PNOTICE_exec.alm 11/14/89 1127.9r w 11/14/89 1127.9 2853 dec 1 "version 1 structure dec 1 "no. of pnotices dec 3 "no. of STIs dec 100 "lgth of all pnotices + no. of pnotices acc "Copyright (c) 1989 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc." aci "C1MXSM0E0000" aci "C2MXSM0E0000" aci "C3MXSM0E0000" end  alloc_.alm 11/11/89 1150.6r w 11/11/89 0805.2 342936 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " alloc_, freen_, area_ " " This module implements the Multics standard area programs. " " Initial coding October 1975 by S Webber. " Modified 3 June 1976 by R Barnes for use with pl1_operators_ " and to properly handle area condition. " Modified 16 August 1976 by R Barnes to fix more bugs and " implement extendable no_free areas " Modified September 1976 by M. Weaver to fix redef entrypoint " Modified 2 November 1976 by M. Weaver to fix zero_on_free bug " Modified 16 November 1976 by R. Barnes to fix bug in extensible areas " Modified 30 November 1976 by M. Asherman to fix bug causing excessive zeroing " on free, which may cause lockup fault " Modified 6 January 1977 to fix area retry for subr call " Modified 3/14/77 (Asherman) to prevent loop creating temp segs on large allocations " Modified 31 May 1977 by RAB to fix 1628 " Modified 12 July 1977 by RAB to fix a bug in which "lcx3 bp|area.next_virgin" " got fixedoverflow " Modified 26 July 1977 by RAB to have alloc_ subr entry init sp|tbp " Modified 9 August 1977 by RAB to not allow allocations of greater than 2**18 words " Modified 10 August 1977 by RAB to change size of largest allocation by 2 words " Modified 13 September 1977 by RAB to fix bug in 9 Aug 1977 change which erroneously " limited allocations to 2**17 words " Modified 14 September 1977 by RAB to fix another fixedoverflow bug in freen_1 " Modified 771018 by PG to add optimization to area_assign_ and fix bugs in it. " Modified 6 September 1978 by RAB to have no_free_alloc do a push if entered by " external call. This is necessary so that area can be properly " signalled and get_next_area_ptr_ can be properly called. " Modified 800109 by PG to run MLR's in area_assign_ uninhibited (MCR 4292). " Modified September 1981 by J. Bongiovanni for IPS protection " """""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " The following entries are included: " " p = alloc_ (size, areap); " p = alloc_$storage_ (size, areap); " call freen_ (p); " call area_ (size, areap); " call area_$no_freeing (size, areap, extend); " call area_$redef (size, areap); " call area_assign_ (new_areap, old_areap); " call area_$extend (areap, flags); " " The following segdef's are included for the use of " pl1_operators_: " " op_alloc_ " op_storage_ " op_freen_ " op_empty_ " " " " " " " " " " " " " " " " " " " " " " " " " " " " NOTE NOTE NOTE NOTE NOTE " " " This routine is used by pl1_operators_ and MUST be bound in with " pl1_operators_. It makes references to code in pl1_operators_ " without establishing its linkage pointer and vice versa. " " NOTE NOTE NOTE NOTE NOTE " " This routine assumes index register 6 (x6) is not changed by the " standard "push" operator. This is because we must remember a " value set before the push and used after the push and there " is no convenient place to save it. " " NOTE NOTE NOTE NOTE NOTE " " This routine protects itself from asynchronous reinvocations within " the same process (IPS signals which interrupt it, and which call " routines while allocate to the area in allocation at the " interruption). It does this by maintaining a counter " (area.allocation_p_clock), which is incremented by 1 in routines " which could conflict with allocation if called asynchronously (other " allocations and frees). After finding a suitable free block, the " saved value is checked in inhibited code against the current value in " the area header. If different, allocation is retried. If the same, " the free block is allocated, unthreaded, etc. in inhibited code. " " This routine is NOT protected against multiple invocations " on different CPUs against the same area. If this is possible " for a given area, it is the responsibility of the caller " to make allocation a critical section. " " " Strategy and conventions. " " The following register assignments are used within this module: " " x0 used to indicate whether or not called as an " operator from a PL/I program. If x0 = 0 then it was called " explicitly as an external entry. If x0 is nonzero, it is " the operator return offset used by standard pl1_operators_. " x1 used as a temporary at various times. " x2 always points to the block being allocated or freed. " x3 points to the block after the one pointed to by x2. Also used " as temporary in certain places. " x4 Used as a pointer to the block to be unthreaded by the " unthread subroutine. Also used as a temporary. " x5 Used to point to the second block after the one pointed to by x2. " Also used as a temporary. " x6 Used to indicate whether "area" or "storage" should be signalled. " x7 Used as temporary. " " ap points to argument list. Not changed. " ab used to hold the return location for the freen_1 subroutine. " bp points at base of area header during execution. At the interface " level, bp points to the block being freed and is returned as " a pointer to the allocated block (operators interface only). " bb used to hold the return location for the unthread " subroutine. " lb points at words containing ptr to block being freed " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Format of a block header: " " " | | " | | " _|________________________________________| /_______ pointed to by x2 " | | | \ " | PREV SIZE | CURRENT SIZE | " _|____________________|____________________| " | | | | | " | MBZ |B| Q_NO | HEADER PTR | " _|__________|__|________|____________________| /_______ allocated storage starts here " | | | \ " | FORWARD POINTER | BACKWARD POINTER | " _|____________________|____________________| " | | " | | " " " The FORWARD and BACKWARD pointers are only filled in and meaningful " if the block is free. If the block is not free, the storage for these " pointers is the first word available for use by the caller. " The flag "B" is the busy bit for the _p_r_e_v_i_o_u_s block. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " The following template is used to define area offsets as well as for intialization of a new area. include area_structures include stack_frame include stack_header " " The following must be the same as used by pl1_operators_. " equ tbp,38 equ buddy_area.size,2 equ buddy_area.inited,3 entry alloc_,storage_,freen_,area_,area_assign_,no_freeing,extend,redef entry old_alloc_,old_freen_,old_area_ segdef op_alloc_,op_storage_,op_freen_,op_empty_ " " The following EQU's define stack variables used by this program. Since " the program is called as an operator as well as externally, " stack variables not used by pl1_operators_ at the time of the " invocation must be used. The regions chosen are the words from 8 to 15, " and 56 to 63. " " equ lsize,8 equ rsize,9 equ blocksize,10 equ temp,11 equ save_x2,12 UPPER equ save_x6,12 LOWER equ save_x0,12 LOWER equ max_size,13 equ save_bp,14 equ free_count,15 equ dtemp1,44 used only for buddy_alloc_op equ dtemp2,46 .. equ arglist,56 equ saved_p_clock,56 shared with arglist equ ret_bp,62 equ min_block_size,8 NOTE. this must be at least 8 because "area.freep has lbound of 4. equ max_version,1 maximum expected version number equ max_method,1 maximum expected allocation method " " " alloc_ " storage_ " op_alloc_ " op_storage_ " " These entries allocate a block of the specified size in the specified " area. If there is not enough room in the area "area" is signalled " unless the area is extensible in which case a new component is found " and the block allocated therein. " " The storage_ entries signal "storage" instead of "area" but are " otherwise identical. " " The alloc_ (and storage_) entry is called as follows: " " blockp = alloc_ (size, areap) " " The operator op_alloc_ (and op_storage_) is called as follows: " " retry: " ldq size " eppbp area_header " tsx0 pr0|allocate_op " tra retry " " a pointer to the allocated block is returned in pr2. " " ________________________________________________ " " The size of the block allocated is increased by 2 to account " for the block header. A fill word may also be allocated in order " to insure that all blocks begin on even word boundaries. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " inhibit on <+><+><+><+><+><+><+><+><+><+><+> op_storage_: eax6 1 indicates we signal "storage" if need arises tra *+2 op_alloc_: eax6 0 indicates we signal "area" if need arises eax0 1,0 we want to return one word later lda bp|area.version check for buddy system areas tze buddy_alloc_op it is buddy system, perform external call tmi signal_area_3 "bad_area_format" cmpa max_version,dl check for expected version tpnz signal_area_3 "bad_area_format" lda bp|area.allocation_method tmi signal_area_3 "bad_area_format" tze standard_alloc_op standard allocation method wanted cmpa max_method,dl check for expected allocation method tpnz signal_area_3 "bad_area_format" tra no_free_alloc_op storage_: eax6 1 indicates we signal "storage" if need arises tra *+2 old_alloc_: alloc_: eax6 0 indicates we signal "area" if need arises eppbp ap|4,* get pointer to area header eppbp bp|0,* .. lda bp|area.version check for old version tze buddy_alloc old version, transfer directly tmi signal_area_p3 bad area format, signal "bad_area_format" cmpa max_version,dl see if expected version number tpnz signal_area_p3 not expected, signal "bad_area_format" lda bp|area.allocation_method dispatch on allocation method tmi signal_area_p3 "bad_area_format" tze standard_alloc standard allocation method needed cmpa max_method,dl check for expected allocation method tpnz signal_area_p3 "bad_area_format" no_free_alloc: push 80 get stack frame lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word epbpbp * give sp|tbp a non-faulting value spribp sp|tbp .. eppbp ap|4,* get area header pointer eppbp bp|0,* .. retry_no_free_alloc_after_area: eax0 0 indicates we are not an operator ref ldq ap|2,* fetch size of block to allocate no_free_alloc_op: eax1 1,ql force even word alignment anx1 -2,du .. lda bp|area.next_virgin get pointer to new block adlx1 bp|area.next_virgin calculate what will be next next_virgin trc no_room_no_free cmpx1 bp|area.last_usable see if overflows trc no_room_no_free yes, overflows. Go handle it. stx1 bp|area.next_virgin update next_virgin pointer eppbp bp|no_free_area.current_component,*au generate return pointer cmpx0 0,du see whether called as operator tnz sp|tbp,*0 was operator, just return spribp ap|6,* external call. return blockp return buddy_alloc: xec get_ptr,6 get pointer to entry to forward call to callsp bp|0 transfer forward... get_ptr: eppbp |[buddy_alloc_] eppbp |[buddy_storage_] buddy_alloc_op: " " We must make an external call to buddy_alloc_$whatever. " spribp sp|dtemp1 save pointer to area sreg sp|8 save registers epbpsb sp|0 get pointer to stack base so we can get lp epaq * get segno of this program lprplp sb|stack_header.lot_ptr,*au get lp eppbp sp|13 get pointer to block size (saved in q with regs) spribp sp|arglist+2 save in argument list eppbp sp|dtemp1 get pointer to area pointer spribp sp|arglist+4 save in argument list eppbp sp|dtemp2 we want buddy_alloc_ to store blockp here spribp sp|arglist+6 fld 3*2048,dl generate arg list header staq sp|arglist .. xec get_ptr,6 get pointer to routine to call eppap sp|arglist get pointer to argument list stcd sp|stack_frame.return_ptr standard call... callsp bp|0 .. lreg sp|8 restore registers eppbp sp|tbp,* must restore return pointer for pl1 frame spribp sp|stack_frame.return_ptr .. eppbp sp|dtemp2,* get blockp tra sp|tbp,*0 return to object program " standard_alloc: push 80 get stack frame large enough lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word epbpbp * give sp|tbp a non-faulting value spribp sp|tbp .. eppbp ap|4,* get area header pointer eppbp bp|0,* .. retry_alloc_after_area: ldq ap|2,* get size of block to allocate tpnz *+2 positive and nonzero is OK ldq min_block_size,dl if negative or zero use min size eax0 0 indicates not operator ref standard_alloc_op: adlq alloc_blkhdrsz+1,dl 1 for rounding canq =o777777,du is the requested block too large to be ever allocated? tnz signal_area yes, then give up. anq -2,dl complete the rounding function qls 18 left justify for compares cmpq min_block_size,du see if requested block is too small trc *+2 large enough, use input value ldq min_block_size,du too small, use minimum value from header stq sp|lsize save in left justified form qrl 18 now right justify stq sp|rsize and save in right justified form " Increment and save a counter identifying this allocation " instance (uniquely over small intervals of time) retry_alloc: lda bp|area.allocation_p_clock allocation instance adla 1,dl this instance (overflows to 0) sta bp|area.allocation_p_clock sta sp|saved_p_clock " " Now search for a large enough block on the free list. " First find the appropriate stratum number and save it. " inhibit off <-><-><-><-><-><-><-><-><-><-><-> fld sp|rsize get desired size lde =26b25,du convert to correct floating pt. value fad =0.0e0,du normalize to get correct exponent ste sp|temp get log2 (size) ldq sp|temp .. qrl 28-18 leave in q-upper cmpq 16,du clip value tmoz stratum_loop if too high ldq 16,du stratum_loop: ldx2 bp|area.freep-3,qu see if anything in free list tze next_stratum nothing on this free list, try next lxl3 bp|area.freep-3,qu get max size for this stratum tze try if the field is zero, we don't know max cmpx3 sp|lsize compare against size we want tnc next_stratum not a large enough block, goto next stratum try: stx2 sp|temp save pointer to head of free list ldx1 40000,du loop check...only allow 40000 steps stz sp|max_size initialize cell used in calculating max size " " Before using the fields in any block, we will check for an IPS " race (asynchronous invocation). The reason for this is that " an asynchronous invocation could have invalidated the block " we are about to examine. If this happen, we will retry from " the beginning. lda sp|saved_p_clock to check for IPS race test_size: cmpa bp|area.allocation_p_clock check for IPS race tnz retry_alloc one has occurred--retry lxl3 bp|block.cur_size,2 get size of this free block from header cmpx3 sp|lsize see if large enough trc large_enough yes... cmpx3 sp|max_size update max size value tnc *+2 .. stx3 sp|max_size .. ldx2 bp|block.fp,2 chain to next free block cmpx2 sp|temp see if we're back to the beginning tze next_stratum_1 yes, try the next stratum eax1 -1,1 count steps tpl test_size loop back if not too many steps tra signal_area_3 signal "bad_area_format" next_stratum_1: ldx1 sp|max_size reset max size for this stratum list sxl1 bp|area.freep-3,qu .. next_stratum: eaq 1,qu skip to next stratum cmpq 17,du see if we've done them all tnc stratum_loop no, keep searching tra use_virgin all used up, take from virgin territory inhibit on <+><+><+><+><+><+><+><+><+><+><+> large_enough: " Check for race with asynchronous invocation (IPS signal) " Race exists if saved allocation instance doesn't match " the one in the header. lda sp|saved_p_clock saved allocation instance cmpa bp|area.allocation_p_clock lose race? tnz retry_alloc yes--retry allocation lca 1,dl update free count in header asa bp|area.n_free .. eax4 0,2 needed by unthread routine tspbb unthread remove block from free list tra *+2 don't save free pointer if nothing in list stx7 bp|area.freep-3,qu implement roving pointer free_merge: stz sp|temp save size of the block stx3 sp|temp .. eax4 sp|temp,*2 x4 -> next block after free block sblx3 sp|lsize get left over size cmpx3 min_block_size,du see if left over will be too small tmoz correct_size the block is the right size, take it stx3 bp|block.prev_size,4 save size of left over free block " " Make a header for the left over block. Also update current header. " ldx5 sp|lsize get size of current block sxl5 bp|block.cur_size,2 save in current header eax5 sp|lsize,*2 get pointer to left over region lda bp|block.header,2 calculate header ptr for new block ana -1,dl .. sbla sp|rsize leaves size of left over region ora block.prev_busy,du turn on busy bit for preceding block sta bp|block.header,5 assumes busy bit in same word with header ptr sxl3 bp|block.cur_size,5 save size of left over block ldx3 sp|lsize get size of newly allocated block stx3 bp|block.prev_size,5 save in new header " " Now make a call to the freen_1 subroutine to free up the left over " block. We must save bp and x2 which are used by that routine. " sprpbp sp|save_bp save what gets wiped by freen_1 stx2 sp|save_x2 eax2 0,5 make x2 -> block to be freed tspab freen_1 free it up lprpbp sp|save_bp ldx2 sp|save_x2 tra return_ptr correct_size: lda block.prev_busy,du turn on busy bit for this block orsa bp|block.prev_busy_word,4 .. tra return_ptr use_virgin: lda bp|area.last_usable get size of virgin storage remaining sbla bp|area.next_virgin .. cmpa sp|lsize see if requested size is too large tnc no_room yes, overflow condition ldx2 bp|area.next_virgin get index to last word used ldx3 bp|area.last_size generate header for new block stx3 bp|block.prev_size,2 .. adlx3 bp|area.last_block update pointer to last allocated block stx3 bp|area.last_block .. ldx3 bp|area.next_virgin (we cannot complement 400000(8) in an xreg) cmpx3 =o400000,du tze 2,ic lcx3 bp|area.next_virgin .. sxl3 bp|block.header,2 .. ldx3 block.prev_busy,du turn busy bit on for previous block stx3 bp|block.prev_busy_word,2 .. lxl3 sp|rsize now update area header stx3 bp|area.last_size .. sxl3 bp|block.cur_size,2 adlx3 bp|area.next_virgin update next available pointer stx3 bp|area.next_virgin .. return_ptr: lda 1,du asa bp|area.n_allocated stz bp|2,2 always zero this word in case the area is being "zerod on free to get zero blocks lda bp|area.flags now see if we should zero the block cana area.zero_on_alloc,du .. tze dont_zero no, just return pointer eppbb bp|3,2 get pointer to first word to zero lda sp|rsize get number of words to clear sbla 3,dl don't zero block header als 2 multiply by 4 for MLR inhibit off <-><-><-><-><-><-><-><-><-><-><-> mlr (),(pr,rl),fill(0) desc9a 0,0 desc9a bb|0,al dont_zero: eppbp bp|2,2 get actual pointer to block cmpx0 0,du see if operator ref tnz sp|tbp,*0 yes, return immediately spribp ap|6,* return it to caller return " " Come here when there is no room in the current area component " for the requested allocation. Check to see if the area is " extensible, and, if so, call to get a pointer to the next " component of the area. " no_room: lda bp|area.flags get flags word from header cana area.extend,du see if the area is extensible tze signal_area no, we must signal "area" ldq sp|rsize see if allocation is impossibly large (rsize includes header size) cmpq 262144-1024-area_size-extend_block_size-alloc_blkhdrsz+1,dl includes extend block and allocated block header overhead trc signal_area block too large even for empty area " " The area is extensible. Get a pointer to the next component. " sxl0 sp|save_x0 epbpsb sp|0 generate linkage pointer epaq * .. lprplp sb|stack_header.lot_ptr,*au spribp sp|save_bp prepare arglist lda 4,du .. ldq 0,du staq sp|arglist eppbp sp|save_bp generate argument list spribp sp|arglist+2 eppbp sp|ret_bp spribp sp|arglist+4 eppap sp|arglist .. stcd sp|stack_frame.return_ptr callsp |[get_next_area_ptr_] lxl0 sp|save_x0 eppbp sp|tbp,* must restore pl1 frame's return pointer spribp sp|stack_frame.return_ptr eppbp sp|ret_bp,* get pointer to next component cmpx0 0,du don't load ap if operator tnz retry_alloc eppap sp|stack_frame.arg_ptr,* must restore argument list pointer tra retry_alloc no_room_no_free: lda bp|area.flags get flags word from header cana area.extend,du see if the area is extendable tze signal_area no, we must signal "area" cmpq 262144-1024-area_size-extend_block_size+1,dl is size too big for empty area? trc signal_area yes--abort " " The no_free area area is extendable, get a pointer to the next component " sreg sp|8 epbpsb sp|0 generate linkage ptr epaq * lprplp sb|stack_header.lot_ptr,*au eppbp bp|no_free_area.current_component generate arg list spribp sp|arglist+2 eppbp sp|ret_bp spribp sp|arglist+4 fld 2*2048,dl staq sp|arglist eppap sp|arglist stcd sp|stack_frame.return_ptr callsp |[get_next_area_ptr_] lreg sp|8 eppbp sp|tbp,* must restore pl1 frame stuff spribp sp|stack_frame.return_ptr cmpx0 0,du don't load ap if operator tnz 2,ic eppap sp|stack_frame.arg_ptr,* " " Hook up new component to first component " epplp sp|ret_bp,* get ptr to new component lda lp|area.extend_info lprpbp lp|extend_block.first_area,au get ptr to first component sprilp bp|no_free_area.current_component lda lp|area.last_usable refresh area info sta bp|area.last_usable .. lda lp|area.next_virgin .. sta bp|area.next_virgin .. tra no_free_alloc_op and try again " " " area_ " op_empty_ " " These routines initialize a given area in the specified way. " The various calling sequences are: " " call area_ (size, areap) " call area_$no_freeing (size, areap, extend) " call area_$extend (size, areap) " call area_$redef (size, areap); " " The op_empty_ entry is called after loading the bp with a " pointer to the area and the q-reg with the size. " " ldq size " eppbp area_header " tsx0 pr0|empty_operator " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " inhibit on <+><+><+><+><+><+><+><+><+><+><+> old_area_: area_: eax1 0 describes type of area being initialized areajoin: eax0 0 indicates not an operator call eppbp ap|4,* get a pointer to what will be the initialized header eppbp bp|0,* .. ldq ap|2,* get size of the area tmoz signal_area_p1 bad value op_join: qls 18 left justify eppbb |[template_area_header] mlr (pr),(pr) desc9a bb|0,area_size*4 desc9a bp|0,area_size*4 stq bp|area.last_usable fill in variable items tra *+1,1* dispatch on initialization type arg standard_area arg no_free_area arg extend_area no_free_area: lda area.dont_free,du make sure free requests are ignored orsa bp|area.flags .. spribp bp|no_free_area.current_component aos bp|area.allocation_method set method type to 1 lda ap|6,* get extend flag tze standard_area extensible area not wanted " " Now allocate a block large enough to hold the extend information. " extend_area: lda area.extend,du set extend flag ON in header orsa bp|area.flags lda extend_block_size+2,du get size for the extend block ldq bp|area.next_virgin get start of new last block asa bp|area.next_virgin update header for new block stq bp|area.extend_info .. stq bp|area.last_block .. sta bp|area.last_size .. eppbb =its(-1,1),* initialize variables in extend block sprpbb bp|extend_block.next_area,qu sprpbp bp|extend_block.first_area,qu standard_area: cmpx0 0,du see if called as operator tnz sp|tbp,*0 yes, return in standard way short_return no_freeing: eax1 1 set initialization type tra areajoin extend: eax1 2 set initialization type tra areajoin op_empty_: eax1 0 set initialization type tra op_join redef: eppbp ap|4,* get pointer to the area eppbp bp|0,* .. lda bp|area.version check version of area tze |[buddy_redef] lxl0 ap|2,* get size to redefine area to have cmpx0 bp|area.next_virgin see if we fit tnc signal_area_p0 no, complain by signalling area stx0 bp|area.last_usable reset end of area short_return " " " area_assign_ " " This entry copies one area into the storage of an already initialized other area. " If the receiving area is not large enough, "area" is signalled. " " call is: " " call area_assign_ (new_areap, old_areap) " " where: " new_areap is the target, pointed to by bp. " old_areap is the source, pointed to by bb. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " area_assign_: eppbp ap|2,* get pointer to new area eppbp bp|0,* .. eppbb ap|4,* get pointer to old area eppbb bb|0,* .. lda bp|area.version check new for buddy or empty area tze new_is_buddy_or_empty new_is_new: lda bb|area.version check old for buddy or empty tze old_is_buddy_or_empty both_are_new: lda bb|area.next_virgin see if enough room cmpa bp|area.last_usable .. tze *+2 ok if equal trc signal_area_p0 ldq bb|area.flags check for need to zero past virgin portion canq area.zero_on_free,du .. tnz assign_and_fill is zero_on_free...needs fill canq area.zero_on_alloc,du check for NO_FREEING & zero_on_alloc tze assign_no_fill isn't zero_on_alloc...don't need fill ldq bb|area.allocation_method cmpq NO_FREEING_ALLOCATION_METHOD,dl tnz assign_no_fill isn't NO_FREEING...doesn't need fill " fall through...is both zero_on_alloc & NO_FREEING " assign_and_fill: ldq bp|area.last_usable get length of target (new) lrl 18-2 get char count in AL, QL inhibit off <-><-><-><-><-><-><-><-><-><-><-> mlr (pr,rl),(pr,rl),fill(000) desc9a bb|0,al source desc9a bp|0,ql target inhibit on <+><+><+><+><+><+><+><+><+><+><+> qls 18-2 restore word count to QU stq bp|area.last_usable restore size of area short_return " assign_no_fill: ldq bp|area.last_usable hold length of target (new) arl 18-2 get char count in AL inhibit off <-><-><-><-><-><-><-><-><-><-><-> mlr (pr,rl),(pr,rl) desc9a bb|0,al source desc9a bp|0,al target inhibit on <+><+><+><+><+><+><+><+><+><+><+> stq bp|area.last_usable restore size of area short_return " new_is_buddy_or_empty: lda bp|buddy_area.inited see if empty tnz new_is_buddy not empty, is buddy eppab |[template_area_header] lda bp|buddy_area.size als 18 inhibit off <-><-><-><-><-><-><-><-><-><-><-> mlr (pr),(pr) desc9a ab|0,area_size*4 desc9a bp|0,area_size*4 inhibit on <+><+><+><+><+><+><+><+><+><+><+> sta bp|area.last_usable tra new_is_new new_is_buddy: lda bb|area.version check version of old area tnz signal_area_p2 old is not buddy - error lda bb|buddy_area.inited see if empty tnz |[buddy_area_assign_] both are buddy - ok tra signal_area_p2 old is empty, new is buddy - error old_is_buddy_or_empty: "already know new is not buddy lda bb|area.version check if buddy or empty tnz both_are_new lda bb|buddy_area.inited tnz signal_area_p2 eppab |[template_area_header] lda bb|buddy_area.size als 18 inhibit off <-><-><-><-><-><-><-><-><-><-><-> mlr (pr),(pr) desc9a ab|0,area_size*4 desc9a bb|0,area_size*4 inhibit on <+><+><+><+><+><+><+><+><+><+><+> sta bb|area.last_usable tra both_are_new signal_area_p0: eax6 0 "area" tra signal_area_p signal_area_p1: eax6 2 "bad_area_initialization" tra signal_area_p signal_area_p2: eax6 3 "bad_area_assignment" tra signal_area_p signal_area_p3: eax6 4 "bad_area_format" signal_area_p: push 80 lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word eax0 0 indicates not pl1_operator_ call tra signal_area inhibit off <-><-><-><-><-><-><-><-><-><-><-> " " " freen_ " op_freen_ " " These entries free up the block pointed to by the input pointer. " The block is merged with adjacent blocks if they are free. " " The call for the external entry is: " " call freen_ (blockp) " " The operator entry (op_freen_) is invoked as follows: " " epplb addr(pointer to block_to_free) " tsx0 pr0|free_op " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " inhibit on <+><+><+><+><+><+><+><+><+><+><+> old_freen_: freen_: eppbp ap|2,* make a check for buddy area before doing push eppbp bp|0,* get pointer to block lda bp|-1 see if buddy area tmi |[buddy_freen_] yes, forward the call push 80 now get a stack frame lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word epplb ap|2,* get pointer to block to free eppbp lb|0,* .. eax0 0 not operator use op_freen_join: " " Get standard register values. x2 -> block, bp -> header. " lxl2 bp|block.header-2 fetch header pointer from block header eppbp bp|-2,2 make bp -> header erx2 -1,du complement C(x2) adlx2 1,du .. lda bp|area.flags check if freeing is enabled cana area.dont_free,du .. tnz free_ret disabled, skip freen_1 subroutine work " lca 1,du decrement used blocks asa bp|area.n_allocated tspab freen_1 do the work in this subroutine free_ret: eppbb =its(-1,1),* null out return pointer spribb lb|0 passed by caller cmpx0 0,du perform appropriate return tnz sp|tbp,*0 return op_freen_: eppbp lb|0,* get pointer to block lda bp|-1 check if buddy area tpl op_freen_join no, use standard code " " We were called as operator to free up old style area's block. " We must make an external call to buddy_freen_. " sprilb sp|arglist+2 save pointer to block pointer sreg sp|8 save registers epbpsb sp|0 get pointer to stack base so we can get lp epaq * get segno of this program lprplp sb|stack_header.lot_ptr,*au get lp lda 4,du generate arg list header ldq 0,du .. staq sp|arglist .. eppap sp|arglist get pointer to argument list stcd sp|stack_frame.return_ptr standard call... callsp |[buddy_freen_] lreg sp|8 restore registers eppbp sp|tbp,* must restore return pointer for pl1 frame spribp sp|stack_frame.return_ptr .. tra sp|tbp,*0 return to object program " " " Subroutine to free the block pointed to by x2. The base " of the area is pointed to by bp. " freen_1: inhibit off <-><-><-><-><-><-><-><-><-><-><-> lda 1,dl keep track of how many blocks are freed sta sp|free_count ldaq bp|0,2 fetch entire header als 18 left justify sta sp|blocksize save for now in accumulating total ldx3 bp|area.flags see if must zero block canx3 area.zero_on_free,du .. tze not_zof dont bother epplp bp|0,2 pointer to block being freed eaa -3,au count of words to zero als 2 count of bytes to zero mlr (),(pr,rl) zero block contents desc9a 0,0 zeroes desc9a lp|3,au bytes to be zeroed after block header not_zof: inhibit on <+><+><+><+><+><+><+><+><+><+><+> lda bp|area.allocation_p_clock guard against IPS race adla 1,dl .. sta bp|area.allocation_p_clock .. eax3 sp|blocksize,*2 x3 -> nextblock canq block.prev_busy,du see if previous block is free tze prev_free no cmpx2 bp|area.last_block see if freeing last block tze free_last_block yes, special case tra check_next no, see if next block is free prev_free: " " The previous block is free. Merge it with the current block. " Accumulate the size of the ultimate free block in blocksize. " lca 1,dl already free, undo previous subtraction asa sp|free_count .. ldx4 bp|block.prev_size,2 get size of previous block stx4 sp|temp adlx4 sp|blocksize update blocksize stx4 sp|blocksize .. stz bp|0,2 in case of zero_on_free stz bp|1,2 clear intervening header words stz bp|2,2 .. " " Thread previous block out of its free list. " eax4 0,2 make x4 point to previous block sblx4 sp|temp .. tspbb unthread thread block out of list nop "ignore if just zerod list cmpx2 bp|area.last_block see if we are freeing the last block tnz not_last no, proceed normally stx4 bp|area.last_block yes, update header variables eax2 0,4 pretend we are freeing the merged block tra free_last_block not_last: eax2 0,4 pretend we are freeing the merged block " See if next block is free. check_next: cmpx3 bp|area.last_block see if next block is last in area tze next_busy yes, it therefore can't be free ldaq bp|0,3 get header for next block als 18 left justify current size sta sp|temp so we can generate a pointer to next header eax4 0,3 set x4 in case needed by unthread eax5 sp|temp,*3 get pointer to following header ldq bp|block.prev_busy_word,5 check if block is free canq block.prev_busy,du .. tnz next_busy " " Next block is free. Merge it with current block. " lcq 1,dl asq sp|free_count adla sp|blocksize update size of free block sta sp|blocksize .. tspbb unthread thread the block out of the free list nop "ignore if just zerod list eax3 0,5 x3 -> next block after free block stz bp|0,4 in case zero_on_free stz bp|1,4 clear header of unthreaded block stz bp|2,4 .. next_busy: ldx1 sp|blocksize get accumulated size of block being freed sxl1 bp|block.cur_size,2 update header of block being freed stx1 bp|block.prev_size,3 .. lcx1 block.prev_busy+1,du turn off busy bit ansx1 bp|block.prev_busy_word,3 .. " Thread the block into free list. " First get stratum number for list to thread into. lda sp|blocksize get size of total block arl 18 convert to integer sta sp|temp save integer form fld sp|temp now perform conversion as in alloc_ entry lde =26b25,du .. fad =0.0e0,du .. ste sp|temp .. ldq sp|temp .. qrl 28-18 .. cmpq 16,du clip if too high tmoz *+2 ldq 16,du eppbb bp|block.q_no_word,2 get pointer to header for storing q_no stcq bb|0,10 save q_no in current header ldx1 bp|area.freep-3,qu get free list pointer tze empty nothing there yet, special case lxl5 bp|block.bp,1 sxl2 bp|block.bp,1 stx1 bp|block.fp,2 stx2 bp|block.fp,5 sxl5 bp|block.bp,2 stx2 bp|area.freep-3,qu roving pointer ... lxl5 bp|area.freep-3,qu update max size if needed tze all_done if zero, must recalculate next full search cmpx5 sp|blocksize see if adding largest block trc all_done no, don't need to change max ldx5 sp|blocksize get new max value out: sxl5 bp|area.freep-3,qu update max size for this list all_done: ldq sp|free_count update count of free blocks asq bp|area.n_free .. tra ab|0 empty: stx2 bp|area.freep-3,qu set free ptr to single entry in list stx2 bp|block.fp,2 make entry point to itself sxl2 bp|block.bp,2 .. ldx5 sp|blocksize get set to update max free size for this list tra out " " The following subroutine is used to thread the block pointed to " by index 4 out of the free list. If this results in an empty free list, " the return is made to bb|0, otherwise, the return is made to " bb|1. " unthread: ldq bp|block.q_no_word,4 get stratum number for this free block anq block.q_no_mask,du .. lxl7 bp|area.freep-3,qu get max entry in list to see if unthreading largest stx7 sp|temp save for compare lxl7 bp|block.cur_size,4 see if unthreading largest entry cmpx7 sp|temp .. tnz not_big not largest, ok eax7 0 zero max size to indicate we don't know it sxl7 bp|area.freep-3,qu .. not_big: ldx7 bp|block.fp,4 x7 -> next link in free chain lxl1 bp|block.bp,4 x1 -> previous link in free chain cmpx4 bp|block.fp,4 are they the same? tze last_free yes, last free block in free list stx7 bp|block.fp,1 thread around the block sxl1 bp|block.bp,7 .. cmpx4 bp|area.freep-3,qu see if pointing to head of list tnz bb|1 no, continue stx7 bp|area.freep-3,qu yes, change head of list tra bb|1 last_free:stz bp|area.freep-3,qu free list now empty, clear pointer word tra bb|0 continue " " " Come here when freeing the last block before virgin territory. " free_last_block: lcq 1,dl decrement count of free blocks asq sp|free_count lda bp|area.last_block update header of area sta bp|area.next_virgin .. ldx3 bp|block.prev_size,2 get size of previous block for header stx3 bp|area.last_size save in header erx3 -1,du complement C(x3) adlx3 1,du adlx3 bp|area.last_block update pointer to last allocated block stx3 bp|area.last_block .. lda sp|blocksize get size of the block stz bp|0,2 clear header words--they will be in virgin territory stz bp|1,2 .. stz bp|2,2 .. tra all_done inhibit off <-><-><-><-><-><-><-><-><-><-><-> " " " Come here when we must signal "area", "storage", or "bad_area_initialization" " signal_area_3: eax6 4 "bad_area_format" tra signal_area signal_area_2: eax6 3 "bad_area_assignment" tra signal_area signal_area_1: eax6 2 "bad_area_initialization" signal_area: cmpx0 0,du were we called as an operator? tze signal_for_subr yes, branch eax0 -1,0 subtract one to point to retry location in caller sxl0 sp|stack_frame.operator_ret_ptr save for call_signal_ tra signal_join signal_for_subr: sxl6 sp|save_x6 save for retry eax1 * set up stack frame for call_signal_ sxl1 sp|stack_frame.operator_ret_ptr epbpbp * spribp sp|tbp signal_join: eppbp name,6* get pointer to name to signal ldx6 length,6 get length of name in x6 ldq 1000,dl get oncode in q tsx1 |[call_signal_] stz sp|stack_frame.operator_ret_ptr clear after signal ldx0 sp|8 restore index 0 saved by call_signal_ tnz sp|tbp,*0 return to pl1 program to retry allocation " lxl6 sp|save_x6 restore for retry eppap sp|stack_frame.arg_ptr,* restore arg pointer eppbp ap|4,* get area header pointer eppbp bp|0,* .. lda bp|area.allocation_method see if no_freeing method used tze retry_alloc_after_area no, go retry it tra retry_no_free_alloc_after_area name: arg area_name arg storage_name arg area_init_name arg bad_assign_name arg bad_area_format_name length: zero 4,0 zero 7,0 zero 23,0 zero 19,0 zero 15,0 area_name: aci "area" storage_name: aci "storage" area_init_name: aci "bad_area_initialization" bad_assign_name: aci "bad_area_assignment" bad_area_format_name: aci "bad_area_format" end  any_to_any_.alm 10/01/90 1629.0rew 10/01/90 1626.2 1655631 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1984 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-04-29,Oke), approve(86-05-30,MCR7424), audit(86-05-30,Mabey), " install(86-06-12,MR12.0-1075): " flt_dec.fix_bin.zero case after mp3d or dv3d assumed length in x3 was " valid, it needed copy from x4. " 2) change(86-04-29,Oke), approve(86-05-30,MCR7424), audit(86-05-30,Mabey), " install(86-06-12,MR12.0-1075): " Scan for bad characters before skipping leading blanks in " char_to_arithmetic_. Otherwise we run off the blank skip table to other " tables, and invalidly accept some bad inputs. " 3) change(86-07-15,Ginter), approve(86-07-15,MCR7435), " audit(86-07-16,Mabey), install(86-07-28,MR12.0-1104): " Change by M Mabey (installed by Ginter) - Conversions from fixed bin " numbers with negative scale factors to float decimal, character, and " bits would fail. " 4) change(90-08-27,Blackmore), approve(90-08-27,MCR8194), " audit(90-09-14,Oke), install(90-10-01,MR12.4-1035): " Fix entry 40 in the arrays 'stype' and 'ttype' to fix treatment of fixed " decimal unsigned 4-bit values (Multics type 40). Also fix treatment of " exponent to floating decimal values during conversion into a bitstring. " END HISTORY COMMENTS " PL/I Conversion Package " " BLW, Spring 1973 " Re-written by T. Oke 1983. SEE MTB-672 for details. " Character input of "" mis-handled. Fixed 84-03-13 by T. Oke " Char to bit fills "0"b to wrong target. Fixed 84-03-14 by T. Oke " Flt Dec to Scaled bin forms bad on zero. Fixed 84-03-16 by T. Oke " Flt Dec to Bit did no offset when replacing exponent. Fixed 84-03-16 " by T. Oke " varying char and bit target routines did not limit to source length. " Fixed 84-04-16 by T. Oke " optimization of flt_bin_to_flt_dec omitted converting the last bit " of the flt bin mantissa. Fixed 84-04-16 by T. Oke " original_source_length length not saved prior to error_205 detection " which calls error_xxx, which uses uninitialized " original_source_length. error_205 now forces string to 256. " PHX17351 Fixed 84-04-19 by T. Oke " Full conversion precision from flt_decimal to flt_bin. Maintained " through use of precision correction determined from upper non-0 " digit of flt_decimal. We convert to flt_bin 70 to flt_bin 71. " Correct error_176 to become error_191. Oncode message 376 does not " exist, but 391 was correct message. " Correct handling of scaled fixed bin to correct the scale factor with " a fixed exponent and produce the right values. " " Installed into MR11 - October 1984. " put_bit of aligned target must pre-clear 1st and possible 2nd word to " avoid padded reference bug. Fixed 84-11-09 by T. Oke " load_flt_dec.target needs to validate 0.0 number to prevent size " condition falsely signalled. Fixed 84-11-09 by T. Oke " flt_dec.fix_bin.zero used length of flt_dec source rather than needed " fix_dec target to convert causing size error. Fixed 84-11-12 by " T. Oke " end_get_fix_dec.normalized used X2 as length of fixed decimal " generic. X2 is invalid at this point, should use X3 instead as " length of float decimal generic to fix exponent. " Fixed 84-11-12 by T. Oke " recognize.no_sign did not skip leading 0's to prevent conversion " errors indicating too many digits. Now leading 0's don't count. " Fixed 84-11-13 by T. Oke " move_char_to_numeric needs to recognize 0-length input. " Fixed 84-11-16 by T. Oke " Fix minimum recognized precision to 1 in case of blank or 0 input. " Fixed 84-11-19 by T. Oke " rtrim source string for char_to_numeric_ input. 84-11-19 by T. Oke " Use pl1_signal_conversion_ rather than " plio2_signal_$conversion_error_. 84-11-20 by T. Oke " 84-11-29 by T. Oke. What is hoped to be the final fix to skipping " leading zeros. Now we remember that an integer part was seen " then remove leading zeros from precision calculation. " 85-02-07 by T. Oke. Moved code in convert_flt_bin_to_flt_hex to " correct rounding test. Somehow mask index code got moved. " Fixed rounding. segdef real_to_real_ segdef real_to_real_round_ segdef real_to_real_truncate_ segdef any_to_any_ segdef any_to_any_round_ segdef any_to_any_truncate_ segdef char_to_numeric_ include eis_micro_ops include pl1_system include stack_header include stack_frame " " mnemonics for CSL instruction " bool move,03 " " description of error extension of stack " equ error_extension,128 size of extension equ save_ptrs,0 equ save_regs,16 equ call_ptr,24 equ arglist,26 equ oncode,save_regs+4 equ onchar_index,save_regs+5 equ name_length,save_regs+5 equ onsource_ptr,save_ptrs+4 assumes s = 2 equ onsource,64 " WORK AREA DESCRIPTION. " " There are two work areas of: " 28 words - Normal numeric to numeric, bit to bit. " 118 words - to character, character to numeric. " Old programs (compiled before release 24) reference two work areas, " of 36 and 156 words. " Token information for character to numeric input. Used by recognize to " build token information from input stream. equ sign_part,0 equ integer_part,1 equ fractional_part,2 equ exponent_part,3 equ type_part,4 equ prec_part,5 " precision and scale equ token_size,6 " number of words in token equ token_length,token_size*4 " five words of 4 chars each macro token_info equ &1_token,&2 " start of token equ &1.sign.index,&2+0 " sign index in DL equ &1.sign.length,&2+0 " sign length in DU equ &1.integer.index,&2+1 " integer part index in DL equ &1.integer.length,&2+1 " integer length in DU equ &1.fraction.index,&2+2 " fraction index in DL equ &1.fraction.length,&2+2 " fraction length in DU equ &1.exponent.value,&2+3 " exponent value equ &1.type,&2+4 " type in DU equ &1.term,&2+4 " encoded terminator in DL equ &1.scale,&2+5 " scale in DU equ &1.prec,&2+5 " prec in DL &endm equ scales,0 equ target_scale,0 (DU) target scale equ target_precision,0 (DL) target precision equ source_scale,1 (DU) source scale equ source_precision,1 (DL) source precision equ source_string_length,1 FULL word equ original_source,2 copy of orig source ptr " GENERIC storage. equ fix_bin_generic,4 DOUBLE WORD equ flt_bin_generic,6 DOUBLE WORD float bin equ flt_bin_generic_exp,10 Exponent for float bin equ flt_dec_generic_exp,11 Exponent for float decimal equ flt_dec_generic,12 float decimal (64) bytes equ fix_dec_generic,12 OVERLAY fix dec (64) bytes equ bit_generic,12 ** OVERLAY flt_dec_generic " " end of short work area (28 words) equ return,28 save_target return pointer equ save_target_ptr,30 t ptr during binary -> char equ generic_ptr,32 source ptr char_to_arithmetic_ equ save_pr4,34 PR4 storage if we destroy equ error_return,36 equ save_target_precision,38 equ save_rounding,39 equ char_generic,40 GENERIC char (256 B, 64 W) equ char_flt_dec_gen,72 generic flt_dec for char equ original_source_length,104 equ save_target_type,105 maclist off save token_info real,106 token_info imag,106+token_size maclist restore " end of long work area (118 words) " character constants bool blank,040 bool plus_sign,053 bool minus_sign,055 bool period,056 bool digit_0,060 bool digit_1,061 bool letter_I,111 bool letter_e,145 bool letter_f,146 bool letter_i,151 " " character classes " equ illegal_class,0 equ sign_class,1 equ period_class,2 equ b_class,3 equ de_class,4 equ i_class,5 equ blank_class,6 equ digit_class,7 equ f_class,8 " base register assignments equ target,1 " points to user's target equ generic,2 " points to current generic (char/bit) equ source,3 " points to user's source equ linkage,4 " destroyed in format/recognize equ work,5 " points to working storage area equ sp,6 " points to current caller's stack " text base ptr in stack frame equ tbp,38 " Indicator bits. bool ind_zero,400000 bool ind_negative,200000 bool ind_carry,100000 bool ind_overflow,040000 bool ind_exp_overflow,020000 bool ind_exp_underflow,010000 bool ind_overflow_mask,004000 " Indicator register fault mask. bool mask_faults,ind_overflow_mask bool unmask_faults,0 " Length of power of two table. equ two_table_limit,197 " Type Codes for numeric to character conversion. equ fix_dec_type,2*9 " real_fix_dec_9bit_ls equ flt_dec_type,2*83 " real_flt_dec_gen " Type code for generic float decimal. equ real_flt_dec_generic,83 equ cplx_flt_dec_generic,84 " Error declaration and handling. " " Errors are managed by masking overflow faults throughout the code, using " the constants "mask_faults" and "unmask_faults". Overflows are detected " through code sequences for range testing, or through the hardware " setting the overflow or exponent overflow bits. Then the correct error " is signalled through a pl1-style call. " " At the moment all errors signalled in this manner are restartable, even " though a "size_error" is declared in documentation as not being " restartable. " " Decimal and float binary range error declaration as underflow or " overflow depend upon the correct sign being present in the " flt_dec_generic_exp and the flt_bin_generic_exp respectively. The " contents can well be shifted to the upper bits, the the word sign bit " must be correct. " " " TESTING " " This program has been tested through the test sub-system "test_a" and " its associated test scripts to assure correct functioning. This test " sub-system should be used to pinpoint and duplicate all reported errors " and to verify correct functioning after error removal. " " Three basic test suites are used: " " fetch_tests.test_a Tests ability to fetch values with minimum " converison done. " store_tests.test_a Tests ability to store results with minimum " conversion done. Pre-requisite is fetch_tests. " c_test.rnd.test_a Tests conversion and fixups with rounding. " Pre-requisites are fetch and store tests. " " When you do any work on assign_ or any_to_any_ please add to these test " suites. " Work Area allocation has been done in two areas, rather than the " previous three areas. " " The first area matches the previous smallest area, and is 28 words in " length. The second area is a total of 118 words in length. The previous " second area was 44 words in length and had a decimal temporary within it. " This functionality has been absorbed within the first area. " " The previous third area was a total of 158 words in length, and its " functionality has been absorbed by the new second area's 118 word length. " " The first area is used for all numeric to numeric conversions, pl1 " bit to bit, and pl1 character to character conversions. The second area is " used for numeric to character and character to numeric and bit conversions. " It is also required if conversions of bit or character input, other than pl1 " type descriptors, are done, where a re-structure of the stream is needed. ANY_TO_ANY_ CALLERS as of: 84-03-19 " References to any_to_any_: (bound_library_wired_ in HARDCORE) " assign_.alm 200 words " put_format_.alm 156 words " References to any_to_any_$any_to_any_round_: (bound_library_wired_ in HARDCORE) " assign_.alm 200 words " formline_.alm 160 words " pl1_operators_.alm passed by user program 'convert' = 164 words " put_format_.alm 156 words " References to any_to_any_$any_to_any_truncate_: (bound_library_wired_ in HARDCORE) " assign_.alm 200 words " formline_.alm 160 words " pl1_operators_.alm passed by user program 'convert' = 164 words " References to any_to_any_$char_to_numeric_: (bound_library_wired_ in HARDCORE) " assign_.alm 200 words " References to any_to_any_$real_to_real_round_: (bound_library_wired_ in HARDCORE) " pl1_operators_.alm passed by user program 'convert' = 164 words " pl1_operators_.alm passed by user program 'convert' = 164 words " Calling sequence and register conventions: " " Entries: " any_to_any_ " any_to_any_round_ " any_to_any_truncate_ " real_to_real_ " real_to_real_round_ " real_to_real_truncate_ " " (pr0) pl1_operators_$operator_table (Not used...must not be changed) " pr1 points to the target. (Input) " pr3 points to the source. (Input) " pr5 caller-supplied work area. See "WORK AREA DESCRIPTION" above. " (Input) " pr6 points to caller's stack frame. (Input) " a contains the length of the target if it " is a string, or the scale of the target in AU " and the precision in AL. (Input) " q contains the length of the source if it " is a string, or the scale of the source in QU " and the precision in QL. (Input) " x0 return offset in calling program. (Input) " x6 contains the type code of the target. (Input) " x7 contains the type code of the source. (Input) " NOTE. We run with overflow faults masked. All exit is done through " " tra unmask_exit " " or by similarly doing an: " " ldi unmask_faults,dl " " prior to exiting routine. Without faults masked we can normally take " overflow conditions and not know to signal properly within the code. any_to_any_truncate_: real_to_real_truncate_: eax5 0 " no rounding tra xfer any_to_any_: real_to_real_: eax5 0 " assume no rounding ldx1 target_type_map,x6 " get flags for target canx1 round,du " check targetfor rounding tze xfer " no rounding, process any_to_any_round_: real_to_real_round_: eax5 1 " round " Dispatch " Scales and precision share the same word. Scales are upper (ldxN). " Precision is lower (lxlN). xfer: staq work|scales " Scales in DU, precision DL cmpx7 source_map_size,du " See if source convertable trc error_bad_type cmpx6 target_map_size,du " See if target convertable trc error_bad_type " Find source conversion to GENERIC stz work|original_source " no stack error extension ldi mask_faults,dl " overflows noted by software lxl3 source_type_map,x7 " get source conversion addr tsp7 0,x3 " conversion ldi mask_faults,dl " reset to permit faults " through with conversion, check for complex target " (Note that char & bit targets return directly to the user, " not to the caller via pr7). " " Source and target pointers have been updated by get and put routines " and are correct for imaginary parts. ldx1 target_type_map,x6 " get flag word for target canx1 complex,du " complex? tze unmask_exit " real target, return lxl1 source_type_map,x7 " get source routine ldx2 source_type_map,x7 canx2 simple,du " check if source is simple tnz unmask_exit canx2 complex,du " check if source is complex tnz convert_complex " convert complex source " Source is not complex, target is, assume zero imaginary part. " Zero generic type of source in work area and then convert it. ldx3 source_type_map,x6 " Get GENERIC type anx3 generic_mask,du tra zero_generic,x3* " zero work area zero_fixed_bin: " Zero GENERIC fixed bin stz work|fix_bin_generic stz work|fix_bin_generic+1 ldx1 fix_bin_generic_conversion,du tra convert_complex zero_float_bin: " Zero GENERIC float bin stz work|flt_bin_generic_exp stz work|flt_bin_generic stz work|flt_bin_generic+1 ldx1 flt_bin_generic_conversion,du tra convert_complex zero_float_dec: " Zero GENERIC float decimal ldx3 default_flt_dec_p,du " length of decimal mvn (),(pr,rl) desc9ls dec_zero,2 desc9fl work|flt_dec_generic,x3 stz work|flt_dec_generic_exp ldx1 flt_dec_generic_conversion,du " tra convert_complex convert_complex: ldi mask_faults,dl " mask for conversion faults tsp7 0,x1 " Convert imaginary to target " Unmask faults for exit. unmask_exit: ldi unmask_faults,dl szn work|original_source " was stack extended? tze exit.1 epbp7 sp|0 " get ptr to base of stack inhibit on <+><+><+><+><+><+><+><+><+><+><+> epp2 sb|stack_header.stack_end_ptr,* " throw extension epp2 pr2|-error_extension spri2 sb|stack_header.stack_end_ptr spri2 sp|stack_frame.next_sp inhibit off <-><-><-><-><-><-><-><-><-><-><-> " Setup A and X7 as if for char_to_numeric_ exit.1: lda work|target_precision " scale (DU), precision (DL) eax7 0,x6 " source type used tra sp|tbp,*x0 " return to caller " CHAR_TO_NUMERIC_ " Externally available interface. " " procedure to convert a number to its syntactic numeric form " and return such information to caller " entered with: " source ptr in pr3 " target ptr in pr1 (must be double-word aligned) " work ptr in pr5 " source length in q " rounding called if x5 non-zero " " exits with: " number stored in target " number type in x7 " number precision in al " number scale in au char_to_numeric_: ldi mask_faults,dl " mask fault on indicators ldx6 0,du " flag target of opportunity stq work|source_string_length epp generic,source|0 " point to source tra char_to_arithmetic " convert " Case table used for zeroing source GENERIC work area zero_generic: arg error_bad_type arg zero_fixed_bin " fixed bin signed arg zero_float_bin " float bin arg zero_float_dec " float decimal arg zero_fixed_bin " fixed bin unsigned " Following is both a 2 character fixed decimal 0 and a 3 character " float decimal 0.0 (normalized). dec_zero: aci "+0" " Following instruction sets are used by execute instructions. Double " pairing is typically used for no-round/round with X5 keying exec. mvn.pr_rl.pr_rl: mvn (pr,rl),(pr,rl) mvn (pr,rl),(pr,rl),round dv3d.id.pr.pr_rl: dv3d (id),(pr),(pr,rl) dv3d (id),(pr),(pr,rl),round dv3d.id.pr_rl.pr_rl: dv3d (id),(pr,rl),(pr,rl) dv3d (id),(pr,rl),(pr,rl),round mp3d.id.pr_rl.pr_rl: mp3d (id),(pr,rl),(pr,rl) " index 0 (truncate) mp3d (id),(pr,rl),(pr,rl),round " index 1 (round) dv3d.id.pr_rl.pr: dv3d (id),(pr,rl),(pr) dv3d (id),(pr,rl),(pr),round mp3d.id.pr_rl.pr: mp3d (id),(pr,rl),(pr) mp3d (id),(pr,rl),(pr),round " Macro Definitions for table driving. " macros to define type tables. " " arg1 - Internal routine to convert source or target. " arg2 - Generic internal data type. " arg3 - FLAGS expression. " maclist off save " Table for source conversion macro stype vfd 12/(&3)/64,6/&2,18/get_&1 vfd 12/(&3)/64,6/&2,18/get_&1_packed &end " Table for target conversion macro ttype vfd 12/(&3)/64,6/&2,18/put_&1 vfd 12/(&3)/64,6/&2,18/put_&1_packed &end " Following flags are used to determine what should be done with a " data type. " " round indicates the default is to round the target. " complex indicates the target or source is complex. " short indicates the target is 1 word float bin for rounding. bool round,400000 " round bool complex,200000 " complex bool short,100000 " single word flt bin bool varying,040000 " varying bit or char string bool simple,020000 " type is not complex bool fix,010000 " data type is fixed " The following fields are used to mask out portions of the source and " target tables to recover fields. DU, DL is significant. " " flag_mask recovers the field containing flags. " generic_mask recovers the field indicating GENERIC type. " type_mask recovers the offset to the conversion routine. bool flag_mask,777700 " DU bool generic_mask,000077 " DU bool type_mask,777777 " DL " The following table contains the the GENERIC data type numbers. equ FIXED_BIN,1 equ FLOAT_BIN,2 equ FLOAT_DEC,3 equ FIXED_BIN_UNS,4 equ BIT,5 equ CHAR,6 " Fixed binary is divided into FIXED_BIN and FIXED_BIN_UNS because there " are distinct operational differences between the two, particularly since " a FIXED_BIN_UNS number can appear negative if viewed as a FIXED_BIN " number, and right shifts to normalize a FIXED_BIN_UNS number need to be " done with LOGICAL rather than arithmetic operations. " mapped input type source_type_map: "( 0); stype ERROR,0 " FILLER of ERROR "( 1); stype fix_bin_1,FIXED_BIN,fix " fixed binary short "( 2); stype fix_bin_2,FIXED_BIN,fix " fixed binary long "( 3); stype flt_bin_1,FLOAT_BIN,round " float binary short "( 4); stype flt_bin_2,FLOAT_BIN,round " float binary long "( 5); stype fix_bin_1,FIXED_BIN,(complex+fix) " complex fixed binary short "( 6); stype fix_bin_2,FIXED_BIN,(complex+fix) " complex fixed binary long "( 7); stype flt_bin_1,FLOAT_BIN,(round+complex)" complex float binary short "( 8); stype flt_bin_2,FLOAT_BIN,(round+complex)" complex float binary long "( 9); stype fix_dec_9ls,FLOAT_DEC,fix " fixed decimal 9-bit "(10); stype flt_dec_9,FLOAT_DEC,round " float decimal 9-bit "(11); stype fix_dec_9ls,FLOAT_DEC,(complex+fix) " complex fixed decimal 9-bit "(12); stype flt_dec_9,FLOAT_DEC,(round+complex) " complex float decimal 9-bit "(13); stype ERROR,0 " pointer "(14); stype ERROR,0 " offset "(15); stype ERROR,0 " label "(16); stype ERROR,0 " entry "(17); stype ERROR,0 " structure "(18); stype ERROR,0 " area "(19); stype bit,BIT " bit "(20); stype varying_bit,BIT,varying " varying bit "(21); stype char,CHAR " character "(22); stype varying_char,CHAR,varying " varying character "(23); stype ERROR,0 " file "(24); stype ERROR,0 " label constant runtime "(25); stype ERROR,0 " int entry runtime "(26); stype ERROR,0 " ext entry runtime "(27); stype ERROR,0 " ext procedure runtime "(28); stype ERROR,0 " RESERVED (type 28) "(29); stype fix_dec_9ls_ovrp,FLOAT_DEC,fix " fixed dec leading overpunch 9-bit "(30); stype fix_dec_9ts_ovrp,FLOAT_DEC,fix " fixed dec trailing overpunch 9-bit "(31); stype ERROR,0 " RESERVED (type 31) "(32); stype ERROR,0 " RESERVED (type 32) "(33); stype fix_bin_1uns,FIXED_BIN_UNS,fix " fixed binary unsigned short "(34); stype fix_bin_2uns,FIXED_BIN_UNS,fix " fixed binary unsigned long "(35); stype fix_dec_9uns,FLOAT_DEC,fix " fixed decimal unsigned 9-bit "(36); stype fix_dec_9ts,FLOAT_DEC,fix " fixed decimal trailing sign 9-bit "(37); stype fix_dec_9ts,FLOAT_DEC,(complex+fix) " complex fixed decimal trailing sign (future??) "(38); stype fix_dec_4uns,FLOAT_DEC,fix " fixed decimal unsigned 4-bit "(39); stype fix_dec_4ts,FLOAT_DEC,fix " fixed decimal trailing sign 4-bit "(40); stype fix_dec_4uns,FLOAT_DEC,fix " fixed decimal unsigned 4-bit byte-aligned "(41); stype fix_dec_4ls,FLOAT_DEC,fix " fixed decimal leading sign 4-bit "(42); stype flt_dec_4,FLOAT_DEC,round " float decimal 4-bit "(43); stype fix_dec_4ls,FLOAT_DEC,fix " decimal leading sign 4-bit byte-aligned "(44); stype flt_dec_4,FLOAT_DEC,round " float decimal 4-bit byte-aligned "(45); stype fix_dec_4ls,FLOAT_DEC,(complex+fix) " complex fixed decimal leading sign 4-bit byte-aligned "(46); stype flt_dec_4,FLOAT_DEC,(complex+round) " cplx float decimal 4-bit byte-aligned "(47); stype flt_hex_1,FLOAT_BIN,round " float hex single "(48); stype flt_hex_2,FLOAT_BIN,round " float hex double "(49); stype flt_hex_1,FLOAT_BIN,(round+complex) " complex float hex single "(50); stype flt_hex_2,FLOAT_BIN,(round+complex) " complex float hex double "(51); stype ERROR,0 " RESERVED (type 51) "(52); stype ERROR,0 " RESERVED (type 52) "(53); stype ERROR,0 " RESERVED (type 53) "(54); stype ERROR,0 " RESERVED (type 54) "(55); stype ERROR,0 " RESERVED (type 55) "(56); stype ERROR,0 " RESERVED (type 56) "(57); stype ERROR,0 " RESERVED (type 57) "(58); stype ERROR,0 " ESCAPE (type 58) "(59); stype ERROR,0 " algol68 straight "(60); stype ERROR,0 " algol68 format "(61); stype ERROR,0 " algol68 array descriptor "(62); stype ERROR,0 " algol68 union "(63); stype ERROR,0 " picture runtime "(64); stype ERROR,0 " EXTRA (64) "(65); stype ERROR,0 " EXTRA (65) "(66); stype ERROR,0 " EXTRA (66) "(67); stype ERROR,0 " EXTRA (67) "(68); stype ERROR,0 " EXTRA (68) "(69); stype ERROR,0 " EXTRA (69) "(70); stype ERROR,0 " EXTRA (70) "(71); stype ERROR,0 " EXTRA (71) "(72); stype ERROR,0 " EXTRA (72) "(73); stype ERROR,0 " EXTRA (73) "(74); stype ERROR,0 " EXTRA (74) "(75); stype ERROR,0 " EXTRA (75) "(76); stype ERROR,0 " EXTRA (76) "(77); stype ERROR,0 " EXTRA (77) "(78); stype ERROR,0 " EXTRA (78) "(79); stype ERROR,0 " EXTRA (79) "(80); stype ERROR,0 " EXTRA (80) "(81); stype flt_dec_ext,FLOAT_DEC,round " float dec extended "(82); stype flt_dec_ext,FLOAT_DEC,(round+complex) " complex float dec extended "(83); stype flt_dec_gen,FLOAT_DEC,round " float dec generic "(84); stype flt_dec_gen,FLOAT_DEC,(round+complex) " complex float dec generic "(85); stype flt_bin_gen,FLOAT_BIN,round " float bin generic "(86); stype flt_bin_gen,FLOAT_BIN,(round+complex) " complex float bin generic equ source_map_size,*-source_type_map " mapped output type target_type_map: "( 0); ttype ERROR,0 " FILLER of ERROR "( 1); ttype fix_bin_1,FIXED_BIN " fixed binary short "( 2); ttype fix_bin_2,FIXED_BIN " fixed binary long "( 3); ttype flt_bin_1,FLOAT_BIN,(round+short) " float binary short "( 4); ttype flt_bin_2,FLOAT_BIN,round " float binary long "( 5); ttype fix_bin_1,FIXED_BIN,complex " complex fixed binary short "( 6); ttype fix_bin_2,FIXED_BIN,complex " complex fixed binary long "( 7); ttype flt_bin_1,FLOAT_BIN,(round+complex+short)" complex float binary short "( 8); ttype flt_bin_2,FLOAT_BIN,(round+complex)" complex float binary long "( 9); ttype fix_dec_9ls,FLOAT_DEC " fixed decimal 9-bit "(10); ttype flt_dec_9,FLOAT_DEC,round " float decimal 9-bit "(11); ttype fix_dec_9ls,FLOAT_DEC,complex " complex fixed decimal 9-bit "(12); ttype flt_dec_9,FLOAT_DEC,(round+complex) " complex float decimal 9-bit "(13); ttype ERROR,0 " pointer "(14); ttype ERROR,0 " offset "(15); ttype ERROR,0 " label "(16); ttype ERROR,0 " entry "(17); ttype ERROR,0 " structure "(18); ttype ERROR,0 " area "(19); ttype bit,BIT " bit "(20); ttype varying_bit,BIT,varying " varying bit "(21); ttype char,CHAR " character "(22); ttype varying_char,CHAR,varying " varying character "(23); ttype ERROR,0 " file "(24); ttype ERROR,0 " label constant runtime "(25); ttype ERROR,0 " int entry runtime "(26); ttype ERROR,0 " ext entry runtime "(27); ttype ERROR,0 " ext procedure runtime "(28); ttype ERROR,0 " RESERVED (type 28) "(29); ttype fix_dec_9ls_ovrp,FLOAT_DEC " fixed dec leading overpunch 9-bit "(30); ttype fix_dec_9ts_ovrp,FLOAT_DEC " fixed dec trailing overpunch 9-bit "(31); ttype ERROR,0 " RESERVED (type 31) "(32); ttype ERROR,0 " RESERVED (type 32) "(33); ttype fix_bin_1uns,FIXED_BIN_UNS " fixed binary unsigned short "(34); ttype fix_bin_2uns,FIXED_BIN_UNS " fixed binary unsigned long "(35); ttype fix_dec_9uns,FLOAT_DEC " fixed decimal unsigned 9-bit "(36); ttype fix_dec_9ts,FLOAT_DEC " fixed decimal trailing sign 9-bit "(37); ttype fix_dec_9ts,FLOAT_DEC,complex " complex fixed decimal trailing sign (future??) "(38); ttype fix_dec_4uns,FLOAT_DEC " fixed decimal unsigned 4-bit "(39); ttype fix_dec_4ts,FLOAT_DEC " fixed decimal trailing sign 4-bit "(40); ttype fix_dec_4uns,FLOAT_DEC " fixed decimal unsigned 4-bit byte-aligned "(41); ttype fix_dec_4ls,FLOAT_DEC " fixed decimal leading sign 4-bit "(42); ttype flt_dec_4,FLOAT_DEC,round " float decimal 4-bit "(43); ttype fix_dec_4ls,FLOAT_DEC " decimal leading sign 4-bit byte-aligned "(44); ttype flt_dec_4,FLOAT_DEC,round " float decimal 4-bit byte-aligned "(45); ttype fix_dec_4ls,FLOAT_DEC,complex " complex fixed decimal leading sign 4-bit byte-aligned "(46); ttype flt_dec_4,FLOAT_DEC,(complex+round) " cplx float decimal 4-bit byte-aligned "(47); ttype flt_hex_1,FLOAT_BIN,round " float hex single "(48); ttype flt_hex_2,FLOAT_BIN,round " float hex double "(49); ttype flt_hex_1,FLOAT_BIN,(round+complex) " complex float hex single "(50); ttype flt_hex_2,FLOAT_BIN,(round+complex) " complex float hex double "(51); ttype ERROR,0 " RESERVED (type 51) "(52); ttype ERROR,0 " RESERVED (type 52) "(53); ttype ERROR,0 " RESERVED (type 53) "(54); ttype ERROR,0 " RESERVED (type 54) "(55); ttype ERROR,0 " RESERVED (type 55) "(56); ttype ERROR,0 " RESERVED (type 56) "(57); ttype ERROR,0 " RESERVED (type 57) "(58); ttype ERROR,0 " ESCAPE (type 58) "(59); ttype ERROR,0 " algol68 straight "(60); ttype ERROR,0 " algol68 format "(61); ttype ERROR,0 " algol68 array descriptor "(62); ttype ERROR,0 " algol68 union "(63); ttype ERROR,0 " picture runtime "(64); ttype ERROR,0 " EXTRA (64) "(65); ttype ERROR,0 " EXTRA (65) "(66); ttype ERROR,0 " EXTRA (66) "(67); ttype ERROR,0 " EXTRA (67) "(68); ttype ERROR,0 " EXTRA (68) "(69); ttype ERROR,0 " EXTRA (69) "(70); ttype ERROR,0 " EXTRA (70) "(71); ttype ERROR,0 " EXTRA (71) "(72); ttype ERROR,0 " EXTRA (72) "(73); ttype ERROR,0 " EXTRA (73) "(74); ttype ERROR,0 " EXTRA (74) "(75); ttype ERROR,0 " EXTRA (75) "(76); ttype ERROR,0 " EXTRA (76) "(77); ttype ERROR,0 " EXTRA (77) "(78); ttype ERROR,0 " EXTRA (78) "(79); ttype ERROR,0 " EXTRA (79) "(80); ttype ERROR,0 " EXTRA (80) "(81); ttype flt_dec_ext,FLOAT_DEC,round " float dec extended "(82); ttype flt_dec_ext,FLOAT_DEC,(round+complex) " complex float dec extended "(83); ttype flt_dec_gen,FLOAT_DEC,round " float dec generic "(84); ttype flt_dec_gen,FLOAT_DEC,(round+complex) " complex float dec generic "(85); ttype flt_bin_gen,FLOAT_BIN,round " float bin generic "(86); ttype flt_bin_gen,FLOAT_BIN,(round+complex) " complex float bin generic equ target_map_size,*-target_type_map maclist restore " Register conventions for source GET routines. " (all routines specified in the table below). All registers named below, " must be preserved by the conversion routine. " " pr0 (reserved - pl1_operators_ ptr) " pr1 points to target. " pr2 points to generic data area " pr3 points to source. " pr5 points to work area. " pr6 (reserved - stack_frame ptr) " pr7 points to return location in any_to_any_. " x0 return offset in user program. " x5 0 if no round, 1 if round. " x6 target type. " x7 source type. " work|scales stored scales (in upper halves) " work|precisions stored precisions (in lower halves) " " Decimal GET routines leave X3 as the size of the floating decimal " generic variable, including sign and hardware exponent. " Conversion rules go that source and target pointers are updated by the GET " and PUT routines respectively, thus they are always up-to-date by the " end of the conversion. This makes converting real and imaginary parts " quite easy. If range errors are detected, they are signalled as " appropriate through the singalling routines at the end of this program. " Depending upon the type of error signalled, return is done to a float " bin or float decimal generic converison, to continue the conversion of a " 0.0 quantity. Fixed bin conversion errors simply return. " " Conditions of calling conversion routines: " " Fixed Bin: 72-bit value is expected in work|fix_bin_generic. " Float Bin: 72-bit value is expected in work|flt_bin_generic, " 36-bit exponent is expected in work|flt_bin_generic_exp. " Float Decimal:X3 has the length of the float decimal number, including " the sign and a byte for the hardware exponent. The float " decimal number is left in work|flt_dec_generic and the " 36-bit software exponent is in work|flt_dec_generic_exp. " Fixed Bin uns:72-bit value is expected in work|fix_bin_generic. " Bit: Bit value is pointed to by generic|0. If necessary the " area work|bit_generic can be used for internal storage, BUT " it overlays work|flt_dec_generic. This conflict must be " remembered in conversion routines. In a varying bit string " the pointer points at the start of the bit stream, which is " one word beyond the length word. X3 is the length of the " bit string (up to 256 bits). " Char: Character string is pointed to by generic|0. If necessary " the area work|char_generic can be used for internal storage " and does not conflict with other storage. X3 is the length " of the character string (up to 256 characters). In a " varying character string the pointer points at the start of " the character stream, which is one word beyond the length " word. " " All character conversions require the large work area. Fixed Binary Source Conversion to GENERIC " Unsigned Cases get_fix_bin_1uns: " Fixed bin single word unsigned lda source|0 " load value lrl 36 " position to Q, clear A staq work|fix_bin_generic epp source,source|1 " update source pointer tra fix_bin_uns_generic_conversion get_fix_bin_1uns_packed: " Packed fixed bin single unsigned get_fix_bin_2uns_packed: " Packed fixed bin double unsigned lxl2 work|source_precision csl (pr,rl),(pr,rl),bool(move) descb source|0,x2 descb work|fix_bin_generic,x2 abd source|0,x2 " update source pointer ldaq work|fix_bin_generic erx2 =o777777,du " form 2's complement precision lrl 72+1,2 " position result unsigned staq work|fix_bin_generic tra fix_bin_uns_generic_conversion get_fix_bin_2uns: " Fixed bin double word to GENERIC ldaq source|0 " load value staq work|fix_bin_generic epp source,source|2 " update source pointer tra fix_bin_uns_generic_conversion " Signed Cases get_fix_bin_1: " Fixed bin single word to GENERIC lda source|0 " load value lrs 36 " position and sign extend staq work|fix_bin_generic epp source,source|1 tra fix_bin_generic_conversion get_fix_bin_1_packed: " Packed fixed bin single to GENERIC get_fix_bin_2_packed: " Packed fixed bin double to GENERIC lxl2 work|source_precision adx2 =1,du " account for sign csl (pr,rl),(pr,rl),bool(move) descb source|0,x2 descb work|fix_bin_generic,x2 abd source|0,x2 " update source pointer ldaq work|fix_bin_generic erx2 =o777777,du " form 2's complement precision lrs 72+1,2 " position result staq work|fix_bin_generic tra fix_bin_generic_conversion get_fix_bin_2: " Fixed bin double word to GENERIC fb (71) ldaq source|0 " load value staq work|fix_bin_generic epp source,source|2 " update source pointer tra fix_bin_generic_conversion " Floating Binary Source Conversion to GENERIC get_flt_bin_1: " Floating binary single to generic fld source|0 epp source,source|1 " update source pointer tra end_get_flt_bin get_flt_bin_1_packed: " Floating binary single packed to generic get_flt_bin_2_packed: " Floating binary double packed to generic lxl2 work|source_precision adx2 =9,du " account for sign and exponent csl (pr,rl),(pr),bool(move),fill(0) descb source|0,x2 descb work|flt_bin_generic,72 dfld work|flt_bin_generic abd source|0,x2 " update source pointer tra end_get_flt_bin get_flt_bin_2: " Floating binary double to generic dfld source|0 epp source,source|2 " update source pointer " tra end_get_flt_bin end_get_flt_bin: tnz get_flt_bin.zero " Not zero store as indicated stz work|flt_bin_generic_exp stz work|flt_bin_generic stz work|flt_bin_generic+1 tra flt_bin_generic_conversion " Store absolute zero get_flt_bin.zero: ste work|flt_bin_generic_exp staq work|flt_bin_generic lda work|flt_bin_generic_exp ars 36-8 " position in full exponent sta work|flt_bin_generic_exp tra flt_bin_generic_conversion " Get a GENERIC floating binary value. Storage form is: " " Double word aligned. " " AQ portion of EAQ. Full 72 bits stored. " fixed bin (35) exponent value. " PAD word. get_flt_bin_gen: " Floating binary generic to internal dfld source|0 " move mantissa, 0->exp staq work|flt_bin_generic lde 0,du lda source|2 sta work|flt_bin_generic_exp epp source,source|4 " update source pointer tra flt_bin_generic_conversion " Floating Hexadecimal Source Conversion to GENERIC get_flt_hex_1: " Floating hex single to generic fld source|0 epp source,source|1 " update source pointer tra end_get_flt_hex get_flt_hex_1_packed: " Floating hex single packed to generic get_flt_hex_2_packed: " Floating hex double packed to generic lxl2 work|source_precision adx2 =9,du " account for sign and exponent csl (pr,rl),(pr),bool(move),fill(0) descb source|0,x2 descb work|flt_bin_generic,72 dfld work|flt_bin_generic abd source|0,x2 " update source pointer tra end_get_flt_hex get_flt_hex_2: " Floating hex double to generic dfld source|0 epp source,source|2 " update source pointer " tra end_get_flt_hex end_get_flt_hex: tnz get_flt_hex.nz " Not zero - store as indicated stz work|flt_bin_generic_exp stz work|flt_bin_generic stz work|flt_bin_generic+1 tra flt_bin_generic_conversion " Store absolute zero " Non-Zero Floating HEXADECIMAL - convert to extended floating binary get_flt_hex.nz: ste work|flt_bin_generic_exp lde =0,du " normalize to binary from hex fno ste work|flt_dec_generic_exp lde =0,du " save 0 exponent staq work|flt_bin_generic lda work|flt_bin_generic_exp " position for full range ars 36-8-2 " single bit shift sta work|flt_bin_generic_exp lda work|flt_dec_generic_exp " get binary correction ars 36-8 asa work|flt_bin_generic_exp " include hex exponent tra flt_bin_generic_conversion " Fixed Decimal 9-bit Source Conversion to GENERIC " ****NOTE**** - X2 MUST contain the fixed decimal length at the point " end_get_fix_dec.normalize is called. These initial routines leave " generic pointing to a 9-bit leading signed fixed decimal number. The " final conversion to GENERIC float dec is done by " end_get_fix_dec.normalize. " 9-bit Leading Sign Case get_fix_dec_9ls: " Actual work done in get_fix_dec_9ls_packed: " end_get_fix_dec.normalize lxl2 work|source_precision adx2 =1,du " count sign in size epp generic,source|0 " point to source a9bd source|0,x2 " update source pointer tra end_get_fix_dec.normalize " 9-bit Leading Sign Overpunched Case get_fix_dec_9ls_ovrp: get_fix_dec_9ls_ovrp_packed: lxl3 work|source_precision eax2 1,x3 " Count sign " Move mantissa including overpunched sign, skip sign of generic FD mlr (pr,rl),(pr,rl) desc9a source|0,x3 desc9a work|fix_dec_generic(1),x3 " Translate overpunched sign to sign and leading digit scm (),(pr),mask(000) " Determine index of sign desc9a overpunch_9_source,20 " Conversion table desc9a source|0,1 " overpunch arg work|flt_dec_generic_exp " index result ttn error_bad_type " not convertable lda work|flt_dec_generic_exp als 1 " *2 for char index mlr (al),(pr) " Move in correct codes desc9a overpunch_9_chars,2 desc9a work|fix_dec_generic,2 epp generic,work|flt_dec_generic " point to 9bit_ls a9bd source|0,x3 " update source pointer tra end_get_fix_dec.normalize " 9-bit Trailing Sign Overpunched Case get_fix_dec_9ts_ovrp: get_fix_dec_9ts_ovrp_packed: lxl3 work|source_precision eax2 1,x3 " Count sign " Move mantissa including overpunched sign, skip sign of generic FD mlr (pr,rl),(pr,rl) desc9a source|0,x3 desc9a work|fix_dec_generic(1),x3 " Translate overpunched sign to sign and leading digit scm (),(pr,x3),mask(000) " Determine index of sign desc9a overpunch_9_source,20 " Conversion table desc9a source|-1(3),1 " overpunch arg work|flt_dec_generic_exp " index result ttn error_bad_type " not convertable lda work|flt_dec_generic_exp mlr (al),(pr) " Move sign desc9a overpunch_9_signs,1 desc9a work|fix_dec_generic,1 mlr (al),(pr,x3) " Fixup trailing digit desc9a overpunch_9_digits,1 desc9a work|fix_dec_generic,1 epp generic,work|flt_dec_generic " point to 9bit_ls a9bd source|0,x3 " update source pointer tra end_get_fix_dec.normalize Fixed Decimal 9-bit Source Conversion to GENERIC " 9-bit Unsigned Case get_fix_dec_9uns: get_fix_dec_9uns_packed: lxl4 work|source_precision eax2 1,x4 " length of leading sign result eax3 1,x2 " size of floating result mvn (pr,rl),(pr,rl) desc9ns source|0,x4 desc9fl work|flt_dec_generic,x3 a9bd source|0,x3 " update source pointer tra end_get_fix_dec.normalized " 9-bit Trailing Sign Case get_fix_dec_9ts: get_fix_dec_9ts_packed: lxl3 work|source_precision eax2 1,x3 " size of signed result eax3 1,x2 " size of floating result mvn (pr,rl),(pr,rl) desc9ts source|0,x2 desc9fl work|flt_dec_generic,x3 a9bd source|0,x2 " update source pointer tra end_get_fix_dec.normalized " Table used to determine overpunch conversion. Index provides " conversion reference to an overpunch character table. overpunch_9_source: " used to translate overpunch to table index aci /{ABCDEFGHI}JKLMNOPQR/,20 " ++++++++++---------- " 01234567890123456789 overpunch_9_signs: " overpunch sign aci /++++++++++----------/,20 overpunch_9_digits: " overpunch digit aci /01234567890123456789/,20 overpunch_9_chars: " index*2 to get sign and leading digit aci /+0+1+2+3+4+5+6+7+8+9-0-1-2-3-4-5-6-7-8-9/,40 " Fixed Decimal 4-bit Source Conversion to GENERIC " Fourbit source is byte aligned. Thus we round to next byte in setting " the source pointer update. " 4-bit Leading Sign Case get_fix_dec_4ls: get_fix_dec_4ls_packed: lxl2 work|source_precision adx2 1,du " count sign in size eax3 1,x2 " size of floating result mvn (pr,rl),(pr,rl) desc4ls source|0,x2 desc9fl work|flt_dec_generic,x3 eax2 1,x2 " byte align update anx2 =o777776,du a4bd source|0,x2 " update source pointer tra end_get_fix_dec.normalized " 4-bit Unsigned Case get_fix_dec_4uns: get_fix_dec_4uns_packed: lxl4 work|source_precision eax2 1,x4 " count sign in size eax3 1,x2 " size of floating result mvn (pr,rl),(pr,rl) desc4ns source|0,x4 desc9fl work|flt_dec_generic,x3 eax4 1,x4 " byte align update anx4 =o777776,du a4bd source|0,x4 " update source pointer tra end_get_fix_dec.normalized " 4-bit Trailing Sign Case get_fix_dec_4ts: get_fix_dec_4ts_packed: lxl3 work|source_precision eax2 1,x3 " size of signed result eax3 1,x2 " size of floating result mvn (pr,rl),(pr,rl) " move unsigned mantissa desc4ts source|0,x2 desc9fl work|flt_dec_generic,x3 eax2 1,x2 " byte align update anx2 =o777776,du a4bd source|0,x2 " update source pointer tra end_get_fix_dec.normalized " Normalize fixed decimal to floating decimal " A source decimal mantissa is currently setup with a correct " fixed decimal value. This is now moved in place to a floating decimal " format to establish the 8-bit exponent and round as necessary. From this " the full floating decimal extended exponent is formed, taking into " account a possible fixed decimal scale factor. " " On entry generic points to source to convert. This is simple source pointer " for 9bit_ls, or flt_dec_generic pre-cooked to 9bit_ls for others. " " X3 is precision on exit including exponent and sign. end_get_fix_dec.normalize: eax3 1,x2 " Count byte for exponent xec mvn.pr_rl.pr_rl,x5 " float and ?round? desc9ls generic|0,x2 desc9fl work|flt_dec_generic,x3 " The rounded move may alter the exponent value. We pick up what it " set to account for this possibility and integrate the fixed scale " factor into the 36-bit exponent. " Entry to this point presumes that X3 is the length of the floating " decimal number, and that it is already in work|flt_dec_generic. " At this point we take the 8-bit hardware exponent and extend it to " a full 35 bit signed exponent. end_get_fix_dec.normalized: " have floating number stz work|flt_dec_generic_exp " pre_set exponent mlr (pr,x3),(pr) " get new exponent desc9a work|flt_dec_generic-1(3),1 desc9a work|flt_dec_generic_exp(3),1 lda work|source_scale ars 18 " full extension neg " and form negative scale asa work|flt_dec_generic_exp " in full exponent tra flt_dec_generic_conversion " Floating Decimal Source Conversion to GENERIC " 9-bit Case get_flt_dec_9: get_flt_dec_9_packed: lxl3 work|source_precision adx3 1+1,du " account for sign/exponent mvn (pr,rl),(pr,rl) desc9fl source|0,x3 desc9fl work|flt_dec_generic,x3 mlr (pr,x3),(pr) " 8-bit to 36-bit exponent desc9a work|flt_dec_generic-1(3),1 desc9a work|flt_dec_generic_exp,1 lda work|flt_dec_generic_exp alr 1 " skip pad bit in exponent ars 36-8 " sign extend sta work|flt_dec_generic_exp a9bd source|0,x3 " update source pointer tra flt_dec_generic_conversion " 4-bit Case get_flt_dec_4: get_flt_dec_4_packed: lxl3 work|source_precision eax2 1+2,x3 " 4-bit sign/exponent adx3 1+1,du " form length 9-bit mvn (pr,rl),(pr,rl) desc4fl source|0,x2 desc9fl work|flt_dec_generic,x3 mlr (pr,x3),(pr) " Expand the exponent desc9a work|flt_dec_generic-1(3),1 desc9a work|flt_dec_generic_exp,1 lda work|flt_dec_generic_exp alr 1 " skip pad bit in exponent ars 36-8 " sign extend sta work|flt_dec_generic_exp eax2 1,x2 " byte align update anx2 =o777776,du a4bd source|0,x2 " update source pointer tra flt_dec_generic_conversion " 9-bit extended Case (has 9-bit rather than 8-bit exponent) get_flt_dec_ext: get_flt_dec_ext_packed: lxl3 work|source_precision adx3 1+1,du " account for sign/exponent mvn (pr,rl),(pr,rl) desc9fl source|0,x3 desc9fl work|flt_dec_generic,x3 " Expand the exponent (pick from source since mvn kills high bit) mlr (pr,x3),(pr) " 9-bit to 36-bit exponent desc9a source|-1(3),1 desc9a work|flt_dec_generic_exp,1 lda work|flt_dec_generic_exp ars 36-9 " sign extend sta work|flt_dec_generic_exp a9bd source|0,x3 " update source pointer tra flt_dec_generic_conversion " 9-bit generic Case. Has leading 36-bit exponent. get_flt_dec_gen: " move to generic to get hardware exponent. lda source|0 " get exponent sta work|flt_dec_generic_exp lxl2 work|source_precision adx2 1,du " account for sign eax3 1,x2 " account for hard exponent mlr (pr,rl),(pr,rl),fill(000) " move and clear exp desc9a source|1,x2 desc9a work|flt_dec_generic,x3 eax2 3,x2 " set round of mantissa len a9bd source|0,x2 " increment and round adwp source,1,du tra flt_dec_generic_conversion Bit Source Conversion to FINA " Bit conversion to final target. " " Conversion to numeric converts to fixed bin (71, 0) or fixed bin " unsigned (72, 0) and continues to final target. A bit source is " non-complex, so normal conversion to 0 of the imaginary part will " occur. Since we have no imaginary part for source, we do not move " the source pointer. Source length is left in X3. We use generic to " point to the source to be converted. This permits us to later add " other boolean types converting to a generic form. get_varying_bit: lxl3 source|-1 " load length of varying sxl3 work|source_precision tra get_bit.set_source get_bit: get_bit_packed: lxl3 work|source_precision " get length of bits " Set pointer to bit source. For now it is in true source. get_bit.set_source: epp generic,source|0 " point to source of bits. tra bit_generic_conversion "Character source conversion to TARGET " Character input routines convert a varying string to a fixed length " string, and make a pointer to the string. " Standard is string is pointed to by generic, and current length is in " work|source_precision. " If we are converting to a numeric form, then we take over control and " convert to float decimal, then continue with a float decimal to TARGET " conversion. If we are converting to bit we do a simple conversion, as " with conversion to character. get_varying_char: lda source|-1 " get length of varying char sta work|source_precision get_char: get_char_packed: epp generic,source|0 lxl3 work|source_precision eaa 0,x3 " save source length ars 18 sta work|source_string_length tra char_to_generic " Conversion Routines - Fixed bin to target GENERIC fix_bin_generic_conversion: ldx1 target_type_map,x6 " determine target GENERIC anx1 generic_mask,du " mask for type tra fix_bin_generic_case,x1* fix_bin_generic_case: arg error_bad_type arg fix_bin_to_fix_bin arg fix_bin_to_flt_bin arg fix_bin_to_flt_dec arg fix_bin_to_fix_bin_uns arg fix_bin_to_bit arg fix_bin_to_char " Fixed bin to fixed bin unsigned differs from fixed bin to fixed bin for " left scaling since moving a bit into the sign position would erroneously " trigger a size error. Right shift is fine since sign bit is clear. fix_bin_to_fix_bin_uns: " convert to unsigned target ldaq work|fix_bin_generic tmi size_error " cannot convert negative ldx2 work|target_scale " determine cross-scaling sbx2 work|source_scale fix_bin.fix_bin_uns.flt: " entry from flt_bin_to_fixun tze generic_to_target " scales match tmi fix_bin.scale_right " need right shift and ?round? " Overflow detection means generating a mask of the number of bits to " be shifted left to determine if this area is non-zero, if so then we " will overflow. lda =o400000,du " get mask bit ldq =0,dl lrs -1,x2 " generate mask anaq work|fix_bin_generic tnz size_error " we would overflow ldaq work|fix_bin_generic lls 0,x2 tra fix_bin.noscale " Convert fixed bin to fixed bin. Here it is mainly a matter of scaling " to ensure the target scale factor is correct. fix_bin_to_fix_bin: ldx2 work|target_scale " determine cross-scaling sbx2 work|source_scale fix_bin.fix_bin.flt: " entry from flt_bin_to_fix tze generic_to_target " scales match tmi fix_bin.scale_right " need right shift and ?round? fix_bin.scale_left: " left shift zero fill ldaq work|fix_bin_generic lls 0,x2 trc size_error " overflow tra fix_bin.noscale " Right scaling may require a round. Negative rounds down, positive " rounds up. Do this by determining the bit position to round at. This " rounding bit will be good for both positive and negative values. fix_bin.scale_right: " right shift and ?round? erx2 =o777777,du " form shift count-1 eax4 0,x5 " determine if rounding tze fix_bin.noround ldaq one " load mask for rounding lls 0,x2 " determine round bit anaq work|fix_bin_generic tnz fix_bin.noround eax4 0 " force no round fix_bin.noround: ldaq work|fix_bin_generic tpl fix_bin.scale.pos Conversion Routines - Fixed bin to GENERIC right scaling. " Right scale is done by negate, scale/round and negate again, since " right shift is not a true arithmetic divide unless positive. " In the special case of 400000000000000000000000 we overflow the negate " and special case correct through fix_bin.right.ovfl. negl tov fix_bin.right.ovfl " special case overflow lrs 1,x2 " scale xec binary_round,4 " round as appropriate tov size_error negl " correct result tra fix_bin.noscale " Single special case of only high order bit set. Positive would set " bit above top of register. Do signed shift right since shift count " cannot be beyond end of word. And no round can occur in this case. " We still are masked for overflows and cannot detect further hardware " overflows without clearing and resetting the indicator mask. " When we enter the high order bit is set by negl and is still correct " as signed value. fix_bin.right.ovfl: lrs 1,x2 " scale tra fix_bin.noscale fix_bin.scale.pos: lrs 1,x2 " scale number xec binary_round,4 " round positive or negative tov size_error " out-of-range fix_bin.noscale: " no scaling needed, no round staq work|fix_bin_generic tra generic_to_target even one: dec 0,1 " must be double word aligned binary_round: nop 0 " no round positive (index 0) adl =1,dl " round positive (index 1) " Conversion Routines - Fixed bin to target GENERIC (float bin) " Convert fixed bin to float bin by floating the AQ, setting the " exponent and normalizing. Then move the final exponent to the generic " float bin exponent field and set the generic float bin mantissa. " Rounding of short and long targets is done here since fixed bin is longer " than 63 bits and we would otherwise be numerically incorrect in certain " cases. Since we are rounding anyway we do short at the same time. fix_bin_to_flt_bin: lda work|source_scale " exponent including scale ars 18 " clip precision neg 0 " form -scale (b25) ada =71,dl " add integer scaling als 36-8 sta work|flt_bin_generic_exp ldaq work|fix_bin_generic lde work|flt_bin_generic_exp fno tze fix_bin.flt.zero " store extended 0.0 ste work|flt_bin_generic_exp " save exponent staq work|flt_bin_generic lda work|flt_bin_generic_exp ars 36-8 " form 36-bit exp sta work|flt_bin_generic_exp tra generic_to_target " Store an exact 0.0 in internal generic. This has exponent of 0. fix_bin.flt.zero: " zero float bin then convert to target stz work|flt_bin_generic_exp stz work|flt_bin_generic stz work|flt_bin_generic+1 tra generic_to_target " convert to target " Conversion Routines - Fixed bin to target GENERIC (float decimal) " On exit X3 is the precision of the flt_dec_generic value. " Initial coding uses BTD instruction and EIS divide to provide result of " scaling. This may be improved later. fix_bin_to_flt_dec: ldaq work|fix_bin_generic " see if zero tze force_zero " which is fast conversion " Determine precision of conversion. lde =72b25,du " pre-set bit count fno " find high bit ste work|flt_bin_generic lda work|flt_bin_generic " find true precision ars 36-8 ldx4 bin_prec_to_dec_prec,al " get digits needed lxl2 bin_prec_to_dec_prec,al " get size of source bytes eax1 -9,x2 " determine offset of source erx1 =o777777,du btd (pr,x1,rl),(pr,rl) desc9a work|fix_bin_generic,x2 desc9ls work|flt_dec_generic,x4 stz work|flt_dec_generic_exp " kill flt dec exponent eax3 1,x4 " size of float decimal ldx2 work|source_scale " determine power to divide tze generic_to_target " simple move tmi fix_bin_to_flt_dec.neg_scale " Divide will provide a leading 0 in most cases. So we divide to one " digit more precision. Convert fixed decimal to float decimal. adx3 1,du " one more digit for divide xec dv3d.id.pr_rl.pr_rl,x5 " scale the output arg two_table,x2 " power of two desc9ls work|flt_dec_generic,x4 desc9fl work|flt_dec_generic,x3 tra fix_bin_to_flt_dec.common fix_bin_to_flt_dec.neg_scale: erx2 =o777777,du adx2 =1,du " negate x2 xec mp3d.id.pr_rl.pr_rl,x5 " scale the output arg two_table,x2 " power of two desc9ls work|flt_dec_generic,x4 desc9fl work|flt_dec_generic,x3 fix_bin_to_flt_dec.common: mlr (pr,x3),(pr) " pick and extend exponent desc9a work|flt_dec_generic-1(3),1 desc9a work|flt_dec_generic_exp,1 lda work|flt_dec_generic_exp als 1 ars 36-8 sta work|flt_dec_generic_exp tra generic_to_target " Conversion Routines - Fixed bin to target GENERIC (bit) " Entry condition is a fixed bin value in fix_bin_generic. " We convert the fix bin source to fixed bin (71, 0), obeying all normal " conversion rules. Code highly congruent with fix_bin_to_fix_bin. fix_bin_to_bit: ldx2 work|source_scale fix_bin.bit.flt: " entry from flt_bin_to_bit tze to_bit " scales match tpl fix_bin.bit.scale_right " need right shift and ?round? fix_bin.bit.scale_left: " left shift zero fill ldaq work|fix_bin_generic erx2 =o777777,du adx2 =1,du " negate x2 lls 0,x2 trc size_error " overflow tra to_bit " value is good fix_bin.bit.scale_right: " right shift with round eax4 0,x5 " determine if rounding tze fix_bin.bit.noround ldaq one " load mask for rounding lls -1,x2 " determine round bit anaq work|fix_bin_generic tnz fix_bin.bit.noround eax4 0 " force no round fix_bin.bit.noround: ldaq work|fix_bin_generic tpl fix_bin.bit.scale.pos negl " result left as positive tov fix_bin.bit.right.ovfl " special case overflow lrs 0,x2 " scale xec binary_round,4 " round as appropriate tov size_error tra to_bit fix_bin.bit.right.ovfl: lrs 0,x2 " scale tra to_bit fix_bin.bit.scale.pos: lrs 0,x2 " scale number xec binary_round,4 " round positive or negative tov size_error " out-of-range " Convert to generic bit string. This is done by moving bits for the " precision of the source, subtracting the scale factor first. " On entry the AQ holds a fixed bin (71, 0) number. to_bit: ldi mask_faults,dl " reset faults staq work|fix_bin_generic " save fix bin (71, 0) szn work|fix_bin_generic " see if negative tpl to_bit.pos negl tov size_error " won't fit in (71,0) staq work|fix_bin_generic to_bit.pos: epp generic,work|bit_generic " set generic area lxl2 work|source_precision " determine start bit to move sbx2 work|source_scale eax4 -73,x2 erx4 =o777777,du " start = 72-precision tpl fix_bin.bit.non_null " string not null ldx3 0,du " length is 0 tra generic_to_target " output "0" bits fix_bin.bit.non_null: lls -1,x4 " shift out skipped part trc size_error " number is too big lxl3 work|target_precision csl (pr,x4,rl),(pr,rl),bool(move),fill(0) descb work|fix_bin_generic,x2 descb generic|0,x3 tra generic_to_target " store result Conversion Routines - Float bin to target GENERIC " Entry condition is the flt_bin_generic value. Only global register " assignments hold for other registers, like X6, X7, etc. flt_bin_generic_conversion: ldx1 target_type_map,x6 " determine target GENERIC anx1 generic_mask,du " mask for type tra flt_bin_generic_case,x1* flt_bin_generic_case: arg error_bad_type arg flt_bin_to_fix_bin arg generic_to_target " trivial conversion arg flt_bin_to_flt_dec arg flt_bin_to_fix_bin_uns arg flt_bin_to_bit arg flt_bin_to_char " Fixed bin signed and unsigned are similar conversions. Conversion is " done by considering the floating point mantissa to be a scaled fixed " binary number. The scale is determined to be fixed bin (71,71-exp). flt_bin_to_fix_bin_uns: ldaq work|flt_bin_generic tmi size_error " must be positive staq work|fix_bin_generic " Form scale factor from exponent. lda =72,dl " scaling sba work|flt_bin_generic_exp " - exponent tmi size_error sba 1,dl " correct for ranging eax2 0,al als 36-8 " initial ranging trc size_error cmpx2 =72,du " unsigned limit tpnz size_error " too big " Form shift factor according to target scale. sbx2 work|target_scale erx2 =o777777,du " form target-source adx2 1,du tra fix_bin.fix_bin_uns.flt " Convert float binary to fixed binary signed. flt_bin_to_fix_bin: ldaq work|flt_bin_generic " save integer bits of AQ staq work|fix_bin_generic " Form scale factor from exponent lda =71,dl " scaling sba work|flt_bin_generic_exp " - exponent tmi size_error eax2 0,al " xfer for store als 36-8 " initial ranging trc size_error cmpx2 =71,du " signed limit tpnz size_error " too big " Form shift factor according to target scale. sbx2 work|target_scale erx2 =o777777,du " form target-source adx2 1,du tra fix_bin.fix_bin.flt " enter and process " Conversion Routines - Float Binary to Float Decimal GENERIC " Floating binary conversion utilizes a sectioning technique to " convert through the total range. This will produce errors towards " the limits of the range unfortunately. Hopefully this technique " will be replaced in the near future. " Essentially we find a corrected exponent for the float binary number " to account for the precision. This will be a power of two multiplier. " The mantissa is converted to an integer of precision 63, by storing " the EAQ's AQ after shifting 8 bits. " We convert this to hardware float decimal with a zero exponent, and " store a zero exponent in the flt_dec_generic. " We convert from this decimal value to the final decimal value by " adjusting for the floating point bin's original exponent, by multiplying " or dividing by two as appropriate. We section through the range of " the table taking into account that 2**m is equivalent to 2**(n+o) by " using the limit of the table as the limit of powers of two for each step. " Multiply has an extra digit of precision and divide has two. " Due to the hardware characteristic that a divide may result in a leading " 0 on the float dec mantissa, we use extra precision and move the result " to normalize and round. " On exit, X3 is length of final floating result. " During operations X4 is the length of the current result. It starts as " the length of the initial BTD, and continues during mult or division. flt_bin_to_flt_dec: ldaq work|flt_bin_generic tze force_zero " zero float bin " Form the initial decimal estimate. lrs 8 " clear out 8-dummy bits staq work|flt_bin_generic lda 63,dl " precision is flt bin (63) cmpq =0,dl " see if q is clear tnz flt_bin_to_flt_dec.go " use full precision lda 27,dl " precision is flt bin (27) " We have precision in al. Do the work. flt_bin_to_flt_dec.go: ldx4 bin_prec_to_dec_prec+1,al " get precision of target lxl1 bin_prec_to_dec_prec+1,al " get size of source lxl3 work|target_precision " setup target precision adx3 2,du " sign+exp eax2 2,x3 " over-length for divide sbx4 1,du " fixed decimal length stz work|flt_dec_generic_exp " output number exponent " Convert mantissa to decimal. btd (pr,rl),(pr,rl) desc9a work|flt_bin_generic,x1 desc9ls work|flt_dec_generic,x4 adx4 1,du " account for exponent mlr (),(pr,x4),fill(000) " clear exponent zero desc9a work|flt_dec_generic-1(3),1 " Correct exponent to power of two of representation. ldx1 two_table_limit,du " load range limit neg " -precision ada work|flt_bin_generic_exp " now power of two tze flt_bin.flt_dec.to_target " no work at all tpl flt_bin.flt_dec.start_pos " positive power of two neg " correct exponent tra flt_bin.flt_dec.start_neg " -ve power of two " Start a section of conversion. flt_bin.flt_dec.start_pos: cmpa two_table_limit,dl " within table range? tpl flt_bin.flt_dec.set_pos " above range eax1 0,al " use exponent remainder flt_bin.flt_dec.set_pos: xec mp3d.id.pr_rl.pr_rl,x5 " power and round arg two_table,x1 desc9fl work|flt_dec_generic,x4 " initial length desc9fl work|flt_dec_generic,x3 " Build generic float decimal exponent. mlr (pr,x3),(pr) " X4 is current fix dec len desc9a work|flt_dec_generic-1(3),1 " hardware exponent desc9a work|fix_bin_generic,1 ldq work|fix_bin_generic " sign extend and add qls 1 qrs 36-8 asq work|flt_dec_generic_exp " See if all done the binary exponent. sba two_table_limit,dl tmoz generic_to_target " done eax4 0,x3 " flt dec length mlr (),(pr,x4),fill(000) " clear exponent zero desc9a work|flt_dec_generic-1(3),1 tra flt_bin.flt_dec.start_pos flt_bin.flt_dec.to_target: eax3 0,x4 " length of BTD output tra generic_to_target " Conversion Routine - Float Binary to Float Decimal GENERIC (Continued) " Negative power of two done by divide. We divide overlength to " preserve precision and account for divide characteristic where the " mantissa gets a leading zero if the divisor is greater than or equal " to the dividend. A later MVN collapsing the precision will fix the " leading zero. flt_bin.flt_dec.start_neg: cmpa two_table_limit,dl " check range of section tpl flt_bin.flt_dec.set_neg " above range eax1 0,al " get remaining exp flt_bin.flt_dec.set_neg: dv3d (id),(pr,rl),(pr,rl) arg two_table,x1 desc9fl work|flt_dec_generic,x4 desc9fl work|flt_dec_generic,x2 " one byte larger cmpa two_table_limit,dl " will we continue? tpl flt_bin.flt_dec.neg_continue eax3 0,x2 " done, finish exp move tra flt_bin.flt_dec.neg_done flt_bin.flt_dec.neg_continue: " needs move to normalize xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x2 desc9fl work|flt_dec_generic,x3 " Powering section done. Pick up hardware exponent and add to the " generic exponent. Clear hardware exponent and continue. flt_bin.flt_dec.neg_done: mlr (pr,x3),(pr) " X4 is current fix dec len desc9a work|flt_dec_generic-1(3),1 " hardware exponent desc9a work|fix_bin_generic,1 ldq work|fix_bin_generic " sign extend and add qls 1 qrs 36-8 asq work|flt_dec_generic_exp sba two_table_limit,dl " account for work done tmoz generic_to_target " done eax4 0,x3 " float decimal length mlr (),(pr,x4),fill(000) " clear exponent zero desc9a work|flt_dec_generic-1(3),1 tra flt_bin.flt_dec.start_neg " Conversion Routines - Float bin to target GENERIC (bit) " Entry condition is a generic float bin value in flt_bin_generic. " We convert the flt bin source to fixed bin (71, 0), obeying all normal " conversion rules. flt_bin_to_bit: ldaq work|flt_bin_generic " save integer bits of AQ staq work|fix_bin_generic " Form scale factor from exponent lda =71,dl " scaling sba work|flt_bin_generic_exp " - exponent tmi size_error eax2 0,al " xfer for store als 36-8 " initial ranging trc size_error cmpx2 =71,du " signed limit tpnz size_error " too big cmpx2 0,du " set indicators tra fix_bin.bit.flt " continue in fixed bin Conversion Routines - Float decimal to target GENERIC " Entry condition is float decimal source in flt_dec_generic with X3 " as the precision of this number. Extended exponent is in " flt_dec_generic_exp, with the vestigial hardware float decimal exponent " of flt_dec_generic_exp as a don't-care value. " This routine ensures that the hardware float decimal exponent is set to " 0 prior to conversion, to ensure ease of conversion. flt_dec_generic_conversion: mlr (),(pr,x3),fill(000) zero " put in a 0 value desc9a work|flt_dec_generic-1(3),1 " to the exponent ldx1 target_type_map,x6 " find target GENERIC anx1 generic_mask,du " mask for type tra flt_dec_generic_case,x1* " flt_dec_to_flt_dec is a trivial conversion since on entry X3 has the " precision of the flt_dec_generic and this is what the put routines use. " Thus we match at this point by design. flt_dec_generic_case: arg error_bad_type arg flt_dec_to_fix_bin arg flt_dec_to_flt_bin arg generic_to_target " trivial conversion arg flt_dec_to_fix_bin_uns arg flt_dec_to_bit arg flt_dec_to_char " Convert float decimal to scaled or unscaled fixed binary. flt_dec_to_fix_bin: lxl4 work|target_precision " find conversion precision ldx4 bin_prec_to_dec_prec,x4 ldx2 work|target_scale " is bin an integer? tze flt_dec.fix_bin.no_scale " yes tmi flt_dec.fix_bin.neg_scale " negative scale " Scale the float decimal value by the integer's power of two scale mp3d (id),(pr,rl),(pr,rl) arg two_table,x2 desc9fl work|flt_dec_generic,x3 desc9fl work|flt_dec_generic,x4 tnz flt_dec.fix_bin.exp_change " flt_dec.fix_bin.zero assumes x3 is current position of exp and " therefore the length of the source. Make this true in case of " zero value, since x4 now holds length after mp3d or dv3d. flt_dec.fix_bin.zero_fix: eax3 0,x4 " mp3d or dv3d length is x4 tra flt_dec.fix_bin.zero flt_dec.fix_bin.neg_scale: " negative scale is divide adx4 1,du " extra digit for hardware lcx2 work|target_scale " get |scale| dv3d (id),(pr,rl),(pr,rl) arg two_table,x2 desc9fl work|flt_dec_generic,x3 desc9fl work|flt_dec_generic,x4 tze flt_dec.fix_bin.zero_fix " zero value " tra flt_dec.fix_bin.exp_change " Integrate possible exponent change. flt_dec.fix_bin.exp_change: eax3 0,x4 " x3 is now exp offset mlr (pr,x3),(pr) desc9a work|flt_dec_generic-1(3),1 desc9a work|flt_bin_generic_exp,1 lda work|flt_bin_generic_exp als 1 ars 36-8 asa work|flt_dec_generic_exp " See if exponent is too big. If not, then convert to fixed decimal " and then to binary. We leave it in place as correct. Exp offset is " assumed to be in x3. flt_dec.fix_bin.no_scale: lda work|flt_dec_generic_exp als 36-8 trc decimal_range_error " range outside of flt dec mlr (pr),(pr,x3) " install hardware exp desc9a work|flt_dec_generic_exp(3),1 desc9a work|flt_dec_generic-1(3),1 flt_dec.fix_bin.zero: " x3 is assumed source length eax4 -1,x4 " target leading sign length xec mvn.pr_rl.pr_rl,x5 " create fixed decimal desc9fl work|flt_dec_generic,x3 desc9ls work|flt_dec_generic,x4 dtb (pr,rl),(pr) desc9ls work|flt_dec_generic,x4 desc9a work|fix_bin_generic,8 tov flt_dec.fix_bin.ovfl " may be bad may be -2**71 tra generic_to_target " Check if we had the value -2361183241434822606848, if not - size_error. flt_dec.fix_bin.ovfl: cmpn (pr,rl),() desc9ls work|flt_dec_generic,x4 desc4ls max_fix_bin.dec,23 tnz size_error " was out-of-range fld =1b26,du " get high-order bit staq work|fix_bin_generic ldi mask_faults,dl " clear overflow and mask tra generic_to_target max_fix_bin.dec: ac4 /-2361183241434822606848/,23 " Conversion Routines - Flt Decimal to target GENERIC (flt bin) " Convert float decimal value to an appropriate fixed decimal value " which will have all bits of significance for the final float bin " value. " On entry X3 contains the precision of the flt_dec_generic. " Algorithm finds the power of ten expressed in the float decimal, by " finding the leading zero's, the exponent and the precision as: " " mag = precision + exponent - leading_zeros " " From this and the log identity of base conversion, we determine a " top binary exponent which will cover this number as: " " bin_exp = ceil (mag*log2(10)) - log2(10) = 3.321928095 " " This provides a power of two by which to scale the floating number, prior " to converting it to binary. This power is adjusted by the binary point " position of the floating point number. flt_dec_to_flt_bin: lxl3 work|source_precision tct (pr,rl) " count leading zeros desc9a work|flt_dec_generic(1),x3 " miss sign and exponent desc9a zero_skip arg work|fix_bin_generic ttn store_float_bin_zero " all digits are "0" " At this point fix_bin_generic has the leading zero count. lda =o177,dl " mask for zero count ansa work|fix_bin_generic lxl1 work|fix_bin_generic " leading zero count ldq work|flt_dec_generic_exp " exponent in Q eaa -1,x3 " precision ars 18 ssa work|fix_bin_generic " precision - lead zero tmi store_float_bin_zero " Setup registers for scale series. Determine precision ceiling needed " from precision of both source and target. Take the larger to govern " sufficient precision for operation. Use extra digit for extension " precision needed for floating round. " " x2 is overlength precision of divide " x3 is running precision (starts at flt dec input length) " x4 is output precision of normalize eax3 2,x3 " precision+sign+exp lxl4 work|target_precision " form output from target ldx4 bin_prec_to_dec_prec,x4 " including sign/exp adx4 2,du " with extra digit+extension eax2 1,x4 " extra again for divide stx3 work|flt_bin_generic " save for max cmpx4 work|flt_bin_generic " see if source or target larget tpnz flt_dec.flt_bin.max_prec eax4 1,x3 " take precision from source eax2 2,x3 " overlength for divide flt_dec.flt_bin.max_prec: adq work|fix_bin_generic " exp + prec - LZ mpy log2.10 lls 3 " scale back sta work|flt_bin_generic_exp " save initial exponent stab " Precision correction. " In order to maximize conversion precision, we determine the precision " needed to contain the high order digit of the mantissa. This is " subtracted from the precision of the EAQ to determine the power of two " needed to produce maximum possible conversion precision. " From leading zero count, determine the first non-zero digit value and " move to work|fix_bin_generic filling high with zero. Determine the " precision correction needed to bring us to float_bin 70 to 71. mrl (pr,x1),(pr),fill(000) " zero fill for ldx1 pickup desc9a work|flt_dec_generic(1),1 desc9a work|fix_bin_generic,2 ldx1 work|fix_bin_generic " get high digit - convert ldx1 digit_to_prec-48,x1 " pick up precision-correct 0 stz work|fix_bin_generic " clear storage sxl1 work|fix_bin_generic " save precision correction ada work|fix_bin_generic " correct float_bin 71 prec sba =71,dl " correct alignment sta work|fix_bin_generic " save as final power tmi flt_dec.flt_bin.scale_up flt_dec.flt_bin.scale_dwn: " Scale down by power of two cmpa two_table_limit,dl " within table range? tmoz flt_dec.flt_bin.dwn.final " yes final to fixed lda two_table_limit,dl " scale-down section dv3d (id),(pr,rl),(pr,rl) " down-scale mantissa arg two_table,al desc9fl work|flt_dec_generic,x3 desc9fl work|flt_dec_generic,x2 " overlength for precision xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x2 desc9fl work|flt_dec_generic,x4 neg " subtract work done tra flt_dec.flt_bin.done " Scale up by appropriate power of two. flt_dec.flt_bin.scale_up: neg " form absolute cmpa two_table_limit,dl " within table range? tmoz flt_dec.flt_bin.up.final " yes final to fixed lda two_table_limit,dl " scale-up section xec mp3d.id.pr_rl.pr_rl,x5 " up-scale mantissa ?round? arg two_table,al desc9fl work|flt_dec_generic,x3 desc9fl work|flt_dec_generic,x4 " overlength for precision " tra flt_dec.flt_bin.done " Powering section done. Fix up work done is scaling to bin exp. flt_dec.flt_bin.done: eax3 0,x4 " expand size of flt_dec asa work|fix_bin_generic " count work done mlr (pr,x4),(pr) " update exponent desc9a work|flt_dec_generic-1(3),1 desc9a work|fix_bin_generic+1,1 lda work|fix_bin_generic+1 als 1 ars 36-8 asa work|flt_dec_generic_exp mlr (),(pr,x4),fill(000) " clear decimal exponet zero desc9a work|flt_dec_generic-1(3),1 " to avoid over/underflow lda work|fix_bin_generic " check completion. tmi flt_dec.flt_bin.scale_up " scale up tra flt_dec.flt_bin.scale_dwn " scale down " Final multiply to correct range. Result goes to fixed decimal to " position for DTB conversion to binary. flt_dec.flt_bin.up.final: mlr (pr),(pr,x3) " move exponent desc9a work|flt_dec_generic_exp(3),1 desc9a work|flt_dec_generic-1(3),1 xec mp3d.id.pr_rl.pr,x5 " up-scale mantissa ?round? arg two_table,al desc9fl work|flt_dec_generic,x3 desc9ls work|flt_dec_generic,24 " overlength for precision tra flt_dec.flt_bin.up.enter " Final divide to correct range. Result goes to fixed decimal to position " for DTB conversion to binary. flt_dec.flt_bin.dwn.final: mlr (pr),(pr,x3) " move exponent desc9a work|flt_dec_generic_exp(3),1 desc9a work|flt_dec_generic-1(3),1 xec dv3d.id.pr_rl.pr,x5 arg two_table,al desc9fl work|flt_dec_generic,x3 desc9ls work|flt_dec_generic,24 " Convert the fixed decimal value to bits, and normalize float bin result. flt_dec.flt_bin.up.enter: dtb (pr),(pr) desc9ls work|flt_dec_generic,24 desc9a work|flt_bin_generic,8 " Get the precision correction for the high order decimal input digit and " formulate the initial binary exponent. eaa 0,x1 als 18-8 " to exponent position sta work|fix_bin_generic ldaq work|flt_bin_generic lde work|fix_bin_generic fno ste work|fix_bin_generic staq work|flt_bin_generic lda work|fix_bin_generic ars 36-8 asa work|flt_bin_generic_exp tra generic_to_target " Conversion Routines - Flt Decimal to target generic (fix bin uns) " Convert float decimal to scaled or unscaled fixed binary unsigned. flt_dec_to_fix_bin_uns: cmpc (pr),(),fill(plus_sign) " Ensure positive number. desc9a work|flt_dec_generic,1 zero tnz size_error " converting negative lxl4 work|target_precision " determine precision needed ldx4 bin_prec_to_dec_prec,x4 ldx2 work|target_scale " is bin an integer? tze flt_dec.fix_bin_uns.no_scale " yes tmi flt_dec.fix_bin_uns.neg_scale " negative scale " Scale the float decimal value by the integer's power of two scale mp3d (id),(pr,rl),(pr,rl) arg two_table,x2 desc9fl work|flt_dec_generic,x3 desc9fl work|flt_dec_generic,x4 tnz flt_dec.fix_bin_uns.exp_change " Assumption at flt_dec.fix_bin_uns.zero is x3 is size of target, which is " currently held only in x4. Copy x4 to x3 to correct for assumption. flt_dec.fix_bin_uns.zero_fix: eax3 0,x4 " size of zero target tra flt_dec.fix_bin_uns.zero " zero value flt_dec.fix_bin_uns.neg_scale: " negative scale is divide lcx2 work|target_scale " |scale| adx4 1,du " extra digit for hardware dv3d (id),(pr,rl),(pr,rl) arg two_table,x2 desc9fl work|flt_dec_generic,x3 desc9fl work|flt_dec_generic,x4 tze flt_dec.fix_bin_uns.zero_fix " zero value " tra flt_dec.fix_bin_uns.exp_change flt_dec.fix_bin_uns.exp_change: " Add any exponent change eax3 0,x4 mlr (pr,x3),(pr) desc9a work|flt_dec_generic-1(3),1 desc9a work|flt_bin_generic_exp,1 lda work|flt_bin_generic_exp als 1 ars 36-8 asa work|flt_dec_generic_exp " See if exponent is too big. If not, then convert to fixed decimal " and then to binary. We leave it in place as correct. flt_dec.fix_bin_uns.no_scale: lda work|flt_dec_generic_exp als 36-8 trc decimal_range_error " range outside of flt dec mlr (pr),(pr,x3) " install hardware exp desc9a work|flt_dec_generic_exp(3),1 desc9a work|flt_dec_generic-1(3),1 flt_dec.fix_bin_uns.zero: eax4 -1,x4 " leading signed precision xec mvn.pr_rl.pr_rl,x5 " create fixed decimal desc9fl work|flt_dec_generic,x3 desc9ls work|flt_dec_generic,x4 " Convert. An overflow is acceptable since the bit pattern is right. dtb (pr,rl),(pr) desc9ls work|flt_dec_generic,x4 desc9a work|fix_bin_generic,8 tov flt_dec.fix_bin_uns.ovfl " too big, only 71 bits done tra generic_to_target " We got an overflow on the conversion. Thus set the high order bit. flt_dec.fix_bin_uns.ovfl: cmpn (pr,rl),() " See if above 72 bit limit. desc9ls work|flt_dec_generic,x4 desc4ns two_72,22 tmoz size_error lda =o400000,du " include the sign bit orsa work|fix_bin_generic ldi mask_faults,dl " permits overflow again tra generic_to_target Conversion Routines - Flt Decimal to target GENERIC (bit) " Entry condition is a float decimal value in flt_dec_generic " We convert the flt dec source to fixed bin (71, 0), obeying all normal " conversion rules. flt_dec_to_bit: lda work|flt_dec_generic_exp " incorporate exponent als 36-8 trc decimal_range_error " range outside of flt dec mlr (pr),(pr,x3) " install hardware exp desc9a work|flt_dec_generic_exp(3),1 desc9a work|flt_dec_generic-1(3),1 ldx4 23,du xec mvn.pr_rl.pr_rl,x5 " create fixed decimal desc9fl work|flt_dec_generic,x3 desc9ls work|flt_dec_generic,x4 dtb (pr,rl),(pr) " convert to fixed bin (71,0) desc9ls work|flt_dec_generic,x4 desc9a work|fix_bin_generic,8 tov size_error " Determine the precision equivalent of the result with 0 scale. lxl2 work|source_precision sbx2 work|source_scale eaq 0,x2 qrs 18 mpy log2.10 " convert precision to bin lls 3 cmpq 0,dl " take ceiling tze flt_dec.bit.ceil ada 1,dl flt_dec.bit.ceil: cmpa 71,dl " take min (71, a) tmi flt_dec.bit.min lda 71,dl flt_dec.bit.min: sta work|source_precision ldaq work|fix_bin_generic " pick up value tra to_bit " convert fix bin (71, 0) to bit " Log conversion to convert decimal exponent into binary exponent. log2.10: dec 3.321928095b2 " log2(10) at scale 34 " Conversion Routines - Fixed bin unsigned to target GENERIC fix_bin_uns_generic_conversion: ldx1 target_type_map,x6 " determine target GENERIC anx1 generic_mask,du " mask for type tra fix_bin_uns_generic_case,x1* fix_bin_uns_generic_case: arg error_bad_type arg fix_bin_uns_to_fix_bin arg fix_bin_uns_to_flt_bin arg fix_bin_uns_to_flt_dec arg fix_bin_uns_to_fix_bin_uns arg fix_bin_uns_to_bit arg fix_bin_uns_to_char " Convert fixed bin to fixed bin. Here it is mainly a matter of scaling " to ensure the target scale factor is correct. The difference between " conversion to signed and unsigned targets is to assure that the output " value is within the range of the target, and an unsigned to signed " conversion must result in a positive signed result. fix_bin_uns_to_fix_bin: " target signed fix_bin_uns_to_fix_bin_uns: " target unsigned ldaq work|fix_bin_generic " load for .check_target ldx2 work|target_scale " determine cross-scaling sbx2 work|source_scale tze fix_bin_uns.check_target " scales match tmi fix_bin_uns.scale_right " need right shift and ?round? " Overflow detection means generating a mask of the number of bits to " be shifted left to determine if this area is non-zero, if so then we " will overflow. fix_bin_uns.scale_left: " left shift zero fill fld =1b26,du " get mask bit lrs -1,x2 " generate mask anaq work|fix_bin_generic tnz size_error " we would overflow ldaq work|fix_bin_generic lls 0,x2 tra fix_bin_uns.noscale " Right scaling may require a round. Positive rounds up. Do this by " determining the bit position to round at. fix_bin_uns.scale_right: " right shift and ?round? erx2 =o777777,du " form shift count-1 eax4 0,x5 " determine if rounding tze fix_bin_uns.noround ldaq one " load mask for rounding lls 0,x2 " determine round bit anaq work|fix_bin_generic tnz fix_bin_uns.noround eax4 0 " force no round fix_bin_uns.noround: ldaq work|fix_bin_generic lrl 1,x2 " do total scale xec binary_round,4 " round if necessary fix_bin_uns.noscale: " no scaling needed, no round staq work|fix_bin_generic " Ensure target is big enough to hold result. Do this through shifting. " Fixed bin uns to Fixed bin signed checked by precision difference. fix_bin_uns.check_target: lxl2 work|target_precision " find precision lrl 0,x2 " see what is above it tnz size_error " too big to fit tra generic_to_target " convert to target " Conversion Routines - Fixed bin unsigned to target GENERIC (float bin) " Conversion is almost identical to normal fixed bin conversion, with " the additional condition that the result must be unsigned, thus if " the source is a full fixed bin (72) unsigned and has the upper bit set, " we pre-scale by one to remove an erroneous negative indication. fix_bin_uns_to_flt_bin: lda work|source_scale " form exponent including scale ars 18 " clip precision als 36-8 " move to exp field neg 0 " form -scale (b25) ada =71b25,du " add integer scaling sta work|flt_bin_generic_exp ldaq work|fix_bin_generic tpl fix_bin_uns.positive " high bit is clear aos work|flt_bin_generic_exp " scale exponent lrl 1 " protect high bit fix_bin_uns.positive: lde work|flt_bin_generic_exp " load and normalize fno tze fix_bin_uns.flt.zero " store extended 0.0 ste work|flt_bin_generic_exp " save exponent staq work|flt_bin_generic lda work|flt_bin_generic_exp ars 36-8 " form 36-bit exp sta work|flt_bin_generic_exp tra generic_to_target fix_bin_uns.flt.zero: " zero float bin then convert to target stz work|flt_bin_generic_exp stz work|flt_bin_generic stz work|flt_bin_generic+1 tra generic_to_target " convert to target " Conversion Routines - Fixed bin unsigned to target GENERIC (float decimal) " Initial coding uses BTD instruction and divides to provide result of " scaling. This may be improved later. fix_bin_uns_to_flt_dec: ldaq work|fix_bin_generic " see if high order bit set tze force_zero " total is 0.0 cana =o400000,du tze fix_bin_uns.flt_dec.short ana =o400000,du " mask off high bit ersa work|fix_bin_generic " turn it off ldx4 23,du " set length of conversion btd (pr),(pr,rl) " convert 71 bits desc9a work|fix_bin_generic,8 desc9ls work|flt_dec_generic,x4 ad2d (),(pr,rl) " correct for high bit desc4ns two_71,22 " add 71's bit power desc9ls work|flt_dec_generic,x4 tra fix_bin_uns.flt_dec.long " Determine length needed to convert. Method from fix_bin_to_flt_dec. " At fix_bin_uns.flt_dec.long X4 has length of the fixed decimal number. fix_bin_uns.flt_dec.short: lde =72b25,du " find true precision fno ste work|flt_bin_generic lda work|flt_bin_generic ars 36-8 ldx4 bin_prec_to_dec_prec,al " get digits needed lxl2 bin_prec_to_dec_prec,al " get size of source eax1 -9,x2 " get offset of source erx1 =o777777,du btd (pr,x1,rl),(pr,rl) desc9a work|fix_bin_generic,x2 desc9ls work|flt_dec_generic,x4 fix_bin_uns.flt_dec.long: stz work|flt_dec_generic_exp " pre-set 0 exponent eax3 1,x4 " size of float decimal ldx2 work|source_scale " determine power to divide tze generic_to_target " simple move tmi fix_bin_uns.flt_dec.neg_scale adx3 1,du " one extra digit for divide xec dv3d.id.pr_rl.pr_rl,x5 " scale the output arg two_table,x2 " power of two desc9ls work|flt_dec_generic,x4 desc9fl work|flt_dec_generic,x3 tra fix_bin_uns.flt_dec.common fix_bin_uns.flt_dec.neg_scale: erx2 =o777777,du adx2 =1,du " negate x2 xec mp3d.id.pr_rl.pr_rl,x5 " scale the output arg two_table,x2 " power of two desc9ls work|flt_dec_generic,x4 desc9fl work|flt_dec_generic,x3 fix_bin_uns.flt_dec.common: mlr (pr,x3),(pr) " pick and extend exponent desc9a work|flt_dec_generic-1(3),1 desc9a work|flt_dec_generic_exp,1 lda work|flt_dec_generic_exp als 1 ars 36-8 sta work|flt_dec_generic_exp tra generic_to_target " Conversion Routines - Fixed bin unsigned to target GENERIC (bit) " Entry condition is a fixed bin unsigned value in fix_bin_generic. " We convert the fix bin uns source to fixed bin uns (72, 0), obeying " all normal conversion rules. fix_bin_uns_to_bit: ldaq work|fix_bin_generic " load for to_bit ldx2 work|source_scale " unscaled is (72, 0) tze to_bit_uns " convert to final bits tpl fix_bin_uns.bit.scale_right " need shift right and ?round? fix_bin_uns.bit.scale_left: " left shift zero fill erx2 =o777777,du " negate x2 adx2 =1,du lls 0,x2 trc size_error " overflow tra to_bit_uns " value is good fix_bin_uns.bit.scale_right: eax4 0,x5 " determine if rounding tze fix_bin_uns.bit.noround ldaq one " load mask for rounding lls -1,x2 " determine round bit anaq work|fix_bin_generic tnz fix_bin_uns.bit.noround eax4 0 " force no round fix_bin_uns.bit.noround: ldaq work|fix_bin_generic lrl 0,x2 " do total scale xec binary_round,4 " round if necessary " Determine if it fits within the bit stream target and move to generic. to_bit_uns: staq work|fix_bin_generic " save fix bin (71, 0) epp generic,work|bit_generic " set generic area lxl2 work|source_precision " determine start bit to move sbx2 work|source_scale eax4 -73,x2 erx4 =o777777,du " start = 72-precision tpl fix_bin_uns.bit.non_null " string not null ldx3 0,du " length is 0 tra generic_to_target " output "0" bits fix_bin_uns.bit.non_null: lxl1 work|target_precision " see if fits within bits lrl 0,x1 " okay if "0"b left over tnz size_error " number is too big lxl3 work|target_precision csl (pr,x4,rl),(pr,rl),bool(move),fill(0) descb work|fix_bin_generic,x2 descb generic|0,x3 tra generic_to_target " store result " Conversion Routines - Bit to target GENERIC " Expects generic to point to bit source, and length to be in X3. bit_generic_conversion: ldx1 target_type_map,x6 " Call to target routine anx1 generic_mask,du tra bit_generic_case,x1* bit_generic_case: arg error_bad_type arg bit_to_fix_bin arg bit_to_flt_bin arg bit_to_flt_dec arg bit_to_fix_bin_uns arg bit_to_bit arg bit_to_char " Conversion to fixed bin is done in a simple manner, as is conversion " to float bin and float decimal. For all these we convert to fixed bin " (71, 0), and then call the fixed bin conversion to target GENERIC. bit_to_fix_bin: bit_to_flt_bin: bit_to_flt_dec: stz work|fix_bin_generic " clear sign bit " Copy bits reverse to get from end of string. csr (pr,rl),(pr),bool(move),fill(0) descb generic|0,x3 descb work|fix_bin_generic(1),71 trtf fix_bin_generic_conversion " bit string < 71 bits eax3 -71,x3 " check upper bits cmpb (pr,rl),(),fill(0) " to ensure leading "0"b descb generic|0,x3 zero tnz size_error " too big tra fix_bin_generic_conversion " convert it " Unsigned target case. bit_to_fix_bin_uns: " copy clears sign bit csr (pr,rl),(pr),bool(move),fill(0) descb generic|0,x3 descb work|fix_bin_generic,72 trtf fix_bin_uns_generic_conversion " bit string <= 72 bits eax3 -72,x3 " check upper bits cmpb (pr,rl),(),fill(0) " to ensure leading "0"b descb generic|0,x3 zero tnz size_error " too big tra fix_bin_uns_generic_conversion " convert it " Converison Routine - bit to bit. " Bit to bit conversion is simple. We simply determine if varying or " simple target, and copy sufficient bits to fill the target. Return " is directly to user since we cannot be complex. For a varying string " we only copy up to the length of the source, for a non-varying string, " we fill "0" beyond the length of the source. Source len in X3. Source " is pointed to by generic. We leave generic pointing to bit_generic. bit_to_bit: lxl2 work|target_precision csl (pr,rl),(pr,rl),bool(move),fill(0) descb generic|0,x3 descb work|bit_generic,x2 " copy all bits needed epp generic,work|bit_generic " point to generic source. tra generic_to_target "Conversion Routines - bit to character. " Bit to character is done by converting to the limit of the target's " precision the input bits in a loop. Much of the code, except the final " copy is identical to the bit-to-bit situation, since the only difference " is that the source bits become target digits. Source len in X3. Source " is addressed by generic. On exit we set generic to the generic " character, X3 is length of string. We use fix_bin_generic to temp-store " the string length of output. bit_to_char: lxl2 work|target_precision ldx4 0,du " source bit index stx2 work|fix_bin_generic " save precision ldx1 target_type_map,x6 " see if varying canx1 varying,du tze bit.char.loop " Varying target, adjust conversion length in X2 if bit < char length. cmpx3 work|fix_bin_generic tpnz bit.char.loop " Source > target stx3 work|fix_bin_generic " save precision eax2 0,x3 bit.char.loop: cmpb (pr,x4),() " check if bit 1/0 descb generic|0,1 zero tze bit.char.zero mlr (),(pr,x4),fill(digit_1) " fill in "1" zero desc9a work|char_generic,1 tra bit.char.done_digit bit.char.zero: mlr (),(pr,x4),fill(digit_0) " fill in "0" zero desc9a work|char_generic,1 bit.char.done_digit: eax4 1,x4 sbx3 1,du " count source done tmoz bit.char.fill_blank " beyond the source sbx2 1,du " count target done tpnz bit.char.loop tra bit.char.exit " Beyond source, fill target with " " characters. bit.char.fill_blank: mlr (),(pr,rl,x4),fill(blank) zero desc9a work|char_generic,x2 bit.char.exit: " setup chars and exit ldx3 work|fix_bin_generic " precision of generic chars epp generic,work|char_generic " base of chars tra generic_to_target Conversion Routines - Character to target GENERIC (char to bit) (char to char) char_to_generic: ldx1 target_type_map,x6 " determine target GENERIC anx1 generic_mask,du " mask for type tra char_generic_case,x1* char_generic_case: arg error_bad_type arg char_to_arithmetic " char_to_fix_bin arg char_to_arithmetic " char_to_flt_bin arg char_to_arithmetic " char_to_flt_dec arg char_to_arithmetic " char_to_fix_bin_uns arg char_to_bit arg char_to_char " Char to bit conversion is simple. We simply determine if varying or " simple target, and copy sufficient bits to fill the target. Return " is directly to user since we cannot be complex. For a varying string " we only copy up to the length of the source, for a non-varying string, " we fill "0" beyond the length of the source. We receive generic pointing " to the character string, X3 as the length. We leave generic as base of " bit string and X3 as length. We use fix_bin_generic as the working " target length, permitting correct varying target conversion. char_to_bit: char.bit.restart: " enter and restart lxl3 work|source_precision lxl2 work|target_precision ldx4 0,du " save length of target stx2 work|fix_bin_generic " save precision ldx1 target_type_map,x6 " see if varying canx1 varying,du tze char.bit.loop.enter " Varying target, adjust conversion length in X2 if char < bit length. cmpx3 work|fix_bin_generic tpnz char.bit.loop.enter " Source > target stx3 work|fix_bin_generic " save precision eax2 0,x3 char.bit.loop.enter: cmpx3 0,du tmoz char.bit.fill_0 " no work - fill 0 char.bit.loop: scm (),(pr,x4) desc9a char.bit.01,2 " see if character is 0 or 1 desc9a generic|0,1 arg work|fix_bin_generic+1 ttf char.bit.good " valid digit " Digit is invalid. We correct values to declare a conversion error. eaq 1,x4 " index in Q qrs 18 lda 191,dl " oncode tsx1 conversion_error tra char.bit.restart " re-try conversion again " Character was good. Fill in correct bit. char.bit.good: csl (pr),(pr,x4),bool(move) " fill bit descb work|fix_bin_generic+1(35),1 " using low order of index descb work|bit_generic,1 eax4 1,x4 sbx3 1,du " see if beyond source tmoz char.bit.fill_0 " fill with 0 bits sbx2 1,du " see if more target tpnz char.bit.loop tra char.bit.exit " Fill in "0" bits for remainder of target. char.bit.fill_0: csl (),(pr,x4,rl),bool(move),fill(0) zero descb work|bit_generic,x2 char.bit.exit: " setup bit info for exit ldx3 work|fix_bin_generic " number of bits epp generic,work|bit_generic " location of bits tra generic_to_target " String used to check if characters are 0 or 1. char.bit.01: aci /01/,2 "Conversion Routines - Character to Character " Source length is in work|source_precision. generic points to the string. char_to_char: lxl3 work|source_precision " pick up length tra generic_to_target " Conversion Routines - Numeric to character " This routine utilizes the existing _to_flt_dec " conversion, and sets up for such a conversion. It sets the " target precision according to the log conversion from the " precision of the incoming number. Set X4 to conversion routine address " since source get for real part is already done. fix_bin_to_char: ldx4 fix_bin_to_flt_dec,du " convert to float decimal tra to_char.enter flt_bin_to_char: ldx4 flt_bin_to_flt_dec,du " convert to float decimal tra to_char.enter " At this point X3 contains the length of the float decimal GENERIC. " It must be preserved through to the "to_char.float_type" label. flt_dec_to_char: ldx4 generic_to_target,du " convert to float decimal tsx1 save_target " save old target info lda work|source_precision " source to target prec/scale sta work|target_precision epp target,work|char_flt_dec_gen " past guard band ldx6 flt_dec_type,du " presume float ldx1 source_type_map,x7 " determine if float or fix canx1 fix,du tze to_char.float_type ldx6 fix_dec_type,du " fixed target tra to_char.float_type fix_bin_uns_to_char: ldx4 fix_bin_uns_to_flt_dec,du " convert to float decimal to_char.enter: " common processing tsx1 save_target " save old target info " Float decimal precision is ceil ((fixed bin precision)/3.32). " This considers the bin precision and the decimal precision to be " logarithm expressions and is simply the bin precision changed from " log(2) to log(10). ldq work|source_precision anq =o777777,dl " mask out scale mpy =.3012056b-1 cmpq 0,dl tze to_char.precision.ceil " ceiling ada 1,dl " round up to_char.precision.ceil: sta work|target_precision " store in DL " Put output into work|char_flt_dec_gen. Set target type to float decimal. epp target,work|char_flt_dec_gen " past guard band ldx6 flt_dec_type,du " presume float ldx1 source_type_map,x7 " determine if float or fix canx1 fix,du tze to_char.float_type ldx6 fix_dec_type,du " fixed target aos work|target_precision " get additional precision ldq work|source_scale " find scale digits tpl to_char.pos_scale " don't keep neg scale ldq 0,dl to_char.pos_scale: qrs 18 tze to_char.float_type mpy =.301205b-1 " form scale conversion cmpq 0,dl " round up tze to_char.scale.ceiling ada 1,dl to_char.scale.ceiling: als 18 asa work|target_scale " integrate with precision to_char.float_type: tsp7 0,x4 " Convert real part ldi mask_faults,dl " re-enable overflow detect " Determine if source is complex. If so convert complex part too. ldx1 source_type_map,x7 canx1 complex,du tze to_char.simple_source lxl4 source_type_map,x7 tsp7 0,x4 ldi mask_faults,dl " re-enable overflow detect " Restore target info for character, and CASE to data type of source " to get correct conversion. to_char.simple_source: epp source,work|char_flt_dec_gen " take flt/fix dec from temp ldx1 source_type_map,x7 " determine source GENERIC anx1 generic_mask,du tra to_char.formatter,x1* to_char.formatter: arg error_bad_type arg format_fix arg format_flt_bin arg format_flt_dec arg format_fix arg error_bad_type " bits grabbed earlier arg error_bad_type " characters grabbed earlier " Conversion Routines - Formated fixed bin output. " Format fixed. format_fix: epp4 format_integer " presume an integer ldx1 work|source_scale tmoz to_char.call_format " format as integer epp4 format_fixed tra to_char.call_format " format as fractional " Format float decimal. " " This requires that we determine if the original source was fixed or " float decimal to determine scale information. format_flt_dec: ldx1 source_type_map,x7 canx1 fix,du " was source fixed decimal tze format_flt_bin " no - format float epp4 format_integer ldx4 work|source_scale " if no scale, format integer tze to_char.call_format " Format as scaled fixed decimal. epp4 format_scaled " use F format tmi to_char.call_format " scale below precision lxl4 work|source_precision " is scale beyond precision cmpx4 work|source_scale tmi to_char.call_format epp4 format_fixed " simple format tra to_char.call_format " Format float binary. format_flt_bin: epp4 format_float " Call formatter for real and possibly imaginary parts. to_char.call_format: epp generic,work|char_generic " pointer to target w/guard eax4 0 " flag for real part lxl3 work|target_precision " form target precision tsp7 pr4|0 " call formatter " X2 contains the number of characters output, X3 contains p+2, source " pointer is updated. ldx1 source_type_map,x7 " do imaginary if complex canx1 complex,du tze to_char.copy_to_target " only real part a9bd generic|0,x2 " point to imaginary part stx2 work|save_target_precision " save length output eax4 1 " flag for imaginary part lxl3 work|target_precision " form target precision tsp7 pr4|0 " format " Squeeze blanks from imaginary part and add trailing "i". scmr (pr,rl),(du) desc9a generic|0,x2 vfd 9/blank arg work|fix_bin_generic eaa 0,x2 " length of field ars 18 sba work|fix_bin_generic " form number of leading 0's ldq work|fix_bin_generic " number of non-blank chars eax4 1,ql " space for "i" mlr (pr,rl,al),(pr,rl),fill(letter_i) desc9a generic|0,ql desc9a generic|0,x4 cmpa 0,dl " need to fill spaces at end? tze to_char.no_fill " and skip if none mlr (),(pr,rl,x4),fill(blank) " put spaces right of field zero desc9a generic|0,al to_char.no_fill: adx2 1,du " allow for i at end adx2 work|save_target_precision " form total length of string " assign char temporary to final target to_char.copy_to_target: tsx1 restore_target " restore target info epp generic,work|char_generic " get ptr to characters eax3 0,x2 " get source length in al tra generic_to_target " and go move " Conversion Routines - Format decimal integer. " entered with p in x3, x4 = 0(1) for real(imag) part, " generic = ptr to output buffer, pr4 = ptr to ourselves, " and pr7 = return loc " returns with p+1 in x3 and x2 = number of chars output (p+3), source " pointing after used portion. format_integer: eax3 1,x3 eax2 2,x3 " length of output = p + 3 cmpn (pr,rl),() " is field 0 desc9ls source|0,x3 desc9ls char_zero,2 tze format_integer.zero mvne (pr,rl),(id),(pr,rl) " no, do editing desc9ls source|0,x3 arg int_edit_desc,x4 desc9a generic|0,x2 a9bd source|0,x3 " update source used tra pr7|0 format_integer.zero: mrl (id),(pr,rl),fill(blank) " zero field (edit would IPR) arg zero_field,x4 desc9a generic|0,x2 a9bd source|0,x3 " update source used tra pr7|0 int_edit_desc: desc9a int_edit,7 real desc9a int_edit(2),5 imag int_edit: vfd 9/lte+3,9/blank,9/insm+2,9/mfls,9/mfls,9/mfls,9/mfls zero_field: desc9a char_zero(1),1 real desc9a char_zero,2 imag " Character zero forms. char_zero: aci "+0-0" " Conversion Routines - Format Fixed scaled 0 < scale <= precision. " entered with p in x3, x4 = 0(1) for real(imag) part, " generic = ptr to output buffer, pr4 = ptr to ourselves, " and pr7 = return loc " returns with p+1 in x3 and x2 = number of chars output (p+3), source " points after used part. format_fixed: eax3 1,x3 " form p+1 sbx3 work|target_scale " get p-q+1 eax2 1,x3 " first part of field cmpx3 2,du " need at least 2 digits tmi format_fixed.no_lead_digits " no, special action needed cmpn (pr,rl),() " are first p-q digits zero? desc9ls source|0,x3 desc9ls char_zero,2 tze format_fixed.zero mvne (pr,rl),(id),(pr,rl) " non-zero, form Sdddd desc9ls source|0,x3 arg fixed_edit_desc,x4 desc9a generic|0,x2 " Format right hand side after decimal point. format_fixed.right: ldq work|target_scale " q+1 digits of form .ddddd eaa 1,qu mrl (pr,rl,x3),(pr,rl,x2),fill(period) desc9a source|0,qu desc9a generic|0,au adx3 work|target_scale " get back p+1 eax2 2,x3 " total size of field a9bd source|0,x3 " update source pointer tra pr7|0 " Format integer part as zero. format_fixed.zero: cmpc (pr),(),fill(plus_sign) desc9a source|0,1 zero tze format_fixed.zero_pos " skip if number positive mrl (),(pr,rl),fill(blank) " move in -0 desc9a char_zero(2),2 desc9a generic|0,x2 tra format_fixed.right " format fractional part format_fixed.zero_pos: mrl (id),(pr,rl),fill(blank) " zero, edit would IPR arg zero_field,4 desc9a generic|0,x2 tra format_fixed.right " format fractional part format_fixed.no_lead_digits: mvne (pr),(id),(pr) " put s0 at start of field desc9ls source|0,2 arg no_leading_edit_desc,x4 desc9a generic|0,2 tra format_fixed.right " format fractional part fixed_edit_desc: desc9a fixed_edit,7 desc9a fixed_edit(2),5 fixed_edit: vfd 9/lte+3,9/blank,9/insm+1,9/mfls,9/mfls,9/mfls,9/mfls no_leading_edit_desc: desc9a no_leading_edit,4 desc9a no_leading_edit(2),2 no_leading_edit: vfd 9/lte+3,9/blank,9/enf,9/insb+8 " Conversion Routines - Format fixed scaled scale < 0 | precision < scale " Call: x4 = 0 (1) for real (imag) part " generic = ptr to output buffer " pr4 = ptr to ourselves " tsp7 pr4|0 " x2 = number of chars output (p+4, p+5 or p+6) " x3 = p " Destroys: a, q, x1 " Updates: source to point after used part. format_scaled: eax3 1,x3 " account for sign cmpn (pr,rl),() " Is number zero? desc9ls source|0,x3 desc9ls char_zero,2 tnz format_scaled.nonzero " No: edit number with mvne mrl (id),(pr,rl),fill(blank) " Yes: mvne would IPR arg zero_field,x4 desc9a generic|0,x3 tra format_scaled.scale_factor " Non-zero number. format_scaled.nonzero: mvne (pr,rl),(id),(pr,rl) " convert pic "(p)-9vf(-q)" desc9ls source|0,x3 arg format_scaled.edit_desc,x4 desc9a generic|0,x3 " Format scale factor for number. format_scaled.scale_factor: " convert the scale factor mlr (),(pr,x3),fill(letter_f) " tack on "f" zero desc9a generic|0,1 lda work|source_scale " au = scale_factor ars 18 " a = scale_factor eax2 1+1 " assume 1 digit scale factor cmg 10,dl " Is one digit enough? tmi format_scaled.have_length " Yes: format it eax2 2+1 " No: assume 2 digit factor cmg 100,dl " Are two digits enough? tmi format_scaled.have_length " Yes: format it eax2 3+1 " No: three digit factor format_scaled.have_length: " x2 = digits in factor + 1 neg " a = -scale_factor sta work|fix_bin_generic " work|b = -scale_factor btd (pr),(pr,rl,x3) " convert -scale_factor desc9a work|fix_bin_generic,4 desc9ls generic|0(1),x2 eaa 2,x2 ars 18 ada work|source_precision " A = p+digits_in_factor+1+2 eax2 0,al " into X2 a9bd source|0,x3 " update source pointer tra pr7|0 format_scaled.edit_desc: desc9a format_scaled.edit,6 desc9a format_scaled.edit(2),4 format_scaled.edit: vfd 9/lte+3,9/blank,9/mfls,9/mfls,9/mfls,9/mfls " Conversion Routines - Format Decimal float. " entered with: " source|0 -> float decimal generic " x3 has precision of mantissa " x4 has 0/1 for real/imag " generic -> output buffer " pr4 -> formatting routine " pr7 -> return loc " returns with x2 = number of chars output (p+7), updates source to point " after used part. format_float: tct (pr,rl) " count leading zeros desc9a source|1(1),x3 " miss sign and exponent desc9a zero_skip arg work|fix_bin_generic ttn zero_float " all digits are "0" lxl2 work|fix_bin_generic " get number of leading zeros eaa 0,x2 ars 18 neg ada work|target_precision " form # of non-zero digits ana =o777777,dl mlr (pr),(pr) " copy sign into temp desc9a source|1,1 desc9a work|fix_dec_generic,1 mlr (pr,rl,x2),(pr,rl),fill(digit_0) " copy sans leading zeros desc9a source|1(1),al desc9a work|fix_dec_generic(1),x3 sba 1,dl " form output exponent ada source|0 " include generic exponent sta work|fix_bin_generic " save to stop overwrite adx3 1,du " get p+1 eax2 1,3 " get p+2 mvne (pr,rl),(id),(pr,rl) " generate Sd.dddddddd desc9ls work|fix_dec_generic,x3 arg float_edit_desc,4 desc9a generic|0,x2 mlr (),(pr,x2),fill(letter_e) " move in "e" zero desc9a generic|0,1 btd (pr),(pr,x2) " convert exponent desc9a work|fix_bin_generic,4 desc9ls generic|0(1),11 adx2 2,du " add length of "e+" tct (pr,x2) " count most leading zeros desc9a generic|0,7 desc9a zero_skip arg work|fix_bin_generic eaq 0,x2 " get index qrs 18 adq work|fix_bin_generic " add offset anq =o777777,dl " mask for index lda work|fix_bin_generic " get length ana =o777777,dl neg eax4 10,al " length of move mrl (pr,ql,rl),(pr,x2,rl) desc9a generic|0,x4 desc9a generic|0,x4 stx4 work|fix_bin_generic " store exponent length adx2 work|fix_bin_generic " add length of digits adx3 3,du " round up a9bd source|0,x3 " update source pointer adwp source,1,du " align to word tra pr7|0 Zero floating point value. zero_float: adx3 2,du " get p + 2 mlr (id),(pr,rl),fill(digit_0) " form b0.00000 or +0.0000 arg zero_fl_desc,x4 desc9a generic|0,x3 mlr (),(pr,x3),fill(digit_0) " tack on e+000 desc9a eplus,2 desc9a generic|0,5 eax2 5,x3 " get length of field adx3 2,du " sign+mantissa+3 to round a9bd source|0,x3 " update source pointer adwp source,1,du " align to word tra pr7|0 " Constants and formatting descriptors zero_fl_desc: desc9a real_zero_fl,3 desc9a imag_zero_fl,3 real_zero_fl: aci " 0." imag_zero_fl: aci "+0." eplus: aci "e+" float_edit_desc: desc9a float_edit,8 real desc9a float_edit(2),6 imag float_edit: vfd 9/lte+3,9/blank,9/mfls+1,9/insb+7,9/mvc,9/mvc,9/mvc,9/mvc " Save target information and return pointer. save_target: lda work|target_precision " combined prec(DL), scale(DU) sta work|save_target_precision spri1 work|save_target_ptr spri7 work|return spri4 work|save_pr4 stx6 work|save_target_type tra 0,1 " Restore target information and return pointer. restore_target: lda work|save_target_precision sta work|target_precision epp1 work|save_target_ptr,* epp7 work|return,* epp4 work|save_pr4,* ldx6 work|save_target_type tra 0,1 Conversion Routines - Character to Arithmetic. " On entry original_source is zero'd, to indicate no stack extension. " We receive the input string in the character temporary and translate it " as we go as necessary. One initial translate test is done to permit the " use of short translate/test tables. It finds the first illegal char. " For this translation and the CASE tests, the code is: " " 0 (illegal_class) - illegal character " 1 (sign_class) - plus or minus sign " 2 (period_class) - period (as for decimal point) " 3 (b_class) - b or B, used to indicate binary " 4 (de_class) - d,D e,E, used to indicate exponential format " 5 (i_class) - i or I, used to indicate end of Imaginary part " 6 (blank_class) - Whitespace " 7 (digit_class) - 0 thru 9, numeric digit " 8 (f_class) - f or F, used to indicated fixed format " Recognize is used to build a token list for a numeric part, and to " recognize the numeric type provided. It is first called to parse the " real part, and then the imaginary part of the input number. If in " scanning the real part, it finds a termination of I or i, we have " found the imaginary part instead, and move it to the imaginary token " list and clear the real token list. " The token list is initialized to zero, which will setup exponent, type, " index and length. This is used with fill in later moves to setup the " float decimal source number. " After recognize has been run on the translated token source, we determine " the dominant numeric type for output, and the dominant scale and " precision of the real and imaginary parts. " " Dominant scale is: max (scale_real, scale_imaginary) " The scale is determined by the length of the fractional parts. " " Dominant precision is: max (integer_real, integer_imaginary)+1 + " dominant scale. " " After determining dominant scale and precision and type, we copy " information according to the token list into the character temporary " from the source string. The sign is moved with a "+" fill, thus it " defaults to +. The integer part is moved right to left with 0 fill, " the fractional part left to right with 0 fill. The exponent has already " been parsed and determined. We correct it by subtracting the dominant " scale to produce a true float decimal GENERIC form for the input real " and imaginary parts. " " When this numeric input has been built, we simply enter any_to_any_ " to do conversion to the target. " " There are four basic types of data. equ fixbin,1 " fixed binary equ fltbin,2 " float binary equ fixdec,3 " fixed decimal equ fltdec,4 " float decimal " These are later converted to the true internal data type*2 by a " conversion table. Float decimal will normally use real_flt_dec_9bit, but " if the range does not fit, then we escape to real_flt_dec_ext for a 9-bit " exponent. " Converision Routines - Character to numeric " Uses PR4 to point to token area in current use. char_to_arithmetic: stz work|original_source " clear extension flag stx5 work|save_rounding " save rounding requested lda work|source_string_length " get length of source ana =o777777,dl tze char.arith.zero cmpa 256,dl " check length tpnz error_205 " input string too long tra char.arith.save_len " Restart point to pick up string from "conversion" error recover routine. " Here we may have a different length than before. char_to_arithmetic_restart: lda work|source_string_length " get length of source tze char.arith.zero cmpa 256,dl " deal with max of 256 chars tmi char.arith.save_len lda 256,dl " force length, no error " Save length of string supplied. Length in A. char.arith.save_len: sta work|original_source_length " save for conversion error " NOTE - Here it should be spri generic,work|generic_ptr, but ALM won't do it. spri2 work|generic_ptr " save string pointer tct (pr,rl) " find illegal or end desc9a generic|0,al arg error_table arg work|flt_bin_generic ttn char.arith.good_string " Bad character seen. Find index of it. ldq work|flt_bin_generic " get index anq =o777777,dl tra error_203 " illegal character char.arith.good_string: tctr (pr,rl) " rtrim (string) desc9a generic|0,al arg blank_skip arg work|fix_bin_generic lca work|fix_bin_generic " - blanks alr 9 " sign extend ars 9 ada work|original_source_length " length - blanks tze char.arith.zero " all blank " Start index at first non-whitespace. " Build token information into imaginary token. Will move it later. mlr (),(pr),fill(000) " init real token zero desc9a work|real_token,token_length mlr (),(pr),fill(000) " init imag token zero desc9a work|imag_token,token_length tct (pr,rl) " skip over leading blanks desc9a generic|0,al arg blank_skip arg work|fix_bin_generic stba work|fix_bin_generic,40 " clear high byte blank count sba work|fix_bin_generic " account for blanks tmoz char.arith.zero " all blank - is 0.0 " Not all character input was blank. Start on real part. ldq work|fix_bin_generic " initialize offset tsx2 recognize " look for a number mlr (pr),(pr) " move imag to real desc9a work|imag_token,token_length desc9a work|real_token,token_length cmpa 0,dl " did we reach end of input tpnz char.arith.more_input " continue stz work|imag.type " indicate no imaginary tra char.arith.end_of_input " have some characters after the number, process as terminator. " Use X2 as error index for trailing blank check. char.arith.more_input: ldx2 error_203,du " indicate bad character lxl4 work|real.term " get terminator class tra *+1,x4 " case process terminator tra error_203 " illegal tra char.arith.have_real_part " sign - imag follows tra error_203 " period tra error_203 " b tra error_203 " d e tra char.arith.got_imag_part " i - we saw imag part tra char.arith.blank_imag " blank tra error_203 " digit (can't happen) tra error_203 " f " Blank trailing real part. Clear imaginary part and check blanks. char.arith.blank_imag: stz work|imag.type " no imaginary type tra char.arith.check_blank " We have just seen the imaginary part, and the real part is empty. " The imaginary token list entry is okay, clear the real token. char.arith.got_imag_part: mlr (),(pr),fill(000) " init real zero desc9a work|real_token,token_length tra char.arith.have_imag_part " we have imaginary " Capture token info in imaginary part. char.arith.have_real_part: mlr (),(pr),fill(000) " init imag zero desc9a work|imag_token,token_length tsx2 recognize " look for a number cmpa 0,dl " did we reach end of input tmoz error_219 " must have the "i" " We have both parts of the number, real and imaginary. " Check if we terminate correctly. We must have blanks. char.arith.have_imag_part: lxl4 work|imag.term " check terminator cmpx4 i_class,du " must be "i" tnz error_219 adq 1,dl " skip the blank sba 1,dl " one less to check tmoz char.arith.end_of_input ldx2 error_211,du " bad char after "i" char.arith.check_blank: tct (pr,rl,ql) " skip trailing blanks desc9a generic|0,al arg blank_skip arg work|fix_bin_generic ttf 0,x2 " complain " From token list, form the generic input, using char.flt_dec_generic. char.arith.end_of_input: " Set dominant conversion type. eax6 0,x6 " target of opportunity tnz char.arith.supplied ldx7 work|real.type ldx1 work|imag.type epp generic,dominant_type,x7* " select imaginary table ldx7 generic|0,x1 " get dominant type lxl2 generic|0,x1 " get precision routine " If we alter the precision and scale, for a decimal to binary conversion. " The precision will appear in AL, and the scale in X5. We indicate the " modified scale/precision tokenlist word by X3 as an offset in the " work area. lda 0,dl " preset precision ldx5 0,du " preset scale ldx3 0,du " preset token prec/scale mod tra 0,x2 " manage precision " Transform the precision of the real part to binary from decimal. r_dec_to_xbin: " Convert real part decimal prec/scale to bin ldx3 real.scale,du tra dec_to_bin.scale r_dec_to_bin: " Convert real part decimal prec to bin ldx3 real.prec,du tra dec_to_bin.prec i_dec_to_bin: " Convert imaginary part decimal prec/scale to bin ldx3 imag.prec,du tra dec_to_bin.prec i_dec_to_xbin: " Convert imaginary part decimal prec to bin ldx3 imag.scale,du " tra dec_to_bin.scale " fall through to routine " Convert the indicated scale to X5. dec_to_bin.scale: ldq work|0,x3 " scale = ceil (log2(10)*scale) qrs 18 " position tmi dec_to_bin.prec " negative scale set to 0 mpy log2.10 " convert base lls 3 cmpq 0,dl " ceiling tze dec_to_bin.prec ada 1,dl " tra dec_to_bin.prec " find dominant precision dec_to_bin.prec: ldx3 1,du ldq work|0,x3 " prec = ceil (log2(10)*prec) anq =o777777,dl " mask from DL mpy log2.10 " convert base lls 3 cmpq 0,dl " ceiling tze char.arith.save_prec ada 1,dl tra char.arith.save_prec " find dominant precision " Save updated precision and scale. char.arith.save_prec: sta work|0,x3 " save precision stx5 work|0,x3 " save scale " Take precisions as is: From dominant, process precision and scale. as_is: eax4 0,x7 " save type xec calculate_precision,x7 " target_precision ldx5 work|imag.type " determine if complex tze char.arith.real_type eax4 4,x4 " change to complex char.arith.real_type: " set type of source ldx6 final_type,x4 " presume short ldx5 work|target_precision xec calculate_type,x7 " compare to limit tmoz char.arith.set_round " within short lxl6 final_type,x4 " pick up long type char.arith.set_round: stz work|save_rounding " presume no round ldx1 target_type_map,x7 " get default canx1 round,du tze char.arith.supplied " no round lda 1,dl sta work|save_rounding " round " Caller supplied target type and precision. Convert input. char.arith.supplied: epp generic,work|generic_ptr,* " get ptr to source tsx1 move_char_to_generic " move and set scale/prec, type ldx5 work|save_rounding epp7 char.arith.real_return " setup return lxl3 work|real.prec " setup float dec precision eax3 2,x3 " extend for sign and hard exp ldx2 work|real.type " get internal type tra *+1,x2 " process generic tra flt_dec_generic_conversion " presume 0.0 tra fix_bin_generic_conversion tra flt_bin_generic_conversion tra flt_dec_generic_conversion tra flt_dec_generic_conversion char.arith.real_return: ldi mask_faults,dl " clear for faults again ldx1 target_type_map,x6 " get flag word for target canx1 complex,du " complex? tze unmask_exit " real target, return " Convert imaginary part. mlr (pr),(pr) " move imag to real desc9a work|imag_token,token_length desc9a work|real_token,token_length epp generic,work|generic_ptr,* " get ptr to source tsx1 move_char_to_generic " move and set scale/prec ldx5 work|save_rounding epp7 unmask_exit " setup return lxl3 work|real.prec " setup float dec precision eax3 2,x3 " extend for sign and hard exp ldx2 work|real.type " get internal type tra *+1,x2 " process generic tra flt_dec_generic_conversion " +0 already set tra fix_bin_generic_conversion tra flt_bin_generic_conversion tra flt_dec_generic_conversion tra flt_dec_generic_conversion " Input of real and imaginary is zero. Use a default input. char.arith.zero: epp generic,char.arith.zero_char lda 1,dl " one character long sta work|source_string_length tra char_to_arithmetic_restart char.arith.zero_char: aci /0/,1 " Tables for type conversion. " Dominant type table. Used to convert a real and imaginary type into " the dominant complex type. First table references the other four. " Here we have a 0 entry for a non-existant token type default of 0. " The following matrix provides conversions and determines precision " conversion. " " REAL TYPE " " 0 type | error | fixbin | fltbin | fixdec | fltdec | " | | as is | as is | as is | as is | " ---------------------------------------------| " fixbin | fixbin | fixbin | fltbin | fixbin | fltbin | " | as is | as is | as is |dec->bin|dec->bin| " ---------------------------------------------| " fltbin | fltbin | fltbin | fltbin | fltbin | fltbin | " | as is | as is | as is |dec->bin|dec->bin| " ---------------------------------------------| " fixdec | fixdec | fixbin | fltbin | fixdec | fltdec | " | as is |dec->bin|dec->bin| as is | as is | " ---------------------------------------------| " fltdec | fltdec | fltbin | fltbin | fltdec | fltdec | " | as is |dec->bin|dec->bin| as is | as is | " ---------------------------------------------| " IMAG TYPE 0 type fixbin fltbin fixdec fltdec dominant_type: arg fixdec_type " use default if real is 0 arg fixbin_type arg fltbin_type arg fixdec_type arg fltdec_type " Table element has DU type and DL conversion routine. This conversion " routine is used to convert precision and scale as necessary according " to the output type and the real and imaginary sources. as_is just " passes on the scale and precision. fixbin_type: vfd 18/fixbin,18/as_is " stay in type, use real part vfd 18/fixbin,18/as_is " stay in type, prec/scale vfd 18/fltbin,18/as_is " co-erce fixbin to fltbin vfd 18/fixbin,18/i_dec_to_xbin " co-erce fixdec to fixbin vfd 18/fltbin,18/i_dec_to_bin " co-erce fltdec to fltbin fltbin_type: vfd 18/fltbin,18/as_is " stay in type vfd 18/fltbin,18/as_is " co-erce fixbin to fltbin vfd 18/fltbin,18/as_is " stay in type vfd 18/fltbin,18/i_dec_to_bin " co-erce fixdec to fltbin vfd 18/fltbin,18/i_dec_to_bin " co-erce fltdec to fltbin fixdec_type: vfd 18/fixdec,18/as_is " stay in type vfd 18/fixbin,18/r_dec_to_xbin " co-erce fixdec to fixbin vfd 18/fltbin,18/r_dec_to_bin " co-erce fixdec to fltbin vfd 18/fixdec,18/as_is " stay in type vfd 18/fltdec,18/as_is " co-erce fixdec to fltdec fltdec_type: vfd 18/fltdec,18/as_is " stay in type vfd 18/fltbin,18/r_dec_to_bin " co-erce fixbin to fltbin vfd 18/fltbin,18/r_dec_to_bin " co-erce fltdec to fltbin vfd 18/fltdec,18/as_is " co-erce fixdec to fltdec vfd 18/fltdec,18/as_is " stay in type " Type table for conversion of internal to real data type. DU is " short form, DL is long form. equ real_fix_bin_1,1 equ real_fix_bin_2,2 equ real_flt_bin_1,3 equ real_flt_bin_2,4 equ cplx_fix_bin_1,5 equ cplx_fix_bin_2,6 equ cplx_flt_bin_1,7 equ cplx_flt_bin_2,8 equ real_fix_dec_9bit_ls,9 equ real_flt_dec_9bit,10 equ cplx_fix_dec_9bit_ls,11 equ cplx_flt_dec_9bit,12 final_type: vfd 18/real_fix_bin_2*2,18/real_fix_bin_2*2 " default 0 type vfd 18/real_fix_bin_1*2,18/real_fix_bin_2*2 vfd 18/real_flt_bin_1*2,18/real_flt_bin_2*2 vfd 18/real_fix_dec_9bit_ls*2,18/real_fix_dec_9bit_ls*2 vfd 18/real_flt_dec_9bit*2,18/real_flt_dec_9bit*2 vfd 18/cplx_fix_bin_1*2,18/cplx_fix_bin_2*2 vfd 18/cplx_flt_bin_1*2,18/cplx_flt_bin_2*2 vfd 18/cplx_fix_dec_9bit_ls*2,18/cplx_fix_dec_9bit_ls*2 vfd 18/cplx_flt_dec_9bit*2,18/cplx_flt_dec_9bit*2 " Compute precision and scale of final result " scale = max(real_scale,imag_scale) " precision = scale + max(real_prec-real_scale, imag_prec-imag_scale) " " Result left in source_scale and source_precision fields in work area. fixed_prec_and_scale: ldx2 work|imag.type " take real if no imag tze fixed_prec_and_scale.real " Calculate precisions. lxl2 work|real.prec sbx2 work|real.scale " real prec-scale lxl3 work|imag.prec sbx3 work|imag.scale stx3 work|target_precision " imag prec-scale cmpx2 work|target_precision tpl 2,ic " real>imag eax2 0,x3 " take imaginary adx2 1,du ldx3 work|real.scale " calculate max scale cmpx3 work|imag.scale tpl 2,ic ldx3 work|imag.scale stx3 work|target_scale " set new scale (DU) adx2 work|target_scale " add max scale sxl2 work|target_precision " set new precision (DL) tpnz 0,x1 aos work|target_precision " max (prec, 1) tra 0,x1 fixed_prec_and_scale.real: lda work|real.prec sta work|target_precision ana =o777777,dl " mask for precision tpnz 0,x1 aos work|target_precision " max (prec, 1) tra 0,x1 " Calculate float precision. " precision = max(real_prec, imag_prec) " " Result left in target_precision field in work area. Scale set to 0. float_prec: lxl2 work|real.prec ldx3 work|imag.type " take real if no imag tze float_prec.real lxl3 work|imag.prec cmpx2 work|imag.prec tpl 2,ic eax2 0,x3 float_prec.real: sxl2 work|target_precision " set new precision (DL) ldx2 0,du stx2 work|target_precision " zero scale lxl2 work|target_precision " ensure precision >= 1 tpnz 0,x1 aos work|target_precision " max (prec, 1) tra 0,x1 " Execute table used for calculation of precision and scale according to " the dominant target type. calculate_precision: tra error_bad_type " must have a type by now tsx1 fixed_prec_and_scale tsx1 float_prec tsx1 fixed_prec_and_scale tsx1 float_prec " Execute table used for comparison of precision limit to determine " long/short data type. calculate_type: tra error_bad_type " must have type by now cmpx5 35,du " short limit of fixed bin cmpx5 27,du " short limit of float bin cmpx5 59,du " upper limit of fixed dec cmpx5 59,du " upper limit of float dec Move float decimal generic from source character stream. " Routine to move character input to float decimal generic form for " char_to_arithmetic. It creates a 36-bit exponent, moves the sign " and moves the integer and fractional parts. " On entry: " X1 is return offset " generic points to source string " type of numer in work|imag.type (DU) " " On exit we have stored the appropriate type of float decimal generic, " fix_bin_generic or flt_bin_generic. " We have also set source_precision and source_scale and X7. move_char_to_generic: ldx2 work|real.type tra *+1,x2 tra char_to_generic.zero_dec tra char_to_generic.fixbin tra char_to_generic.fltbin tra char_to_generic.fixdec tra char_to_generic.fltdec char_to_generic.zero_dec: lda 1,dl " set source scale/prec sta work|source_precision sta work|real.prec " same in token stz work|flt_dec_generic_exp " clear exponent lda dec_zero " implant +0 sta work|flt_dec_generic tra 0,x1 char_to_generic.fixdec: char_to_generic.fltdec: stz work|source_scale " kill the scale ldx7 real_flt_dec_generic*2,du " set type of data moved to ldx2 work|real.integer.length " get precision (DU) adx2 work|real.fraction.length tmoz char_to_generic.zero_dec " default to 0.0 cmpx2 max_p_dec,du " see if too many digits tpnz error_218 sxl2 work|source_precision " save precision lda work|real.fraction.length " get fractional length ars 18 ssa work|real.exponent.value " form fraction - exponent lca work|real.exponent.value " save generic's exponent sta work|flt_dec_generic_exp " Move in sign. ldx2 work|real.sign.length " length in DU lxl3 work|real.sign.index " index in DL ldx4 1,du " move 1 char mlr (pr,rl,x3),(pr,rl),fill(plus_sign) desc9a generic|0,x2 " fills "+" if no sign desc9a work|flt_dec_generic,x4 " Move integer part. ldx2 work|real.integer.length " length of source DU lxl4 work|real.integer.index " index in source DL mlr (pr,rl,x4),(pr,rl),fill(digit_0) desc9a generic|0,x2 desc9a work|flt_dec_generic(1),x2 " Move fractional part. lxl4 work|real.fraction.index " index in source DL ldx3 work|real.fraction.length " length of source DU mlr (pr,rl,x4),(pr,rl,x2),fill(digit_0) desc9a generic|0,x3 desc9a work|flt_dec_generic(1),x3 tra 0,x1 " return for next section " Move fixed bin generic from source character stream. " Here we will receive an integer and a fractional part. They must " be converted to bits and stored. They have been pre-checked. " " Number is converted from the lower bits to the higher bits. " Precision is set, scale was set by recognize. char_to_generic.fixbin: ldx7 real_fix_bin_2*2,du " set type of output ldx2 work|real.scale " copy scale stx2 work|source_scale ldx2 work|real.fraction.length " length of fraction adx2 work|real.integer.length " plus length of integer cmpx2 max_p_fix_bin_2,du " see if too many digits tpnz error_218 sxl2 work|source_precision " gives precision epp source,work|fix_bin_generic " point to target area stz source|0 " pre-set stz source|1 ldx5 71,du " bit index of target ldx4 work|real.fraction.length " get length tze char.gen.fixbin.int lxl3 work|real.fraction.index " get index adx3 work|real.fraction.length " plus length +1 tsx2 move_char_to_bit_right " move right to left " Do integer part next. Abbut to fraction. char.gen.fixbin.int: ldx4 work|real.integer.length " get length tze char.gen.fixbin.exit_1 " set precision and exit lxl3 work|real.integer.index " get index adx3 work|real.integer.length " plus length+1 tsx2 move_char_to_bit_right " move right to left tra char.gen.fixbin.exit char.gen.fixbin.exit_1: ldx3 1,du sxl3 work|real.prec " indicate source prec is 1 char.gen.fixbin.exit: ldx4 work|real.sign.length " length of sign tze 0,x1 " default + sign lxl3 work|real.sign.index " index of sign cmpc (pr,x3),(),fill(plus_sign) desc9a generic|0,1 zero tze 0,x1 " + sign ldaq work|fix_bin_generic " form negative negl tov size_error " -2**72 won't fit staq work|fix_bin_generic tra 0,x1 " Move float bin generic from source character stream. " Here we will receive an integer and a fractional part. They must " be converted to bits and stored. They have been pre-checked. " Number is converted from the lower bits to the higher bits, it is " stored starting from integer+fractional length from the top, and " the exponent is set to integer length + exponent. char_to_generic.fltbin: ldx7 real_flt_bin_2*2,du " set type of output ldx2 work|real.fraction.length " length of fraction stz work|source_scale adx2 work|real.integer.length " plus length of integer cmpx2 max_p_flt_bin_2,du " see if too many digits tpnz error_218 sxl2 work|source_precision " gives precision lda work|real.integer.length " get length DU ars 18 ada work|real.exponent.value sta work|flt_bin_generic_exp " store the flt bin gen exp epp source,work|flt_bin_generic " point to target area stz source|0 stz source|1 " pre-set mantissa ldx5 work|real.fraction.index " bit index of target adx5 work|real.integer.length ldx4 work|real.fraction.length " get length tze char.gen.fltbin.int lxl3 work|real.fraction.index " get index adx3 work|real.fraction.length tsx2 move_char_to_bit_right " move right to left " Do integer part next. Abbut to fraction. char.gen.fltbin.int: ldx4 work|real.integer.length " get length tze char.gen.fltbin.exit_1 lxl3 work|real.integer.index " get index adx3 work|real.integer.length tsx2 move_char_to_bit_right " move right to left tra char.gen.fltbin.exit char.gen.fltbin.exit_1: ldx3 1,du " indicate source precision 1 sxl3 work|real.prec char.gen.fltbin.exit: ldx4 work|real.sign.length " length of sign tze 0,x1 " default + sign lxl3 work|real.sign.index " index of sign cmpc (pr,x3),(),fill(plus_sign) desc9a generic|0,1 zero tze 0,x1 " + sign ldaq work|flt_bin_generic " form negative lde 0,du fneg staq work|flt_bin_generic lda =-1,du " form -1 to correct exp ars 18 asa work|flt_bin_generic_exp " account for shift in fneg tra 0,x1 " x3 is index into character string and is pre-decremented. " x4 is length of character string and is decremented. " x5 is index into bit string and is decremented. move_char_to_bit_right: sbx3 1,du " move source index scm (),(pr,x3),mask(000) " check 0 or 1 desc9a char.bit.01,2 desc9a generic|0,1 arg work|flt_dec_generic_exp " lowermost bit will be good csl (pr),(pr,x5),bool(move) " as true digit value descb work|flt_dec_generic_exp(35),1 descb source|0,1 sbx5 1,du " move target index sbx4 1,du " count bit done tpnz move_char_to_bit_right tra 0,x2 RECOGNIZE A REAL CONSTANT " recognize a " entered with " char offset in ql " char length in al " token area to use is imag_token " return offset in x2 " pointer to source string in generic " " exits with " char offset in ql " char length (remaining) in al " type in x7 " token area filled in recognize: ldx7 fixdec,du " preset to fixed decimal " Check for sign. Translate and test next character. mvt (pr,ql),(pr) " translate first character desc9a generic|0,1 desc9a work|flt_bin_generic_exp,1 arg translate_table cmpc (pr),(),fill(sign_class) " test if in classification desc9a work|flt_bin_generic_exp,1 zero tnz recognize.no_sign " Note sign index and length of 1. stq work|imag.sign.index " index in DL ldx3 1,du stx3 work|imag.sign.length " length of 1 sba 1,dl " done one character tmoz error_202 " error - no digits found adq 1,dl " skip sign " Check for integer part. recognize.no_sign: tct (pr,rl,ql) " skip over string of digits desc9a generic|0,al arg digit_skip arg work|fix_bin_generic lxl3 work|fix_bin_generic " get number of digits found tze recognize.no_integer " skip if none " Note that a mantissa exists by leaving a non-zero X3, and clip the " leading 0's from it to remove them from significance checks. eax4 0,x3 " remember mantissa size tct (pr,rl,ql) " skip over leading 0's desc9a generic|0,x3 arg zero_skip arg work|flt_bin_generic lxl5 work|flt_bin_generic stx5 work|flt_bin_generic " move to upper eax5 0,ql " setup index sbx4 work|flt_bin_generic " length of non-zero int adx5 work|flt_bin_generic " index of 1st non-zero " Store length of integer part, and its index. sxl5 work|imag.integer.index " significance index in DL stx4 work|imag.integer.length " length of sig string in DU stba work|fix_bin_generic,40 " clear upper byte adq work|fix_bin_generic " move string index sba work|fix_bin_generic " count all digits done tmoz recognize.no_more_input " no chars left " Check for decimal point, or other situations. recognize.no_integer: mvt (pr,ql),(pr) " translate terminator desc9a generic|0,1 desc9a work|fix_bin_generic(1),1 arg translate_table ldx4 work|fix_bin_generic " get character class anx4 =o777,du " mask for it tra *+1,4 tra error_203 " illegal tra recognize.finish_up " sign (start imag?) tra recognize.start_fractional " period tra recognize.have_bin " b tra recognize.start_exponent_flt " d e tra recognize.finish_up " i tra recognize.finish_up " blank zero 0 " digit (can't happen) tra recognize.start_scaled_fix " f " have "." after (possibly empty) string of digits recognize.start_fractional: adq 1,dl " account for . sba 1,dl tpnz recognize.scan_fraction " fractional digits cmpx3 0,du " legitimate integer? tpnz recognize.finish_up " digits already seen sbq 1,dl " no digits before/after "." tra error_202 " Find limits of fractional digits. recognize.scan_fraction: tct (pr,rl,ql) " skip over string of digits desc9a generic|0,al arg digit_skip arg work|fix_bin_generic lxl5 work|fix_bin_generic " get number of digits tze recognize.no_fraction " Fractional digits present. Note where and how many. stq work|imag.fraction.index " save index in DL stx5 work|imag.fraction.length " save length in DU adx3 work|imag.fraction.length " form total precision stbq work|fix_bin_generic,40 " clear high byte digit count adq work|fix_bin_generic " account for digits sba work|fix_bin_generic tmoz recognize.no_more_input " exit if end reached " we are scanning character after string of fractional digits recognize.no_fraction: mvt (pr,ql),(pr) " translate terminator desc9a generic|0,1 desc9a work|fix_bin_generic(1),1 arg translate_table ldx4 work|fix_bin_generic " get char type anx4 =o777,du tra *+1,4 tra error_203 " illegal tra recognize.finish_up " sign tra error_204 " period tra recognize.have_bin " b tra recognize.start_exponent_flt " d e tra recognize.finish_up " i tra recognize.finish_up " blank zero 0 " digit (can't happen) tra recognize.start_scaled_fix " f " we have "d" or "e" after mantissa recognize.start_exponent_flt: eax7 fltdec " change type " we have "f" after mantissa recognize.start_scaled_fix: cmpx3 0,dl tze error_214 " no digits before e or f adq 1,dl " account for exponent start sba 1,dl tmoz error_201 mvt (pr,ql),(pr) " translate terminator desc9a generic|0,1 desc9a work|fix_bin_generic,1 arg translate_table cmpc (pr),(),fill(sign_class) " check for sign desc9a work|fix_bin_generic,1 zero tnz recognize.unsigned_exponent " have start of signed exponent adq 1,dl " account for sign sba 1,dl tmoz error_201 tct (pr,rl,ql) " skip over string of digits desc9a generic|0,al arg digit_skip arg work|fix_bin_generic lxl5 work|fix_bin_generic " get number of digits tze error_201 " no digits in exponent cmpx5 11,du " check for max digits tpl error_213 " too many digits adx5 1,du " allow for sign dtb (pr,rl,ql),(pr) " convert exponent to binary desc9ls source|-1(3),x5 desc9a work|imag.exponent.value,4 tra recognize.common_exponent " have start of unsigned exponent recognize.unsigned_exponent: tct (pr,rl,ql) " skip over string of digits desc9a generic|0,al arg digit_skip arg work|fix_bin_generic lxl5 work|fix_bin_generic " get number of digits tze error_201 " no digits cmpx5 11,du " check for max digits tpl error_213 dtb (pr,rl,ql),(pr) " convert exponent to binary desc9ns generic|0,x5 desc9a work|imag.exponent.value,4 recognize.common_exponent: stbq work|fix_bin_generic,40 " clear high byte digit count adq work|fix_bin_generic " count exponent digits sba work|fix_bin_generic tmoz recognize.no_more_input " we are scanning character after exponent field mvt (pr,ql),(pr) " translate terminator desc9a generic|0,1 desc9a work|fix_bin_generic(1),1 arg translate_table ldx4 work|fix_bin_generic " get character class anx4 =o777,du tra *+1,4 tra error_203 " illegal tra recognize.finish_up " sign tra error_204 " period tra recognize.have_bin " b tra error_207 " d e tra recognize.finish_up " i tra recognize.finish_up " blank zero 0 " digit (can't happen) tra error_207 " f " have "b" at end, validate bit input form of 0 or 1. recognize.have_bin: ldx3 work|imag.integer.length " get length of integer tze recognize.bin.int " nothing to check lxl4 work|imag.integer.index " get index of integer tct (pr,rl,x4) " validate integer part desc9a generic|0,x3 arg bit_test arg work|fix_bin_generic " dummy ttf error_191 " invalid digit recognize.bin.int: ldx3 work|imag.fraction.length " get length of fraction tze recognize.bin.frac " nothing to check lxl4 work|imag.fraction.index " get index of fraction tct (pr,rl,x4) " validate fraction part desc9a generic|0,x3 arg bit_test arg work|fix_bin_generic " dummy ttf error_191 " invalid digit recognize.bin.frac: adq 1,dl " account for "b" sba 1,dl eax7 -2,7 " base from dec to bin " Entry if input scan is done. Now fixup terminator. recognize.end_of_input: mvt (pr,ql),(pr) " translate terminator desc9a generic|0,1 desc9a work|fix_bin_generic(1),1 arg translate_table ldx4 work|fix_bin_generic " get character class anx4 =o777,du tra recognize.finish_up " Entry if input exhausted. recognize.no_more_input: ldx4 blank_class,du " presume ended on blank recognize.finish_up: " accept terminator found ldx3 work|imag.integer.length " for digit count adx3 work|imag.fraction.length stx7 work|imag.type " save internal type code sxl4 work|imag.term " save termination character ldx3 work|imag.integer.length " form precision adx3 work|imag.fraction.length sxl3 work|imag.prec " save in DL ldx4 work|imag.fraction.length stx4 work|imag.scale " save scale in DU " Scaled fixed numbers should have the scale corrected for any exponent " which may have been specified. cmpx7 fixbin,du tze recognize.fix_scale " fixup scale from exp cmpx7 fixdec,du tnz 0,2 " not a fixed type recognize.fix_scale: ldx4 work|imag.exponent.value " load upper part tze recognize.finish_scale " okay if clear tpl error_208 " big cmpx4 =o777777,du " okay if -1 tnz error_209 " small recognize.finish_scale: lxl4 work|imag.exponent.value " get exponent sbx4 work|imag.scale " -scale tmi recognize.scale_pos " negative scale cmpx4 -min_scale,du tpnz error_209 " scale too small erx4 =o777777,du " complement adx4 1,du " add one stx4 work|imag.scale " save scale tra 0,2 " return recognize.scale_pos: erx4 =o777777,du " complement adx4 1,du " add one cmpx4 max_scale,du tpnz error_208 " scale too big stx4 work|imag.scale " save scale tra 0,2 " return Table of translations for errors. Only valid info will be 0. " This table is used to initially check the incoming string, and is a full " 9-bit translation. This permits the other tables to be much smaller and " only encompass the contiguous zero-area of this table. error_table: oct 777777777777,777777777777 000 - 007 oct 777777777777,777777777777 010 - 017 oct 777777777777,777777777777 020 - 027 oct 777777777777,777777777777 030 - 037 oct 000777777777,777777777777 040 - 047 blank oct 777777777000,777000000777 050 - 057 + - . oct 000000000000,000000000000 060 - 061 01234567 oct 000000777777,777777777777 070 - 077 89 oct 777777000777,000000000777 100 - 107 B D E F oct 777000777777,777777777777 110 - 117 I oct 777777777777,777777777777 120 - 127 oct 777777777777,777777777777 130 - 137 oct 777777000777,000000000777 140 - 147 b d e f oct 777000777777,777777777777 150 - 157 i oct 777777777777,777777777777 160 - 167 oct 777777777777,777777777777 170 - 177 oct 777777777777,777777777777 200 - 207 oct 777777777777,777777777777 210 - 217 oct 777777777777,777777777777 220 - 227 oct 777777777777,777777777777 230 - 237 oct 777777777777,777777777777 240 - 247 oct 777777777777,777777777777 250 - 257 oct 777777777777,777777777777 260 - 267 oct 777777777777,777777777777 270 - 277 oct 777777777777,777777777777 300 - 307 oct 777777777777,777777777777 310 - 317 oct 777777777777,777777777777 320 - 327 oct 777777777777,777777777777 330 - 337 oct 777777777777,777777777777 340 - 347 oct 777777777777,777777777777 350 - 357 oct 777777777777,777777777777 360 - 367 oct 777777777777,777777777777 370 - 377 oct 777777777777,777777777777 400 - 407 oct 777777777777,777777777777 410 - 417 oct 777777777777,777777777777 420 - 427 oct 777777777777,777777777777 430 - 437 oct 777777777777,777777777777 440 - 447 oct 777777777777,777777777777 450 - 457 oct 777777777777,777777777777 460 - 467 oct 777777777777,777777777777 470 - 477 oct 777777777777,777777777777 500 - 507 oct 777777777777,777777777777 510 - 517 oct 777777777777,777777777777 520 - 527 oct 777777777777,777777777777 530 - 537 oct 777777777777,777777777777 540 - 547 oct 777777777777,777777777777 550 - 557 oct 777777777777,777777777777 560 - 567 oct 777777777777,777777777777 570 - 577 oct 777777777777,777777777777 600 - 607 oct 777777777777,777777777777 610 - 617 oct 777777777777,777777777777 620 - 627 oct 777777777777,777777777777 630 - 637 oct 777777777777,777777777777 640 - 647 oct 777777777777,777777777777 650 - 657 oct 777777777777,777777777777 660 - 667 oct 777777777777,777777777777 670 - 677 oct 777777777777,777777777777 700 - 707 oct 777777777777,777777777777 710 - 717 oct 777777777777,777777777777 720 - 727 oct 777777777777,777777777777 730 - 737 oct 777777777777,777777777777 740 - 747 oct 777777777777,777777777777 750 - 757 oct 777777777777,777777777777 760 - 767 oct 777777777777,777777777777 770 - 777 Source checking tables. " Table used to encode the input string: " " encoding characters " 0 (Any other characters) " 1 + - " 2 . " 3 B b " 4 D E d e " 5 I i " 6 SP " 7 0 1 2 3 4 5 6 7 8 9 " 8 F f translate_tab: oct 006000000000,000000000000 040 - 047 oct 000000000001,000001002000 050 - 057 oct 007007007007,007007007007 060 - 061 oct 007007000000,000000000000 070 - 077 oct 000000003000,004004010000 100 - 107 oct 000005000000,000000000000 110 - 117 oct 000000000000,000000000000 120 - 127 oct 000000000000,000000000000 130 - 137 oct 000000003000,004004010000 140 - 147 oct 000005000000 150 - 153 equ translate_table,translate_tab-8 " Table for finding contiguous digit streams. digit_tab: oct 777777777777,777777777777 040 - 047 oct 777777777777,777777777777 050 - 057 oct 000000000000,000000000000 060 - 067 oct 000000777777,777777777777 070 - 077 oct 777777777777,777777777777 100 - 107 oct 777777777777,777777777777 110 - 117 oct 777777777777,777777777777 120 - 127 oct 777777777777,777777777777 130 - 137 oct 777777777777,777777777777 140 - 147 oct 777777777777 150 - 153 equ digit_skip,digit_tab-8 " Table for finding contiguous spaces. blank_tab: oct 000777777777,777777777777 040 - 047 oct 777777777777,777777777777 050 - 057 oct 777777777777,777777777777 060 - 067 oct 777777777777,777777777777 070 - 077 oct 777777777777,777777777777 100 - 107 oct 777777777777,777777777777 110 - 117 oct 777777777777,777777777777 120 - 127 oct 777777777777,777777777777 130 - 137 oct 777777777777,777777777777 140 - 147 oct 777777777777 150 - 153 equ blank_skip,blank_tab-8 " Table used to validate bit input. Very short since we know input is " pre-validated numeric digits. bit_tab: oct 000000777777,777777777777 060 - 061 only 0 and 1 oct 777777777777 070 - 073 equ bit_test,bit_tab-8-4 " Table of translation values to check leading zeros. " True beginning is offset 40(8) characters above true table. zero_tab: oct 777777777777,777777777777 040 - 047 oct 777777777777,777777777777 050 - 057 oct 000777777777,777777777777 060 - 067 oct 777777777777,777777777777 070 - 077 oct 777777777777,777777777777 100 - 107 oct 777777777777,777777777777 110 - 117 oct 777777777777,777777777777 120 - 127 oct 777777777777,777777777777 130 - 137 oct 777777777777,777777777777 140 - 147 oct 777777777777 150 - 153 equ zero_skip,zero_tab-8 " Call GENERIC to target conversion " Register conventions for source PUT routines. " (all routines specified in the table below). All registers named below, " must be preserved by the conversion routine. " " pr0 (reserved - pl1_operators_ ptr) " pr1 points to target. " pr3 points to source. " pr5 points to work area. " pr6 (reserved - stack_frame ptr) " pr7 points to return location in any_to_any_. " x0 return offset in user program. " x3 for decimal target routines is size of flt_dec_generic. " x5 0 if no round, 1 if round. " x6 target type. " x7 source type. " work|scales stored scales (in upper halves) " work|precisions stored precisions (in lower halves) " " Decimal PUT routines require X3 as the size of the floating decimal " generic variable, including sign and hardware exponent. " In this calling sequence x6 is the target type and the GENERIC form " is correctly stored in the work area. Store in target form and update " target pointer. generic_to_target: lxl1 target_type_map,x6 tra 0,x1 " call for target conversion " GENERIC to Fixed Binary Target Conversion " GENERIC to Fixed Binary Target Conversion " Unsigned Cases and some Signed Cases put_fix_bin_1uns: ldaq work|fix_bin_generic " size the value stq target|0 " and put to target lxl2 work|target_precision " check overflow lrl 0,x2 tnz size_error epp target,target|1 " update target pointer tra pr7|0 " return put_fix_bin_1: ldaq work|fix_bin_generic stq target|0 " and store lxl2 work|target_precision " check precision erx2 =o777777,du " -precision-1 lls 72,x2 " 72-precision-sign trc size_error " too big epp target,target|1 " update target pointer tra pr7|0 " return put_fix_bin_2uns: ldaq work|fix_bin_generic staq target|0 " and store lxl2 work|target_precision " check overflow lrl 0,x2 tnz size_error epp target,target|2 " update target pointer tra pr7|0 " return put_fix_bin_2: ldaq work|fix_bin_generic staq target|0 " and store lxl2 work|target_precision " check overflow erx2 =o777777,du " -precision-1 lls 72,x2 " 72-precision-sign trc size_error " too big epp target,target|2 " update target pointer tra pr7|0 " return " Calculate first bit position from: -(precision-72-1)-1 put_fix_bin_1uns_packed: put_fix_bin_2uns_packed: lxl3 work|target_precision ldaq work|fix_bin_generic lrl 0,x3 " check overflow tnz size_error " leftover bits eax2 -73,x3 " form start bit position erx2 =o777777,du csl (pr,rl,x2),(pr,rl),bool(move) descb work|fix_bin_generic,x3 descb target|0,x3 abd target|0,x3 " update target pointer tra pr7|0 " return " Packed Signed Cases " Calculate first bit position from: -((precision+1)-72-1)-1 put_fix_bin_1_packed: put_fix_bin_2_packed: lxl3 work|target_precision eax3 1,x3 " account for sign ldaq work|fix_bin_generic eax2 -73,x3 " form start bit position erx2 =o777777,du lls 0,x2 " check overflow trc size_error " sign change due to shift csl (pr,rl,x2),(pr,rl),bool(move) descb work|fix_bin_generic,x3 descb target|0,x3 abd target|0,x3 " update target pointer tra pr7|0 " return " GENERIC to Float Binary Target Conversion " Rounding is done to the desired precision. put_flt_bin_1: ldx2 27,du " round precision tsx1 load_rounded_flt_bin fst target|0 " store away epp target,target|1 " update target pointer tra pr7|0 " return put_flt_bin_2: " target store double precision ldx2 63,du " round precision tsx1 load_rounded_flt_bin dfst target|0 " store away epp target,target|2 " update target pointer tra pr7|0 " return put_flt_bin_1_packed: put_flt_bin_2_packed: lxl2 work|target_precision " get round precision tsx1 load_rounded_flt_bin dfst work|flt_bin_generic eax2 8+1,x2 " account for sign and exp csl (pr,rl),(pr,rl),bool(move) " move to target descb work|flt_bin_generic,x2 descb target|0,x2 abd target|0,x2 " update target pointer tra pr7|0 " return " Output float binary generic form. put_flt_bin_gen: lda work|flt_bin_generic_exp " move exponent sta target|2 stz work|flt_bin_generic_exp " clear for load_round ldaq work|flt_bin_generic " check for zero tze put_flt_bin_gen.zero ldx2 63,du " round to 63 tsx1 load_rounded_flt_bin ste work|flt_bin_generic_exp lde 0,du " clear exponent dfst target|0 " move mantissa lda work|flt_bin_generic_exp ars 36-8 asa target|2 epp target,target|4 " update target pointer tra pr7|0 put_flt_bin_gen.zero: stz target|0 " zero output stz target|1 stz target|2 epp target,target|4 " update target pointer tra pr7|0 " Load the float bin generic to a true float bin and round to the " precision specified. " Called with: " x1 = return address. " x2 = precision to round to. load_rounded_flt_bin: lda work|flt_bin_generic_exp als 36-8 " make short exponent trc flt_range_error " won't fit sta work|flt_bin_generic_exp ldaq work|flt_bin_generic " get mantissa lde work|flt_bin_generic_exp " get exponent fno " find 0.0 tze 0,x1 " cannot round cmpx5 0,du tze 0,x1 " no round stx2 work|flt_bin_generic_exp " two word mask entries eax3 0,x2 adx3 work|flt_bin_generic_exp cmpa 0,du tmi load_rounded_flt_bin.negative adaq mask_table+2,x3 " round " Normalize to recover any possible overflow situation. fno ldi mask_faults,dl " clear possible overflow tra 0,x1 load_rounded_flt_bin.negative: fneg adaq mask_table+2,x3 " round fno " fix overflow staq work|fix_bin_generic " temp save ldi mask_faults,dl " clear possible overflow lda =o400000,du " generate mask ldq =0,dl lrs 0,x2 " mask for precision+sign anaq work|fix_bin_generic fneg tra 0,x1 " GENERIC to Float Hexadecimal Target Conversion " Here we must convert the generic flt_bin value to hexadecimal and " output it to the target. We will do a round here, since hex round is " different that normal binary round and therefore must be an additional " treatment. put_flt_hex_1: ldx2 27,du " do single prec round tsx1 convert_flt_bin_to_flt_hex " common conversion fst target|0 epp target,target|1 " update target pointer tra pr7|0 " return put_flt_hex_2: ldx2 63,du " do double prec round tsx1 convert_flt_bin_to_flt_hex " common conversion dfst target|0 epp target,target|2 " update target pointer tra pr7|0 " return put_flt_hex_1_packed: put_flt_hex_2_packed: lxl2 work|target_precision tsx1 convert_flt_bin_to_flt_hex " common conversion dfst work|flt_bin_generic eax2 8+1,x2 " account for sign and exp csl (pr,rl),(pr,rl),bool(move) descb work|flt_bin_generic,x2 descb target|0,x2 abd target|0,x2 " update target pointer tra pr7|0 " Convert float bin generic to rounded float hexadecimal. " Common conversion routine since there are four calls to convert bin to " hex. Converts in place in the flt_bin_generic. Rounding is done if " requested by X5^=0. X2 has rounding precision. " Result after round is left normalized. " " Called by: " tsx1 convert_flt_bin_to_flt_hex " " Leaves double float hex value in EAQ. convert_flt_bin_to_flt_hex: lca work|flt_bin_generic_exp " form shift in x3 ana =3,dl " mask for count 0-3 eax3 0,al lda work|flt_bin_generic_exp " form hex exp ada =3,dl " correct exp ceiling ars 2 " divide by 4 als 36-8 " shift to check range trc flt_range_error " too big sta work|flt_bin_generic_exp ldaq work|flt_bin_generic " get value tze c_flt_bin_to_flt_hex.zero " get normalized zero lrs 0,3 " hex normalize lde work|flt_bin_generic_exp " form full hex with exp " Rounding is done according to PL/I rules. Round up for positive, round " down for negative. Result is left normalized. cmpx5 0,du " see if rounding tze 0,x1 " none - return stx2 work|flt_bin_generic_exp " 2 word mask entries eax3 0,x2 adx3 work|flt_bin_generic_exp canaq mask_table+2,x3 " if zero bits, then won't round tze 0,x1 cmpa =0,dl " determine sign of mantissa tmi c_flt_bin_to_flt_hex.neg adaq mask_table+2,x3 " round AQ tov c_flt_bin_to_flt_hex.norm_pos " normalize needed tra 0,x1 " return to put routine c_flt_bin_to_flt_hex.zero: fld =0.0,du " load normalized 0.0 tra 0,x1 " return to put routine c_flt_bin_to_flt_hex.neg: " round down negl adaq mask_table+2,x3 " 1 bit higher tov c_flt_bin_to_flt_hex.norm_neg " normalize needed tra c_flt_bin_to_flt_hex.normal " Overflow bit indicates sign changed on positive mantissa. Thus the " Logical Right shift recovers the sign bit as the carry. c_flt_bin_to_flt_hex.norm_neg: " shift right 4 and gen sign lrl 4 ade =1b25,du " adjust exponent teo flt_range_error " too big rounded c_flt_bin_to_flt_hex.normal: staq work|fix_bin_generic " temp save lda =o400000,du " generate mask ldq =0,dl lrs 0,x2 " mask for precision+sign anaq work|fix_bin_generic negl tra 0,x1 " return to put routine c_flt_bin_to_flt_hex.norm_pos: " shift right 4 and inc exp lrl 4 ade =1b25,du teo flt_range_error " too big rounded tra 0,x1 " return to put routine " GENERIC to Float Decimal 9 Target Conversion " On entry X3 holds the length of the floating decimal number, including " sign and exponent byte. put_flt_dec_9: put_flt_dec_9_packed: lxl2 work|target_precision eax2 2,x2 " form true target length lda work|flt_dec_generic_exp " range the exponent als 36-8 trc decimal_range_error mlr (pr),(pr,x3) " move to generic desc9a work|flt_dec_generic_exp(3),1 desc9a work|flt_dec_generic-1(3),1 xec mvn.pr_rl.pr_rl,x5 " move and round mantissa desc9fl work|flt_dec_generic,x3 desc9fl target|0,x2 teo decimal_overflow " blew up teu decimal_underflow " blew up a9bd target|0,x2 " update target pointer tra pr7|0 put_flt_dec_ext: " Float Decimal Extended Case put_flt_dec_ext_packed: lxl2 work|target_precision eax2 2,x2 " form true target length sbx3 1,du " form lead sign source len xec mvn.pr_rl.pr_rl,x5 " move and round mantissa desc9ls work|flt_dec_generic,x3 desc9fl target|0,x2 tze put_flt_dec_ext.zero_exp " Update the true exponent, account for target exponent changes due to " rounding and truncation/expansion of the mantissa. mlr (pr,x2),(pr) desc9a target|-1(3),1 desc9a work|flt_dec_generic,1 " RE-USE mantissa lda work|flt_dec_generic " sign extend exp als 1 ars 36-8 ada work|flt_dec_generic_exp " integrate with big exp als 36-9 " use 9-bit exponent trc decimal_range_error " test after exp is valid sta work|flt_dec_generic_exp mlr (pr),(pr,x2) " implant exponent desc9a work|flt_dec_generic_exp,1 desc9a target|-1(3),1 put_flt_dec_ext.zero_exp: " take exponent planted a9bd target|0,x2 " update target pointer tra pr7|0 " Float Decimal 9-bit generic Case. Has leading 36-bit exponent. put_flt_dec_gen: lxl2 work|target_precision adx2 2,du " account for sign and exp sbx3 1,du " form lead sign source len xec mvn.pr_rl.pr_rl,x5 " move and round desc9ls work|flt_dec_generic,x3 " collapse/expand to target desc9fl work|flt_dec_generic,x2 tnz put_flt_dec_gen.non_zero stz work|flt_dec_generic_exp " zero exponent put_flt_dec_gen.non_zero: mlr (pr,x2),(pr) " update exponent for length desc9a work|flt_dec_generic-1(3),1 desc9a work|fix_bin_generic,1 sbx2 1,du " correct for no exponent mlr (pr,rl),(pr,rl) " move mantissa to target desc9a work|flt_dec_generic,x2 desc9a target|1,x2 lda work|fix_bin_generic " sign extend corrector als 1 ars 36-8 ada work|flt_dec_generic_exp " get exponent sta target|0 eax2 3,x2 " set round of mantissa a9bd target|0,x2 " increment and round adwp target,1,du tra pr7|0 " return to call GENERIC to Float Decimal 4 Target Conversion " On entry X3 holds the length of the floating decimal number, including " sign and exponent byte. The hardware exponent byte (8-bit) is 0. put_flt_dec_4: put_flt_dec_4_packed: lxl2 work|target_precision eax2 3,x2 " form true target length lda work|flt_dec_generic_exp " range the exponent als 36-8 trc decimal_range_error mlr (pr),(pr,x3) " move to generic desc9a work|flt_dec_generic_exp(3),1 desc9a work|flt_dec_generic-1(3),1 xec mvn.pr_rl.pr_rl,x5 " move and round mantissa desc9fl work|flt_dec_generic,x3 desc4fl target|0,x2 teo decimal_overflow " blew up teu decimal_overflow " blew up eax2 1,x2 " byte align target anx2 =o777776,du a4bd target|0,x2 " update target pointer tra pr7|0 " GENERIC to Fixed Decimal (9-bit) Target Conversion " For these conversions X3 holds the length of the float decimal number, " including the exponent and sign. " " Fixed decimal target capacity depends upon scale and precision. " We preset the floating decimal exponent to account for the fixed decimal " scale factor then do the move. If we overflow the move, then a " size is generated. " 9-bit Leading Sign Case put_fix_dec_9ls: put_fix_dec_9ls_packed: tsx2 load_flt_dec.target " load for conversion eax1 1,x1 " count in sign xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc9ls target|0,x1 tov size_error " did not fit a9bd target|0,x1 " update target pointer tra pr7|0 " 9-bit Un-signed Case put_fix_dec_9uns: put_fix_dec_9uns_packed: tsx2 load_flt_dec.target " load for conversion cmpc (pr),(),fill(minus_sign) " see if negative desc9a work|flt_dec_generic,1 zero tze size_error " cannot put -ve in uns xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc9ns target|0,x1 tov size_error " did not fit a9bd target|0,x1 " update target pointer tra pr7|0 " 9-bit Trailing Sign Case put_fix_dec_9ts: put_fix_dec_9ts_packed: tsx2 load_flt_dec.target " load for conversion eax1 1,x1 " length of signed result xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc9ts target|0,x1 tov size_error " did not fit a9bd target|0,x1 " update target pointer tra pr7|0 " GENERIC to Fixed Decimal Target Conversion (overpunched sign 9-bit) " Conversion of leading sign overpunched value is done by making the float " decimal generic a positive, and then moving unsigned to the high part of " the fixed_decimal value, then moving the overpunched sign to the leading " character position. " " NOTE. This uses flt_dec_generic_exp to store the original sign. " This uses fix_bin_generic to store the digit/sign index. put_fix_dec_9ls_ovrp: put_fix_dec_9ls_ovrp_packed: tsx2 load_flt_dec.target " load for conversion mlr (pr),(pr) " save true sign desc9a work|flt_dec_generic,1 desc9a work|flt_dec_generic_exp,1 mlr (),(pr),fill(plus_sign) " make flt_dec positive zero desc9a work|flt_dec_generic,1 xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc9ns target|0,x1 tov size_error " did not fit " Determine the leading digit and the sign. scm (),(pr),mask(000) desc9a overpunch_9_digits,10 desc9a target|0,1 arg work|fix_bin_generic " holds value lda work|fix_bin_generic cmpc (pr),(),fill(minus_sign) " determine sign desc9a work|flt_dec_generic_exp,1 zero tnz put_fix_dec_9ls_ovrp.pos " positive, digit as index ada =10,dl " increment index to negative put_fix_dec_9ls_ovrp.pos: mlr (al),(pr) " move in overpunch sign desc9a overpunch_9_source,1 desc9a target|0,1 a9bd target|0,x1 " update target pointer tra pr7|0 " Conversion of trailing sign overpunched value is done by making the float " decimal generic a positive, and then moving unsigned to the high part of " the fixed_decimal value, then moving the overpunched sign to the trailing " character position. " " NOTE. This uses flt_dec_generic_exp to store the original sign. " This uses fix_bin_generic to store the digit/sign index. put_fix_dec_9ts_ovrp: put_fix_dec_9ts_ovrp_packed: tsx2 load_flt_dec.target " load for conversion mlr (pr),(pr) " save true sign desc9a work|flt_dec_generic,1 desc9a work|flt_dec_generic_exp,1 mlr (),(pr),fill(plus_sign) " make flt_dec positive zero desc9a work|flt_dec_generic,1 xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc9ns target|0,x1 tov size_error " did not fit " Determine the trailing digit and the sign. scm (),(pr,x1),mask(000) desc9a overpunch_9_digits,10 desc9a target|-1(3),1 arg work|fix_bin_generic " holds value lda work|fix_bin_generic cmpc (pr),(),fill(minus_sign) " determine sign desc9a work|flt_dec_generic_exp,1 zero tnz put_fix_dec_9ts_ovrp.pos " positive, digit as index ada =10,dl " increment index to negative put_fix_dec_9ts_ovrp.pos: mlr (al),(pr,x1) " move in overpunch sign desc9a overpunch_9_source,1 desc9a target|-1(3),1 a9bd target|0,x1 " update target pointer tra pr7|0 " GENERIC to Fixed Decimal (4-bit) Target Conversion " For these conversions X3 holds the length of the float decimal number, " including the exponent and sign. " " Fixed decimal target capacity depends upon scale and precision. " We preset the floating decimal exponent to account for the fixed decimal " scale factor then do the move. If we overflow the move, then a " size is generated. " 4-bit Leading Sign Case put_fix_dec_4ls: put_fix_dec_4ls_packed: tsx2 load_flt_dec.target " load for conversion eax1 1,x1 " count in sign xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc4ls target|0,x1 tov size_error " did not fit eax1 1,x1 " byte align target anx1 =o777776,du a4bd target|0,x1 " update target pointer tra pr7|0 " 4-bit Un-signed Case put_fix_dec_4uns: put_fix_dec_4uns_packed: tsx2 load_flt_dec.target " load for conversion cmpc (pr),(),fill(minus_sign) " see if negative desc9a work|flt_dec_generic,1 zero tze size_error " cannot put -ve in uns xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc4ns target|0,x1 tov size_error " did not fit eax1 1,x1 " byte align target anx1 =o777776,du a4bd target|0,x1 " update target pointer tra pr7|0 " 4-bit Trailing Sign Case put_fix_dec_4ts: put_fix_dec_4ts_packed: tsx2 load_flt_dec.target " load for conversion eax1 1,x1 " account for sign xec mvn.pr_rl.pr_rl,x5 desc9fl work|flt_dec_generic,x3 desc4ts target|0,x1 tov size_error " did not fit eax1 1,x1 " byte align target anx1 =o777776,du a4bd target|0,x1 " update target pointer tra pr7|0 " Load and start conversion of flt_dec_generic to fixed decimal target " Load float decimal information and setup precision of target. " Precurser of most float to fixed target routines. " " Calling sequence: " tsx2 load_flt_dec.target " " Returns: " 1. True scaled exponent for floating decimal number in the hardware " exponent field of the flt_dec_generic variable. This has the " exponent adjusted for the scale of the target fixed decimal. " 2. X1 holds to target precision (does not include sign). " 3. X3 holds length of flt_dec_generic, including sign and exponent. load_flt_dec.target: lda work|target_scale " setup scale offset ars 18 ada work|flt_dec_generic_exp " get exponent range sta work|flt_dec_generic_exp " save for testing als 36-8 " fit to normal 8-bit trc load_flt_dec.range " exponent won't fit arl 1 load_flt_dec.range_continue: " re-enter with max neg exp sta work|flt_dec_generic_exp mlr (pr),(pr,x3) " plant true scaled exp desc9a work|flt_dec_generic_exp,1 desc9a work|flt_dec_generic-1(3),1 " as hardware exponent lxl1 work|target_precision tra 0,x2 " Exponent won't fit in 7-bits, see if too big or too small. load_flt_dec.range: eax1 -1,x3 " size less exponent cmpn (pr,rl),() " Is number zero? desc9ls work|flt_dec_generic,x1 " If so good by definition desc9ls char_zero,2 tze load_flt_dec.range.fix " No: edit number with mvne lda work|flt_dec_generic_exp " get exponent tpl size_error " it was too big load_flt_dec.range.fix: lda =o400000,du " force max neg exponent tra load_flt_dec.range_continue " GENERIC to Bit Target Conversion " Bit to target conversion. Expects pointer to bit string in generic and " length in X3. " " For varying bit, the target pointer is one beyond the length word, " so we negative index to the length word. " " NOTE. In all cases we return immediately to the user after unmasking. put_varying_bit: eaa 0,x3 " get length of bits ars 18 " position to DL sta target|-1 " save varying length lxl2 work|target_precision stx2 work|target_precision cmpx3 work|target_precision " take min (length, prec) tmoz put_bit " have min lxl2 work|target_precision " get min sxl2 target|-1 " save target length tra put_bit.common.aligned " copy all put_bit: " determine max copy length lxl2 work|target_precision put_bit.common.aligned: " Remove padded reference stz target|0 " pre-clear 1st word cmpx2 36,du tmoz put_bit.common " if one word or less stz target|1 " pre_clear 2nd word tra put_bit.common put_bit_packed: lxl2 work|target_precision put_bit.common: csl (pr,rl),(pr,rl),bool(move),fill(0) descb generic|0,x3 descb target|0,x2 tra unmask_exit " return to user " GENERIC to Character Target Conversion " Character target routine. Expects pointer to source in generic and " length in X3. These routines return directly to the user. put_varying_char: lda =o777777,dl " mask for string length ansa work|target_precision eaa 0,x3 ars 18 cmpa work|target_precision " limit to length of target tmoz put_varying_char.in_range lda work|target_precision put_varying_char.in_range: sta target|-1 " save string length tra put_char.common " move and fill all " Put simple fixed length character string. put_char: put_char_packed: lda work|target_precision ana =o777777,dl " mask for just length " Copy string to target, filling with spaces. put_char.common: mlr (pr,rl),(pr,rl),fill(blank) " move to target desc9a generic|0,x3 desc9a target|0,al tra unmask_exit " return direct to user " ERROR BRANCHES " The following branches all signal the conversion " condition. On entry, the Q contains the current " index into the string being converted. " oncodes are documented and determined according to the ASCII segment " >sss>oncode_messages_ error_191: lda 191,dl " Bin digit not 0 or 1 tra error_xxx error_201: lda 201,dl " no digit after d/e/f error_xxx: adq 1,dl " get pl1 index stz work|source_string_length " restore string length lxl2 work|original_source_length sxl2 work|source_string_length tsx1 conversion_error tra char_to_arithmetic_restart error_202: lda 202,dl " no digit in a numeric field tra error_xxx error_203: lda 203,dl " illegal char after numeric field tra error_xxx error_204: lda 204,dl " too many decimal points tra error_xxx error_205: lda 256,dl " force to 256 character limit sta work|original_source_length " save for conversion error lda 205,dl " >256 chars to convert tra error_xxx error_207: lda 207,dl " too many exponents tra error_xxx error_208: lda 208,dl " scale factor too big tra error_xxx error_209: lda 209,dl " scale factor too small tra error_xxx error_211: lda 211,dl " wrong character after "i" tra error_xxx error_213: lda 213,dl " too many digits in exponent tra error_xxx error_214: lda 214,dl " no digits in mantissa tra error_xxx error_218: lda 218,dl " prec > dec(59) or bin(71) tra error_xxx error_219: lda 219,dl " 2nd half of complex number must be imaginary tra error_xxx " SIGNALLING SUBROUTINES " " subroutine to signal conversion conditions " calling sequence is " epp generic,character_string " lda oncode " ldq onchar_index " tsx1 conversion_error " " Presumes work|source_string_length is length of string of error " Presumes availability of work|original_source pointer area. " work|source_string_length is fixed bin (35) length. " " When returns, source pointer is changed to point to onsource area " of stack extension, to permit user to change it. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " conversion_error: spri7 work|error_return " save return ptr epbp7 sp|0 " so we can get ptr to stack base again sxl0 sp|stack_frame.operator_ret_ptr " save x0 for default_error_handler_ szn work|original_source " already extended? tnz have_extension " yes - use it epp4 sb|stack_header.stack_end_ptr,* epp4 pr4|error_extension " extend stack spri4 sb|stack_header.stack_end_ptr spri4 sp|stack_frame.next_sp epp4 pr4|-error_extension lxl0 work|source_string_length " make copy of source for signalling mlr (pr,rl),(pr,rl) desc9a generic|0,x0 desc9a pr4|onsource,x0 sprp4 work|original_source " remember ptr to extension epp generic,pr4|onsource " change onsource ptr have_extension: cmpq work|source_string_length " make sure onindex is in range tmoz conversion_error.in_range ldq work|source_string_length conversion_error.in_range: lprp4 work|original_source " get ptr to old extension spri pr4|save_ptrs " now save ptrs sreg pr4|save_regs " and registers epp0 null " build arg list spri0 pr4|arglist+2 " ARG 1 - null epp0 my_name spri0 pr4|arglist+4 " ARG 2 - ptr to "any_to_any_" epp0 pr4|oncode spri0 pr4|arglist+6 " ARG 3 - oncode epp0 pr4|onsource_ptr spri0 pr4|arglist+8 " ARG 4 - ptr to source string epp0 =1 spri0 pr4|arglist+10 " ARG 5 - start character (1) epp0 work|source_string_length spri0 pr4|arglist+12 " ARG 6 - len of source string epp0 pr4|onchar_index spri0 pr4|arglist+14 " ARG 7 - index of char error epp0 pointer_desc " fill in descriptors spri0 pr4|arglist+16 " ARG 1 - pointer spri0 pr4|arglist+22 " ARG 4 - pointer epp0 my_name_desc spri0 pr4|arglist+18 " ARG 2 - character (11) packed epp0 fixbin_15_desc spri0 pr4|arglist+20 " ARG 3 - fixed bin (15) spri0 pr4|arglist+24 " ARG 5 - fixed bin (15) spri0 pr4|arglist+26 " ARG 6 - fixed bin (15) spri0 pr4|arglist+28 " ARG 7 - fixed bin (15) ldaq conversion_arg_header " 7 arguments, 7 descriptors eax0 ce_link " get routine to call epp2 pr4|0 " use PR2 for rest call_it: ora =4,dl staq pr2|arglist " comple arglist epaq * " get our linkage ptr lprplp sb|stack_header.lot_ptr,*au epp0 pr2|arglist stcd sp|stack_frame.return_ptr callsp lp|0,0* " call error routine " epbp2 sp|tbp,* " restore original value spri2 sp|stack_frame.return_ptr " of return pointer epp2 sb|stack_header.stack_end_ptr,* " get ptr to extension epp2 pr2|-error_extension lreg pr2|save_regs lpri pr2|save_ptrs " restores generic ptr epp7 work|error_return,* lxl0 sp|stack_frame.operator_ret_ptr " restore x0 stz sp|stack_frame.operator_ret_ptr " and clear switch tra 0,1 " " signal size error " size_error: lda =703,dl " size condition raised ldq =4,dl epp4 size_name tsx1 signal_from_ops tra 7|0 " Floating point range errors. flt_range_error: lda work|flt_bin_generic_exp " see if positive or negative tmi underflow_error " underflow " tra overflow_error " overflow " signal overflow error " overflow_error: lda =705,dl " overflow condition raised ldq =8,dl epp4 overflow_name tsx1 signal_from_ops tra store_float_bin_zero " " signal underflow condition " underflow_error: lda =706,dl " underflow condition raised ldq =9,dl epp4 underflow_name tsx1 signal_from_ops store_float_bin_zero: " zero float bin and finish stz work|flt_bin_generic_exp stz work|flt_bin_generic stz work|flt_bin_generic+1 tra flt_bin_generic_conversion " Decimal fixed/float range errors. decimal_range_error: lda work|flt_dec_generic_exp " see if positive or negative tmi decimal_underflow " underflow " tra decimal_overflow " overflow " " signal overflow for conversion to decimal " decimal_overflow: lda =705,dl " overflow condition raised ldq =8,dl epp4 overflow_name tsx1 signal_from_ops tra force_zero " " signal underflow for conversion to decimal " decimal_underflow: lda =706,dl underflow condition raised ldq =9,dl epp4 underflow_name tsx1 signal_from_ops force_zero: " Zero GENERIC float decimal ldx3 default_flt_dec_p,du " length of decimal mvn (),(pr,rl) desc9ls dec_zero,2 desc9fl work|flt_dec_generic,x3 stz work|flt_dec_generic_exp tra flt_dec_generic_conversion " " signal error condition for unimplemented conversion " get_ERROR: get_ERROR_packed: put_ERROR: put_ERROR_packed: " Bad data types. get_varying_char_packed: get_varying_bit_packed: put_varying_char_packed: put_varying_bit_packed: get_flt_dec_gen_packed: put_flt_dec_gen_packed: get_flt_bin_gen_packed: put_flt_bin_gen_packed: error_bad_type: lda =415,dl attempted invalid or unimp conversion ldq =5,dl = length ("error") epp4 error_name tsx1 signal_from_ops do it tra pr7|0 standard action is to ignore conversion Signal an error condition from the operators. " All conditions other than conversion error come through here. " We do an error extension of the stack to create an argument/descriptor " area for the call. Descriptors are filled in to make trace-stack " cleaner. signal_from_ops: sxl0 sp|stack_frame.operator_ret_ptr " x0 for default_error_handler spri7 work|error_return " Error extension of stack for ERROR_EXTENSION words. epbp7 sp|0 " get stack header epp2 sb|stack_header.stack_end_ptr,* epp2 pr2|error_extension spri2 sb|stack_header.stack_end_ptr spri2 sp|stack_frame.next_sp epp2 pr2|-error_extension " save end of stack ptr " Save all registers and pick up arguments from them. spri pr2|save_ptrs sreg pr2|save_regs " Create argument list. spri4 pr2|arglist+2 " ARG 1 - ptr to condition name epp0 pr2|name_length spri0 pr2|arglist+4 " ARG 2 - len of condition name epp0 sp|tbp,*0 epp0 0|-1 spri0 pr2|call_ptr epp0 pr2|call_ptr spri0 pr2|arglist+6 " ARG 3 - ptr to caller epp0 pr2|oncode spri0 pr2|arglist+8 " ARG 4 - oncode value epp0 null spri0 pr2|arglist+10 " ARG 5 - null " Build descriptors. adq string_desc " form character descriptor stq pr2|arglist+24 " store away epp0 pr2|arglist+24 spri0 pr2|arglist+12 " ARG 1 - character (n) epp0 fixbin_17_desc spri0 pr2|arglist+14 " ARG 2 - condition string len epp0 fixbin_35_desc spri0 pr2|arglist+18 " ARG 4 - oncode epp0 pointer_desc spri0 pr2|arglist+16 " ARG 3 - pointer spri0 pr2|arglist+20 " ARG 5 - pointer ldaq ops_arg_header " 5 arguments, 5 descriptors eax0 fo_link " get routine to call tra call_it " Error call tables and data. " Various constants required for setting up pointers, descriptors and " character strings for error calls. even null: its -1,1,n ops_arg_header: vfd 17/5,1/0,18/0 " 5 args, call type filled later vfd 17/5,19/0 " 5 descriptors conversion_arg_header: vfd 17/7,1/0,18/0 " 7 args, call type filled later vfd 17/7,19/0 " 7 descriptors " my_name: aci "any_to_any_" " fixbin_15_desc: oct 404000000017 " fix bin 15 fixbin_17_desc: oct 404000000021 " fix bin 17 fixbin_35_desc: oct 404000000043 " fix bin 35 pointer_desc: oct 464000000000 " pointer my_name_desc: oct 526000000013 " char 11 string_desc: oct 526000000000 " string (*) desc len=0 " size_name: aci "size" overflow_name: aci "overflow" underflow_name: aci "underflow" error_name: aci "error" " link ce_link,pl1_signal_conversion_$pl1_signal_conversion_ link fo_link,|[pl1_signal_from_ops_] " Two table for fixed binary conversion. include two_table " Table of mask constants for precision masking and generation. even " table must be double aligned mask_table: oct 377777777777,777777777777 oct 177777777777,777777777777 oct 077777777777,777777777777 oct 037777777777,777777777777 oct 017777777777,777777777777 oct 007777777777,777777777777 oct 003777777777,777777777777 oct 001777777777,777777777777 oct 000777777777,777777777777 oct 000377777777,777777777777 oct 000177777777,777777777777 oct 000077777777,777777777777 oct 000037777777,777777777777 oct 000017777777,777777777777 oct 000007777777,777777777777 oct 000003777777,777777777777 oct 000001777777,777777777777 oct 000000777777,777777777777 oct 000000377777,777777777777 oct 000000177777,777777777777 oct 000000077777,777777777777 oct 000000037777,777777777777 oct 000000017777,777777777777 oct 000000007777,777777777777 oct 000000003777,777777777777 oct 000000001777,777777777777 oct 000000000777,777777777777 oct 000000000377,777777777777 oct 000000000177,777777777777 oct 000000000077,777777777777 oct 000000000037,777777777777 oct 000000000017,777777777777 oct 000000000007,777777777777 oct 000000000003,777777777777 oct 000000000001,777777777777 oct 000000000000,777777777777 oct 000000000000,377777777777 oct 000000000000,177777777777 oct 000000000000,077777777777 oct 000000000000,037777777777 oct 000000000000,017777777777 oct 000000000000,007777777777 oct 000000000000,003777777777 oct 000000000000,001777777777 oct 000000000000,000777777777 oct 000000000000,000377777777 oct 000000000000,000177777777 oct 000000000000,000077777777 oct 000000000000,000037777777 oct 000000000000,000017777777 oct 000000000000,000007777777 oct 000000000000,000003777777 oct 000000000000,000001777777 oct 000000000000,000000777777 oct 000000000000,000000377777 oct 000000000000,000000177777 oct 000000000000,000000077777 oct 000000000000,000000037777 oct 000000000000,000000017777 oct 000000000000,000000007777 oct 000000000000,000000003777 oct 000000000000,000000001777 oct 000000000000,000000000777 oct 000000000000,000000000377 oct 000000000000,000000000177 oct 000000000000,000000000077 oct 000000000000,000000000037 oct 000000000000,000000000017 oct 000000000000,000000000007 oct 000000000000,000000000003 oct 000000000000,000000000001 " Precision Conversion Table " Convert binary precision to necessary decimal precision, including " sign and hardware exponent. DU has decimal precision for indexed " binary precision. DL has number of bytes of binary source for that " binary precision. bin_prec_to_dec_prec: vfd 18/2,18/0 " binary prec 0 vfd 18/3,18/1 " binary prec 1 vfd 18/3,18/1 " binary prec 2 vfd 18/3,18/1 " binary prec 3 vfd 18/4,18/1 " binary prec 4 vfd 18/4,18/1 " binary prec 5 vfd 18/4,18/1 " binary prec 6 vfd 18/5,18/1 " binary prec 7 vfd 18/5,18/1 " binary prec 8 vfd 18/5,18/1 " binary prec 9 vfd 18/6,18/2 " binary prec 10 vfd 18/6,18/2 " binary prec 11 vfd 18/6,18/2 " binary prec 12 vfd 18/6,18/2 " binary prec 13 vfd 18/7,18/2 " binary prec 14 vfd 18/7,18/2 " binary prec 15 vfd 18/7,18/2 " binary prec 16 vfd 18/8,18/2 " binary prec 17 vfd 18/8,18/2 " binary prec 18 vfd 18/8,18/3 " binary prec 19 vfd 18/9,18/3 " binary prec 20 vfd 18/9,18/3 " binary prec 21 vfd 18/9,18/3 " binary prec 22 vfd 18/9,18/3 " binary prec 23 vfd 18/10,18/3 " binary prec 24 vfd 18/10,18/3 " binary prec 25 vfd 18/10,18/3 " binary prec 26 vfd 18/11,18/3 " binary prec 27 vfd 18/11,18/4 " binary prec 28 vfd 18/11,18/4 " binary prec 29 vfd 18/12,18/4 " binary prec 30 vfd 18/12,18/4 " binary prec 31 vfd 18/12,18/4 " binary prec 32 vfd 18/12,18/4 " binary prec 33 vfd 18/13,18/4 " binary prec 34 vfd 18/13,18/4 " binary prec 35 vfd 18/13,18/4 " binary prec 36 vfd 18/14,18/5 " binary prec 37 vfd 18/14,18/5 " binary prec 38 vfd 18/14,18/5 " binary prec 39 vfd 18/15,18/5 " binary prec 40 vfd 18/15,18/5 " binary prec 41 vfd 18/15,18/5 " binary prec 42 vfd 18/15,18/5 " binary prec 43 vfd 18/16,18/5 " binary prec 44 vfd 18/16,18/5 " binary prec 45 vfd 18/16,18/6 " binary prec 46 vfd 18/17,18/6 " binary prec 47 vfd 18/17,18/6 " binary prec 48 vfd 18/17,18/6 " binary prec 49 vfd 18/18,18/6 " binary prec 50 vfd 18/18,18/6 " binary prec 51 vfd 18/18,18/6 " binary prec 52 vfd 18/18,18/6 " binary prec 53 vfd 18/19,18/6 " binary prec 54 vfd 18/19,18/7 " binary prec 55 vfd 18/19,18/7 " binary prec 56 vfd 18/20,18/7 " binary prec 57 vfd 18/20,18/7 " binary prec 58 vfd 18/20,18/7 " binary prec 59 vfd 18/21,18/7 " binary prec 60 vfd 18/21,18/7 " binary prec 61 vfd 18/21,18/7 " binary prec 62 vfd 18/21,18/7 " binary prec 63 vfd 18/22,18/8 " binary prec 64 vfd 18/22,18/8 " binary prec 65 vfd 18/22,18/8 " binary prec 66 vfd 18/23,18/8 " binary prec 67 vfd 18/23,18/8 " binary prec 68 vfd 18/23,18/8 " binary prec 69 vfd 18/24,18/8 " binary prec 70 vfd 18/24,18/8 " binary prec 71 vfd 18/24,18/8 " binary prec 72 " Convert decimal digit to binary precision needed to hold it. " Used by flt_dec_to_flt_bin to maintain maximum converison precision. digit_to_prec: zero 1,0 " digit 0.0-0.99... zero 2,0 " digit 1.0-1.99... zero 3,0 " digit 2.0-2.99... zero 3,0 " digit 3.0-3.99... zero 4,0 " digit 4.0-4.99... zero 4,0 " digit 5.0-5.99... zero 4,0 " digit 6.0-6.99... zero 4,0 " digit 7.0-7.99... zero 5,0 " digit 8.0-8.99... zero 5,0 " digit 9.0-9.99... end  arc_sine_.alm 11/11/89 1150.6rew 11/11/89 0805.3 78282 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-07-15,Ginter), approve(86-07-15,MCR7287), " audit(86-07-16,Mabey), install(86-07-28,MR12.0-1104): " Change by M Mabey (installed by Ginter) to normalize input with frd. " END HISTORY COMMENTS name arc_sine_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on the GCOS routine '7nah'. " " Modified: May 10, 1985 by M Mabey - normalize input with a frd. " " Function: Approximate to single precision the arcsine or arccosine of " a value in the range [-1:1]. " " Entry: through the appropriately named entry point with: " EAQ = a value in the range [-1:1] " PR2 = the address of a 20 word, even-word aligned scratch area. " 12 words are used in this program and another 8 are allocated " for the double_square_root_ routine. " PR3 = the return address. " " Exit: EAQ = the desired angle. " " Uses: X2, X3, X4, PR5 " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. " X3 = saves a return address from arcsine. " X4 = saves a return address from part_arcsine. " PR5 = a temporary " The X register usage starts at X2 because this function calls " double_square_root_ which uses registers X0 through X2. Register X2 " is used for the same purpose in both routines. " " Since double_square_root_ expects the return address in PR3, " this register must be saved before the call is made. In addition, " double_square_root_ expects PR2 to point to an even-word aligned, " 8 word long working storage area. segdef arc_sine_radians_ segdef hfp_arc_sine_radians_ segdef arc_sine_degrees_ segdef hfp_arc_sine_degrees_ segdef arc_cosine_radians_ segdef hfp_arc_cosine_radians_ segdef arc_cosine_degrees_ segdef hfp_arc_cosine_degrees_ segref math_constants_,half_pi,hfp_half_pi,hfp_one_radian,one_radian,pi,quarter_pi equ abs_x,0 equ arg_x,2 equ y,4 equ yy,6 equ p,8 equ space_used,10 equ pp,p equ temp,abs_x equ BFP,0 equ HFP,2 bool P90.0H,004264 " yields HFP +90.0 under 'du' modification hfp_arc_sine_radians_: eax2 HFP " 2 word offset for HFP constants tsx3 arcsine frd 0 tra pr3|0 " Return to caller arc_sine_radians_: eax2 BFP tsx3 arcsine frd 0 tra pr3|0 " Return to caller hfp_arc_sine_degrees_: eax2 HFP tsx3 arcsine dfmp hfp_one_radian " Convert to degrees frd 0 tra pr3|0 " Return to caller arc_sine_degrees_: eax2 BFP tsx3 arcsine dfmp one_radian " Convert to degrees frd 0 tra pr3|0 " Return to caller hfp_arc_cosine_radians_: eax2 HFP tsx3 arcsine fneg 0 dfad hfp_half_pi " convert to cosine frd 0 tra pr3|0 " Return to caller arc_cosine_radians_: eax2 BFP tsx3 arcsine fneg 0 dfad half_pi " convert to cosine frd 0 tra pr3|0 " Return to caller hfp_arc_cosine_degrees_: eax2 HFP tsx3 arcsine dfmp hfp_one_radian " convert to degrees fneg 0 anq kill_nine_bits " clean out unnecessary bottom bits fad P90.0H,du " convert to cosine frd 0 tra pr3|0 " Return to caller arc_cosine_degrees_: eax2 BFP tsx3 arcsine dfmp one_radian,x2 " convert to degrees fneg 0 dfrd 0 " clean out unnecessary bottom bits fad =90.0,du " convert to cosine frd 0 tra pr3|0 " Return to caller arcsine: frd 0 " round and normalize input ("arg_x") fst pr2|arg_x " store sign of arg_x. tpl 2,ic " abs_x=abs(arg_x) fneg 0 fst pr2|abs_x " determine what range abs_x is in. A binary search is not used as " each higher range is much smaller than the previous one. Once the " range is determined, perform the appropriate polynomial scaling to " get abs_x into [0, .5], and then transfer to part_arcsine. " Upon return, scale the result back. fcmg =0.5,du " is abs_x in the range [0,.5) tpl above_bound_1 " no, find the correct range fld pr2|arg_x tsx4 part_arcsine tra 0,x3 " Return to entry above_bound_1: fcmg bound_2,x2 " is abs_x in the range [.5, .866) tpl above_bound_2 " no, find correct range fmp pr2|abs_x " EAQ = abs_x**2 fmp two,x2 " EAQ = 2 * abs_x**2 fsb one,x2 " EAQ = 2 * abs_x**2 - 1 tsx4 part_arcsine dfad half_pi,x2 " EAQ = part_asin + pi/2 fmp =0.5,du " EAQ = .5*part_asin + pi/4 fszn pr2|arg_x " was arg_x negative tpl 0,x3 " no, return to entry fneg 0 " EAQ = -EAQ tra 0,x3 " Return to entry above_bound_2: fcmg bound_3,x2 " is abs_x in the range [.866, .966) tpl above_bound_3 " no, find correct range fmp pr2|abs_x " EAQ = abs_x**2 dfst pr2|temp fmp eight,x2 " EAQ = 8*abs_x**2 fsb eight,x2 " EAQ = 8*abs_x**2 - 8 dfmp pr2|temp " EAQ = 8*abs_x**4 - 8*abs_x**2 fad one,x2 " EAQ = 8*abs_x**4 - 8*abs_x**2 + 1 tsx4 part_arcsine dfad three_pi_by_two,x2 " EAQ = part_asin + 3*pi/2 dfmp one_quarter,x2 " EAQ = part_asin/4 + 3*pi/8 fszn pr2|arg_x " was arg_x negative tpl 0,x3 " no, return to entry fneg 0 " EAQ = -EAQ tra 0,x3 " return to entry above_bound_3: fcmg bound_4,x2 " is abs_x in the range [.966, 1] tpnz arcsine_domain_error fmp =0.5,du " EAQ = abs_x/2 fneg 0 " EAQ = - abs_x/2 fad =0.5,du " EAQ = .5 - abs_x/2 or (1-abs_x)/2 epp5 pr3|0 " save the return address epp2 pr2|space_used " increment PR2 for sqrt tsp3 square_root,x2 " call sqrt function epp2 pr2|-space_used " restore PR2 epp3 pr5|0 " restore PR3 tsx4 part_arcsine " EAQ = sqrt ((1 - abs_x)/2) fmp two,x2 " EAQ = 2*part_asin fneg 0 " EAQ = - 2*part_asin dfad half_pi,x2 " EAQ = pi/2 - 2*part_asin fszn pr2|arg_x " was arg_x negative tpl 0,x3 " no, return to entry fneg 0 " EAQ = -EAQ tra 0,x3 " return to entry " Transfer Table " We call double_square_root_ instead of square_root_ because we need " the additional accuracy. If we call the single precision version " we can sometimes end up with a final result that will be wrong in the " second last bit of the mantissa. square_root: tra |[double_square_root_] nop tra |[hfp_double_square_root_] arcsine_domain_error: " abs_x > 1 ldq 58,dl tsx0 |[call_math_error_] fld =0.0,du tra pr3|0 " return to caller " This next subroutine calculates the arcsine of a value in the " range [0, .5]. part_arcsine: fcmg formula_bound,x2 " Can we use a short polynomial? tmi small_formula " Yup. dfst pr2|y dfmp pr2|y dfst pr2|yy " yy = y*y dfmp p2,x2 " EAQ = yy*p2 dfad p1,x2 " EAQ = p1 + yy*p2 dfmp pr2|yy " EAQ = yy*(p1 + yy*p2) dfad p0,x2 " EAQ = p0 + yy*(p1 + yy*p2) dfst pr2|p dfld pr2|yy " EAQ = yy dfad q1,x2 " EAQ = q1 + yy dfmp pr2|yy " EAQ = yy*(q1 + yy) dfad q0,x2 " EAQ = q0 + yy*(q1 + yy) dfdi pr2|p " EAQ = p/q dfmp pr2|y " EAQ = y*p/q tra 0,x4 " Return from part_arcsine small_formula: fcmg epsilon,x2 " Is any calculation necessary? tmi 0,x4 " No. Small number. Just return. dfst pr2|y dfmp pr2|y dfst pr2|yy " yy = y*y dfmp pp1,x2 " EAQ = yy*pp1 dfad pp0,x2 " EAQ = pp0 + yy*pp1 dfst pr2|pp dfld pr2|yy dfad qq0,x2 " EAQ = qq0 + yy dfdi pr2|pp " EAQ = pp/qq dfmp pr2|y " EAQ = y*pp/qq tra 0,x4 " Return from part_arcsine " Constants: (Hex values are given in octal) even p0: dec .5603629044813127d01 oct 002263241667,336306551630 p1: dec -.46145309466645d01 oct 003554253414,621544301723 p2: dec .49559947478731d00 oct 000375576333,402012333277 pp0: dec -2.21393498174243d00 oct 003671116707,231744233462 pp1: dec .63101484054356d00 oct 000503050602,166633467044 q0: dec .5603629030606043d01 oct 002263241667,241274777175 q1: dec -.554846659934668d01 oct 003516345730,544667102152 qq0: dec -2.21393497792717d00 oct 003671116707,252252114363 bound_2: dec .866025404d0 hfp_bound_2: oct 000673317272,000000000000 " sin(pi/3) bound_3: dec .965925826d0 oct 000756433521,000000000000 " sin(5*pi/12) bound_4: dec 1.0d0 oct 002040000000,000000000000 three_pi_by_two: dec .471238898038468985787763d01 oct 002226627617,714620722152 one_quarter: dec 0.25d0 oct 000200000000,000000000000 one: dec 1.0d0 oct 002040000000,000000000000 two: dec 2.0d0 oct 002100000000,000000000000 eight: dec 8d0 oct 002400000000,000000000000 formula_bound: dec 0.13052619d0 oct 000102650520,000000000000 epsilon: dec 5.7031627d-10 oct 762116304341,000000000000 kill_nine_bits: oct 777777777000 end  arc_tangent_.alm 11/11/89 1150.6rew 11/11/89 0804.2 98820 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** " HISTORY COMMENTS: " 1) change(86-07-14,BWong), approve(86-07-14,MCR7413), " audit(86-07-16,Ginter), install(86-07-28,MR12.0-1104): " Make code more efficient. " END HISTORY COMMENTS name arc_tangent_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on the GCOS routine '7naj'. " " Function: Approximate to single precision the principal value, in radians " or degrees, of the arctangent of (x, y) or z where z=x/y for any " valid input argument(s). For atan(z) the answer is in quadrant 1 " or 4 (-pi/2<=atan<=pi/2, -90<=atan<=90). For atan(x,y) the answer " will be in the correct quadrant (-pi<=atan2<=pi, -180<=atan2<=180). " " Modified: March 18, 1986 by B. Wong - Make code more efficient by " replacing " " range_0_to_1: fcmg tan_pi_by_32,x2 " tmi range_0 " range_1: tra calculate_for_range_1_to_7 " range_0: " " with " " range_0_to_1: fcmg tan_pi_by_32,x2 " range_1: tpl calculate_for_range_1_to_7 " range_0: " " Entry: through the appropriately named entry point with: " EAQ = the first argument (z or x). " PR1 = the address of the second argument (y). " PR2 = the address of a 8 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired arctangent in radians or degrees. " " Uses: X0, X1, X2, X3, X4 " X0 = saves a return address from arctan " X1 = saves a return address from arctan2 " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. " X3 = saves a return address from part_arctan " X4 = index to tables segref math_constants_,half_pi,hfp_one_radian,one_radian,pi equ BFP,0 equ HFP,2 equ z,0 equ zz,2 equ arctan_z,3 equ x,4 equ y,5 equ indicators,6 segdef arc_tangent_degrees_,hfp_arc_tangent_degrees_ segdef arc_tangent_degrees_2_,hfp_arc_tangent_degrees_2_ segdef arc_tangent_radians_,hfp_arc_tangent_radians_ segdef arc_tangent_radians_2_,hfp_arc_tangent_radians_2_ arc_tangent_degrees_: eax2 BFP " no offset for BFP constants tsx0 arctan " EAQ := arctan (x) dfmp one_radian " convert radians to degrees frd 0 tra pr3|0 " return arc_tangent_degrees_2_: eax2 BFP " no offset for BFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) dfmp one_radian " convert radians to degrees frd 0 tra pr3|0 " return arc_tangent_radians_: eax2 BFP " no offset for BFP constants tsx0 arctan " EAQ := arctan (x) frd 0 tra pr3|0 " return arc_tangent_radians_2_: eax2 BFP " no offset for BFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) frd 0 tra pr3|0 " return hfp_arc_tangent_degrees_: eax2 HFP " 2 word offset for HFP constants tsx0 arctan " EAQ := arctan (x) dfmp hfp_one_radian " convert radians to degrees frd 0 tra pr3|0 " return hfp_arc_tangent_degrees_2_: eax2 HFP " 2 word offset for HFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) dfmp hfp_one_radian " convert radians to degrees frd 0 tra pr3|0 " return hfp_arc_tangent_radians_: eax2 HFP " 2 word offset for HFP constants tsx0 arctan " EAQ := arctan (x) frd 0 tra pr3|0 " return hfp_arc_tangent_radians_2_: eax2 HFP " 2 word offset for HFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) frd 0 tra pr3|0 " return arctan: fad =0.0,du " normalize input fst pr2|arctan_z " store argument z " Find which of the 9 ranges abs(z) lies in using a binary search. " Set X4 as the range indicator. X4 is set to X2+4*(range-1) since double " precision tables with decimal BFP and octal HFP values are used. eax4 0,x2 " initialize the table index with BFP or HFP offset fcmg tan_7_pi_by_32,x2 tmi range_0_to_3 fcmg tan_13_pi_by_32,x2 tmi range_4_to_6 fcmg tan_15_pi_by_32,x2 tmi range_7 range_8: " range = 8, abs (z) >= tan_15_pi_by_32 fcmg eps1,x2 tmi 3,ic " if abs (z) < 1e71b: fld half_pi,x2 " EAQ := radians = half_pi tra set_to_quadrant_1_or_4 " else: fcmp =0.0,du tpl 2,ic fneg 0 " EAQ := abs (z) fdi =-1.0,du " EAQ := -1/abs_z tsx3 part_arctan " calculate part_arctan (-1/abs_z) " which is equivalent to - (part_arctan (1/abs_z)) fad half_pi,x2 " EAQ := radians = half_pi - part_arctan (1/abs_z) tra set_to_quadrant_1_or_4 range_7: adx4 =24,du " range = 7, tan_13_pi_by_32 <= abs (z) < tan_15_pi_by_32 tra calculate_for_range_1_to_7 range_4_to_6: fcmg tan_11_pi_by_32,x2 tmi range_4_to_5 range_6: adx4 =20,du " range = 6, tan_11_pi_by_32 <= abs (z) < tan_13_pi_by_32 tra calculate_for_range_1_to_7 range_4_to_5: fcmg tan_9_pi_by_32,x2 tmi range_4 range_5: adx4 =16,du " range = 5, tan_9_pi_by_32 <= abs (z) < tan_11_pi_by_32 tra calculate_for_range_1_to_7 range_4: adx4 =12,du " range = 4, tan_7_pi_by_32 <= abs (z) < tan_9_pi_by_32 tra calculate_for_range_1_to_7 range_0_to_3: fcmg tan_3_pi_by_32,x2 tmi range_0_to_1 fcmg tan_5_pi_by_32,x2 tmi range_2 range_3: adx4 =8,du " range = 3, tan_5_pi_by_32 <= abs (z) < tan_7_pi_by_32 tra calculate_for_range_1_to_7 range_2: adx4 =4,du " range = 2, tan_3_pi_by_32 <= abs (z) < tan_5_pi_by_32 tra calculate_for_range_1_to_7 range_0_to_1: fcmg tan_pi_by_32,x2 range_1: " range = 1, tan_pi_by_32 <= abs (z) < tan_3_pi_by_32 tpl calculate_for_range_1_to_7 range_0: " range = 0, abs (z) < tan_pi_by_32 fcmp =0.0,du tpl 2,ic fneg 0 " EAQ := abs (z) tsx3 part_arctan " EAQ := part_arctan (abs_z) tra set_to_quadrant_1_or_4 calculate_for_range_1_to_7: fcmp =0.0,du tpl 2,ic fneg 0 " EAQ := abs (z) dfad one_over_u,x4 " EAQ := t = 1/u(range) - (1/(u(range)**2)+1) / (1/u(range) + abs_z) dfdi one_plus_one_over_u_squared,x4 dfad one_over_u,x4 tsx3 part_arctan " EAQ := part_arctan (t) dfad arctan_of_u,x4 " EAQ := radians = part_arctan (t) + arctan(u(range)) set_to_quadrant_1_or_4: fszn pr2|arctan_z " set indicators tpl 0,x0 " if z >= 0 then return (radians) fneg 0 " else return (-radians) tra 0,x0 part_arctan: " EAQ contains z arg fcmg eps2,x2 " if abs (z) < 5.7031627e10 tmi 0,x3 " then return (z) dfstr pr2|z dfmp pr2|z " calculate zz = z*z fstr pr2|zz fmp p3,x2 " calculate p(zz) dfad p2,x2 fmp pr2|zz dfad p1,x2 fmp pr2|zz dfad p0,x2 fmp pr2|z " calculate z*p(zz) tra 0,x3 " return arctan2: fad =0.0,du " normalize x fst pr2|x " save normalized x for quadrant check fld pr1|0 " load y fad =0.0,du " normalize y fst pr2|y " save normalized y for quadrant check tnz y_not_zero fszn pr2|x " test if x = 0 also tze arctan2_domain_err " 0/0 is error dfld half_pi,x2 " atan(x/0) = + or - (half_pi) fszn pr2|x tpl 0,x1 " if x >= 0 then return (radians) fneg 0 " else return (-radians) tra 0,x1 y_not_zero: sti pr2|indicators " save indicators ldi no_overflow,x2 fdi pr2|x " EAQ := x/y teo quotient_too_large " if overflow, atan(x,y) = pi/2 or -pi/2 teu quotient_too_small " if underflow, atan(x,y) = 0 ldi pr2|indicators " restore previous indicators fad =0.0,du " set indicators tpl 2,ic " calculate z = abs (x,y) fneg 0 tsx0 arctan " EAQ := arctan(z) set_quadrant: fszn pr2|y " set the quadrant tpl 3,ic " if y < 0 then fneg 0 " radians = pi-radians dfad pi,x2 fszn pr2|x tpl 0,x1 " if x >= 0 then return (radians) fneg 0 " else return (-radians) tra 0,x1 " error when x=0 and y=0 arctan2_domain_err: ldq 11,dl tsx0 |[call_math_error_] fld =0.0,du tra pr3|0 " return to caller quotient_too_small: ldi pr2|indicators " restore indicators fld =0.0,du " radians = 0.0 tra set_quadrant quotient_too_large: ldi pr2|indicators " restore indicators dfld half_pi,x2 " radians = half_pi tra set_quadrant even eps1: oct 220400000000,000000000000 " 2**71 = 2.36e21 oct 044400000000,000000000000 eps2: dec 5.7031627d-10 oct 762116304341,000000000000 no_overflow: oct 000000004000,000000000000 " bit 25 is the overflow mask oct 000000004010,000000000000 " bit 33 is the hex indicator " This is the table of ranges. tan_pi_by_32: dec .98491403d-1 " tan(pi/32) oct 000062332734,000000000000 tan_3_pi_by_32: dec .30334668d00 " tan(3*pi/32) oct 000233240406,000000000000 tan_5_pi_by_32: dec .53451114d00 " tan(5*pi/32) oct 000421526707,000000000000 tan_7_pi_by_32: dec .82067879d00 " tan(7*pi/32) oct 000644140013,000000000000 tan_9_pi_by_32: dec 1.2185035d00 " tan(9*pi/32) oct 002046773754,000000000000 tan_11_pi_by_32: dec 1.8708684d00 " tan(11*pi/32) oct 002073674236,000000000000 tan_13_pi_by_32: dec 3.2965582d00 " tan(13*pi/32) oct 002151372636,000000000000 tan_15_pi_by_32: dec 10.153170d00 " tan(15*pi/32) oct 002504715423,000000000000 " This table is the value of 1/u(i), where 1/u(i)=.... one_over_u: dec 5.0273394921258481045d0 " 1/tan(pi/16) oct 002240677734,220443561021 dec 2.4142135623730950488d0 " 1/tan(2*pi/16) oct 002115202363,147747363110 dec 1.4966057626654890176d0 " 1/tan(3*pi/16) oct 002057710307,045516430250 dec 1.0d0 " 1/tan(4*pi/16) oct 002040000000,000000000000 dec .66817863791929891999d0 " 1/tan(5*pi/16) oct 000526067012,533771440572 dec .41421356237309504880d0 " 1/tan(6*pi/16) oct 000324047463,177167462204 dec .19891236737965800691d0 " 1/tan(7*pi/16) oct 000145657536,012514254010 " This table is values of 1/(u(i)**2) + 1. one_plus_one_over_u_squared: dec -.26274142369088180356d02 oct 005713347216,344112137060 dec -.68284271247461900976d01 oct 003445373031,460061031557 dec -.32398288088435500410d01 oct 003630246512,105301545417 dec -.20d1 oct 003700000000,000000000000 dec -.14464626921716895685d01 oct 003721555117,372172063463 dec -.11715728752538099024d01 oct 003732404746,317716746221 dec -.10395661298965800348d01 oct 003736567577,176041165302 " This table is values of arctan(u(i)). arctan_of_u: dec .19634954084936207740d00 " pi/16 oct 000144417665,210413214107 dec .39269908169872415481d00 " 2*pi/16 oct 000311037552,421026430215 dec .58904862254808623221d00 " 3*pi/16 oct 000455457437,631441644324 dec .78539816339744830962d00 " 4*pi/16 oct 000622077325,042055060432 dec .98174770424681038702d00 " 5*pi/16 oct 000766517212,252470274541 dec 1.17809724509617246442d00 " 6*pi/16 oct 002045545743,763144164432 dec 1.37444678594553454182d00 " 7*pi/16 oct 002053766737,233564735237 " These constants are used to approximate atan over the range [0,tan(pi/32)]. p0: dec .9999999999924517d00 oct 000777777777,777366325725 p1: dec -.33333330840148d00 oct 001525252530,533760740143 p2: dec .199987124164d00 oct 000146311331,336371476042 p3: dec -.14072538d00 oct 001667745537,162731562146 end  bfp_to_hfp_.alm 11/11/89 1150.6rew 11/11/89 0804.2 10647 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1983 * " * * " ****************************************** " Function: Convert a Binary Floating Point number to the " nearest Hexadecimal Floating Point number. " " Entry: EAQ = BFP number to convert. " PR2 = address of 2 word work area. " PR3 = return address. " " Exit: EAQ = HFP equivalent of original BFP number. " X1 = number of bits of precision lost (0 to 3). " Written 20 Dec 83 by HH. segdef bfp_to_hfp_ equ accum,0 equ exponent,1 bfp_to_hfp_: sta pr2|accum save A ste pr2|exponent store exponent lda pr2|exponent A := 8/exponent,28/0 ars 2 A := 10/exponent,26/0 ada =o001400,du A := 10/exponent+3,26/0 sta pr2|exponent lde pr2|exponent E := floor((exponent+3)/4) ars 26 A := exponent+3 ana 3,dl A := mod(exponent+3, 4) neg 0 A := -mod(exponent+3, 4) eax1 3,al X1 := 3 - mod(exponent+3, 4) lda pr2|accum restore A lrs 0,x1 normalize (discards 0 to 3 bits) tnz return done if mantissa is nonzero fld =0.0 load "normalized" floating zero return: tra pr3|0 return end  call_math_error_.alm 11/11/89 1150.6r w 11/11/89 0804.2 32031 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-07-14,BWong), approve(86-07-14,MCR7413), " audit(86-07-16,Ginter), install(86-07-28,MR12.0-1104): " Fix fortran bug 495. " END HISTORY COMMENTS " This routine is called when an error is detected by an ALM math routine. " Calling sequence is " ldq error_code " tsx0 call_math_error_ " This routine must be bound with the other math routines in order to work! " " At entry, pr0 -> pl1_operators_ | arglist of caller and must be preserved " pr2 -> work area of math routines and must be preserved " pr3 -> return loc of real math routine which may be " in the PL/I program or in an alm write-around. " " Modified by BW 86-03-18 to store PR3 in 'stack_frame.return_ptr'. " This is needed by 'trace_stack' and 'probe' to correctly " diagnose the line on which the math error occurs. In " the case of a math routine calling another math routine, " the called math routine must not encounter an error " which requires a call to 'call_math_error_'. It is up " to the math routine which calls the other math routine " to ensure this. 'double_square_root_' is currently the " only routine which is called by other math routines " (arc_sine_ and double_arc_sine_). Fixes Fortran error " number 495. " Modified by HH 84-01-13 to not store PR3 in 'stack_frame.return_ptr'. " This was of no value since control is always returned " through PR3, but was of great harm if the calling math " routine was called from another math routine, since that " would change the segment number in 'stack_frame.return_ptr' " from that of the owner of the stack frame to that of our " caller's caller (which means that the next call to " 'pl1_operators_' could return to our caller's caller " at a random offset, rather than to the owner of the frame). " segdef call_math_error_ " tempd work_ptr,ops_ptr,arglist(5) temp code " include stack_frame include stack_header " call_math_error_: epp4 2|0 save work ptr in pr4 spri3 sp|stack_frame.return_ptr save return pointer epbpsb sp|0 get ptr to base of stack push stq code save error code ldq stack_frame.support_bit,dl set support bit orsq sp|stack_frame.flag_word spri0 ops_ptr save ptr to pl1_operators_ epp2 |[error_in_math_routine_]+1 set entry ptr spri2 sp|stack_frame.entry_ptr spri4 work_ptr save work ptr where we can get at it epp2 code 1st arg = code spri2 arglist+2 fld 1*2048,dl staq arglist epaq * lprplp sb|stack_header.lot_ptr,*au call |[math_error_](arglist) epp2 work_ptr,* restore work ptr epp0 ops_ptr,* restore operator ptr sprisp sb|stack_header.stack_end_ptr pop stack eppsp sp|stack_frame.prev_sp,* tra 0,0 and return to caller " " this entry is here just so entry_pt field in stack " frame can point to an ALM entry. it must be retained. " entry error_in_math_routine_ error_in_math_routine_: end  char_bit_offset_fcns_.alm 11/11/89 1150.6rew 11/11/89 0805.2 54909 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Subroutines to manipulate the word and bit numbers of an ITS pointer as " either a character or bit offset from the base of the segment referenced " by the ITS pointer " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Created: September 1980 by G. Palter name char_bit_offset_fcns_ segdef char_offset_ " return character offset of pointer segdef add_char_offset_ " increment the character offset segdef set_char_offset_ " set the character offset segdef bit_offset_ segdef add_bit_offset_ " as above but for bit offsets segdef set_bit_offset_ " Constants even word_bit_mask: " mask to obtain word and bit offsets vfd 36/0 " nothing usefull in the A vfd 18/-1,3/0,6/-1,9/0 bit_to_char_offset: " converts bit offset to character offset vfd 36/0,36/0,36/0,36/0,36/0,36/0,36/0,36/0,36/0 vfd 36/1,36/1,36/1,36/1,36/1,36/1,36/1,36/1,36/1 vfd 36/2,36/2,36/2,36/2,36/2,36/2,36/2,36/2,36/2 vfd 36/3,36/3,36/3,36/3,36/3,36/3,36/3,36/3,36/3 " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " char_offset_: Returns the character offset relative to the base of the " segment of the character addressed by the given pointer " " dcl char_offset_ entry (pointer) returns (fixed binary (21)) reducible; " character_offset = char_offset_ (pointer_value); " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " char_offset_: ldaq pr0|2,* " pickup the pointer anaq word_bit_mask " clear unwanted bits from pointer llr 18+2 " puts character offset into A qrl 9+18+2 " puts bit offset into QL ada bit_to_char_offset,ql " add in converted bit offset sta pr0|4,* " and return it short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " add_char_offset_: Constructs a pointer to a character relative to the " character referenced by the input pointer;" the " displacement to the new character may be positive/negative " " dcl add_char_offset_ entry (pointer, fixed binary (21)) returns (pointer) " reducible; " new_pointer_value = add_char_offset_ (pointer_value, char_displacement); " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " add_char_offset_: epp3 pr0|2,* " pick up pointer epp3 pr3|0,* lda pr0|4,* " get character displacement a9bd pr3|0,al " ZAP! spri3 pr0|6,* " set output pointer short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_char_offset_: Constructs a pointer to a character in the segment " referenced by the input pointer " " dcl set_char_offset_ entry (pointer, fixed binary (21)) returns (pointer) " reducible; " new_pointer_value = set_char_offset_ (pointer_value, character_offset); " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_char_offset_: epp3 pr0|2,* " get pointer to segment ... epbp3 pr3|0,* " ... base of input pointer lda pr0|4,* " get new character offset a9bd pr3|0,al " ZAP! spri3 pr0|6,* " store into output value short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " bit_offset_: Returns the bit offset relative to the base of the segment of " the bit addressed by the given pointer " " dcl bit_offset entry (pointer) returns (fixed binary (24)) reducible; " bit_offset = bit_offset_ (pointer_value); " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " bit_offset_: ldaq pr0|2,* " pickup the pointer anaq word_bit_mask " mask out the useless bits llr 18 " puts word offset into A eax0 0,al " copy word offset alr 5 " 32 * word offset into A qrl 9+18 " puts bit offset into QL stq pr0|4,* " save it here eaq 0,x0 " get back the word offset qrl 18-2 " 4 * word offset into Q asq pr0|4,* " add to bit offset in word asa pr0|4,* " add 32 * word offset to get 36*WO + BO short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " add_bit_offset_: Constructs a pointer to a bit relative to the bit referenced " by the input pointer;" the displacement to the new bit may " be positive or negative " " dcl add_bit_offset_ entry (pointer, fixed binary (24)) returns (pointer) " reducible; " new_pointer_value = add_bit_offset_ (pointer_value, bit_displacement); " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " add_bit_offset_: epp3 pr0|2,* " pick up pointer epp3 pr3|0,* lda pr0|4,* " get bit displacement abd pr3|0,al " ZAP! spri3 pr0|6,* " set output pointer short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_bit_offset_: Constructs a pointer to a bit in the segment referenced by " the input pointer " " dcl set_bit_offset_ entry (pointer, fixed binary (24)) returns (pointer) " reducible; " new_pointer_value = set_bit_offset_ (pointer_value, bit_offset); " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_bit_offset_: epp3 pr0|2,* " get pointer to segment ... epbp3 pr3|0,* " ... base of input pointer lda pr0|4,* " get new bit offset abd pr3|0,al " ZAP! spri3 pr0|6,* " store into output value short_return end  clock_.alm 11/11/89 1150.6rew 11/11/89 0805.3 10728 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " clock_ subroutine to read the calander clock. " " Usage: " " clock_reading = clock_();" " " returns fixed bin (71) " " " " " " " " " " " " " " " " " " " " " " " " " " name clock_ entry clock_ clock_: rccl |[clock_],* read th clock cmpaq lp|clock_time make sure still going tnc clock_ loop if trouble staq lp|clock_time save for next time staq ap|2,* return to caller short_return " internal static use internal_static join /link/internal_static even clock_time: oct 0,0 end  config_.pl1 11/11/89 1150.6rew 11/11/89 0805.3 201168 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387), audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056): Correct error message documentation. END HISTORY COMMENTS */ /* format: style2 */ config: config_: proc (); /* * This is an all rings program which manages the config_deck segment. It has entries * for locating various types of information in the config_deck, as well as entries * for manipulating it. During Service Multics operation, the config_deck is protected * against simulataneous updates by wired_hardcore_data$config_lock; all updates also * automatically cause it to be immediately force updated to disk. At other times, it * is not protected (there being only one process), and any updates must be manually * requested by a call to config_$update. */ /* * Completely rewritten, for Bootload Multics, 11/13/80 W. Olin Sibert Considerable rearranged for installation, BIM, 7/82. Modified to write out deck to partition in update entry '82. Modified to not run off end of deck. K. Loepere, April '84. */ /* * Entrypoints for extracting information: * * call config_$find (card_word, cardp); * * Locates a card whose name field is card_word. If cardp is null, the first such card * in the config_deck is returned. Otherwise, the first one following the one pointed * to by cardp is used. * * call config_$find_2 (card_word, field_name, cardp); * * Similar to config_$find, but locates a card whose name is card_word, and whose first * data field contains field_name. * * call config_$find_periph (peripheral_name, cardp); * * Locates the (first) PRPH config card for the peripheral named peripheral_name. * * call config_$find_peripheral (peripheral_name, iom_no, channel_no, info, code); * * Locates the (first) PRPH config card for the peripheral named peripheral_name, * and returns the iom number, channel number, and first information parameter * from the card. If no such card can be found, code is set nonzero. * * call config_$find_parm (parameter_name, parm_ptr); * * Locates some PARM card which contains an entry for parameter_name, and returns * a pointer to the first field following the parameter name. Note that parm_ptr * therefore points into the middle of a card. * * call config_$find_table (table_name, table_size); * * Locates some TBLS card which contains an entry for table_name and returns * the number following the table name. If no appropriate card can be found, * -1 is returned for table_size. */ /* * Entrypoints for modifying the config_deck: * * call config_$clear (); * * This initializes the config_deck segment by completely filling it with "free" cards. * * call config_$init_card (card_word, cardp); * * This initializes the card image pointed to by cardp to be an empty card with the supplied name. * If cardp is null on input, it is returned as a pointer to a card in the config_deck; otherwise, * it is assumed to point to a user-supplied card buffer. * * call config_$replace (cardp1, cardp2); * * This replaces the contents of the card pointed to by cardp1 by the new card image * pointed to by cardp2. Neither pointer may be null. * * call config_$add (cardp, after_cardp); * * This adds the card image pointed to by cardp to the config_deck, at the end if * after_cardp is null, or immediately following the card pointed to by after_cardp. * * call config_$delete (cardp); * * This removes the card pointed to by cardp from the config_deck. * * call config_$update (); * * This updates the config_deck image to its disk partition, for use in circumstances * where that is not being done automatically. */ dcl ( P_cardp pointer, P_cardp1 pointer, P_cardp2 pointer, P_after_cardp pointer, P_card_word char (4) aligned, P_field_name char (4) aligned, P_peripheral_name char (4) aligned, P_parm_name char (4) aligned, P_parm_ptr pointer, P_table_name char (4) aligned, P_table_size fixed bin, P_iom_no fixed bin (3), P_channel_no fixed bin (8), P_peripheral_info bit (36) aligned, P_code fixed bin (35) ) parameter; dcl config_seg_size fixed bin (19); dcl whoami char (32); dcl idx fixed bin; dcl lock_sw bit (1) aligned; /* This is set if the config must be unlocked */ dcl (delete_idx, after_idx) fixed bin; dcl after_cardp pointer; dcl card_word char (4) aligned; dcl field_data bit (36) aligned; dcl 1 card_image aligned like config_card automatic; dcl dseg$ (0:1023) fixed bin (71) external static; dcl sys_info$initialization_state fixed bin external static; dcl get_ring_ entry () returns (fixed bin (3)); dcl sub_err_ entry () options (variable); dcl syserr entry options (variable); dcl get_ptrs_$given_segno entry (fixed bin (15)) returns (pointer); dcl pc_wired$write_wait entry (pointer, fixed bin, fixed bin); dcl astep pointer; dcl (addr, addrel, baseno, bin, binary, divide, mod, null, rel, rtrim, size, substr, unspec, verify) builtin; /* Note that none of the $find entrypoints bother to lock the config_deck. This is because their callers expect card pointers to be valid when returned, and hence must implement their own locking mechanism (calling config_$lock and config_$unlock as necessary) to make this work at all. Since most config deck hacking is done only in initialization code, anyway, this turns out not to be a problem: once initialization is over, nobody ever adds or deletes cards, so individual card pointers remain valid forever. */ find: entry (P_card_word, P_cardp); /* Find a card with a specified name */ whoami = "config_$find"; if P_cardp ^= null () then cardp = addrel (validate_cardp (P_cardp), size (config_card)); /* SKIP the one we got */ else cardp = addr (config_deck$); /* Start with first card if none specified */ config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0); /* Assume four page default (other programs know this limit, this might as well) */ config_n_cards = divide (wordno (cardp), size (config_card), 17, 0); card_word = P_card_word; do idx = config_n_cards + 1 to config_max_cards while (config_card.word ^= FREE_CARD_WORD); if config_card.word = card_word then do; /* Found one */ P_cardp = cardp; return; /* Return it */ end; cardp = addrel (cardp, size (config_card)); /* on to the next card */ end; /* of looking */ P_cardp = null (); /* Sorry... no more left */ return; /* End of config_$find */ /* */ find_2: entry (P_card_word, P_field_name, P_cardp); /* Find a card with a specified name and first field */ whoami = "config_$find_2"; cardp = addr (config_deck$); /* Start looking from the beginning */ config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0); /* Assume four page default (other programs know this limit, this might as well) */ config_n_cards = divide (wordno (cardp), size (config_card), 17, 0); card_word = P_card_word; field_data = unspec (P_field_name); /* Translate to a bitstring */ do idx = config_n_cards + 1 to config_max_cards while (config_card.word ^= FREE_CARD_WORD); if config_card.word = card_word then if config_card.data_field (1) = field_data then do; P_cardp = cardp; /* Found one */ return; /* Return it */ end; cardp = addrel (cardp, size (config_card)); /* on to the next card */ end; /* of looking */ P_cardp = null (); /* Sorry... no more left */ return; /* End of config_$find */ /* */ find_2_next: entry (P_card_word, P_field_name, P_cardp); /* Like config_$find_2, except it finds the NEXT matching card after the one at P_cardp. */ whoami = "config_$find_2_next"; if P_cardp ^= null () then cardp = addrel (validate_cardp (P_cardp), size (config_card)); /* SKIP the one we got */ else cardp = addr (config_deck$); /* Start with first card if none specified */ config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0); /* Assume four page default (other programs know this limit, this might as well) */ config_n_cards = divide (wordno (cardp), size (config_card), 17, 0); card_word = P_card_word; field_data = unspec (P_field_name); do idx = config_n_cards + 1 to config_max_cards while (config_card.word ^= FREE_CARD_WORD); if config_card.word = card_word then if config_card.data_field (1) = field_data then do; P_cardp = cardp; /* Found one */ return; end; cardp = addrel (cardp, size (config_card)); /* on to the next card */ end; /* of looking */ P_cardp = null (); /* Sorry... no more left */ return; /* End of config_$find */ find_periph: entry (P_peripheral_name, P_cardp); /* Find a PRPH card for a specified peripheral */ whoami = "config_$find_periph"; call find_2 ("prph", P_peripheral_name, P_cardp); /* Very simple */ return; /* End of config_$find_periph */ find_peripheral: entry (P_peripheral_name, P_iom_no, P_channel_no, P_peripheral_info, P_code); /* Find a PRPH card for a specified peripheral, and return info about the peripheral */ whoami = "config_$find_peripheral"; cardp = null (); /* Prepare to call ourselves to locate the card */ call find_2 ("prph", P_peripheral_name, cardp); if cardp = null () then do; /* Not found */ P_iom_no = -1; P_channel_no = -1; P_peripheral_info = ""b; P_code = 1; /* Indicate error */ return; end; P_iom_no = cardp -> prph_card.iom; /* Otherwise, return the info */ P_channel_no = cardp -> prph_card.chan; P_peripheral_info = unspec (cardp -> prph_card.model); P_code = 0; /* Indicate success */ return; /* End of config_$find_peripheral */ find_parm: entry (P_parm_name, P_parm_ptr); /* Find a PARM card with the specified field */ whoami = "config_$find_parm"; field_data = unspec (P_parm_name); /* We must search for it as bit patterns */ cardp = null (); FIND_PARM_LOOP: call find ("parm", cardp); /* Look through all the PARM cards */ if cardp ^= null () then do; /* Found one */ do idx = 1 to config_card.n_fields; /* Do any match? */ if config_card.data_field (idx) = field_data then if config_card.field_type (idx) = CONFIG_STRING_TYPE then do; P_parm_ptr = addr (config_card.data_field (idx)); return; /* Return a pointer to the matching parameter */ end; end; /* of search of a single card */ goto FIND_PARM_LOOP; /* Isn't it a KLUDGE that pl1 doesn't have do ... until? */ end; P_parm_ptr = null (); /* If not found, return null */ return; /* End of config_$find_parm */ find_table: entry (P_table_name, P_table_size); /* Find a TBLS card for the specified field, and return the size it specifies */ whoami = "config_$find_table"; field_data = unspec (P_table_name); /* We must search for it as bit patterns */ cardp = null (); FIND_TABLE_LOOP: call find ("tbls", cardp); /* Look through all the PARM cards */ if cardp ^= null () then do; /* Found one */ do idx = 1 to config_card.n_fields; /* Do any match? */ if config_card.data_field (idx) = field_data then if config_card.field_type (idx) = CONFIG_STRING_TYPE then do; if idx = config_card.n_fields then /* Nothing after the name. Grump. */ if get_ring_ () = 0 then call syserr (BEEP, "^a: TBLS card specifies no value for ^a", whoami, P_table_name); else call sub_err_ (0, whoami, ACTION_DEFAULT_RESTART, null (), (0), "TBLS card specified no value for ^a", P_table_name); else if (config_card.field_type (idx + 1) ^= CONFIG_OCTAL_TYPE) & (config_card.field_type (idx + 1) ^= CONFIG_DECIMAL_TYPE) then if get_ring_ () = 0 then call syserr (BEEP, "^a: TBLS card specifies invalid type of value for ^a", whoami, P_table_name); else call sub_err_ (0, whoami, ACTION_DEFAULT_RESTART, null (), (0), "TBLS card specifies invalid type of value for ^a", P_table_name); else do; /* At last, it's OK to return the value */ P_table_size = binary (config_card.data_field (idx + 1), 35); return; /* Return the size */ end; end; /* Of having found the right table name */ end; /* Of loop through fields on a single card */ goto FIND_TABLE_LOOP; /* Isn't it a KLUDGE that pl1 doesn't have do ... until? */ end; P_table_size = -1; /* If not found, return clearly invalid value */ return; /* End of config_$find_table */ clear: entry (); /* Clear the whole config deck */ whoami = "config_$clear"; call get_config_size (); /* This will always work for clearing; if not the first */ /* time, then in the second, recursive, invocation. */ config_n_cards = config_max_cards; do idx = 1 to config_max_cards; /* Clear out each card */ cardp = addr (config_deck.cards (idx)); config_card.word = FREE_CARD_WORD; /* The "free" pattern */ config_card.data_field (*) = EMPTY_FIELD; unspec (config_card.type_word) = ""b; /* And nothing in the type fields */ end; call unlock_config_deck (); return; /* End of config_$clear */ init_card: entry (P_card_word, P_cardp); /* Initialize a card image, possibly first getting space for it from the config deck. */ whoami = "config_$init_card"; cardp = P_cardp; /* Get the pointer */ if cardp = null () then do; /* Caller wants to get a card from the deck */ call get_config_size (); /* Locks the config deck */ if config_n_cards >= config_max_cards then /* Not bloody likely.... */ if get_ring_ () = 0 then call syserr (CRASH, "^a: The config_deck is full.", whoami); else call sub_err_ (0, whoami, ACTION_CANT_RESTART, null (), (0), "The config_deck is full."); config_n_cards = config_n_cards + 1; /* It has gotten larger */ cardp = addr (config_deck.cards (config_n_cards)); /* Get a pointer to the newly allocated image */ end; /* Of allocating new image */ config_card.word = P_card_word; /* Initialize it */ config_card.data_field (*) = EMPTY_FIELD; unspec (config_card.type_word) = ""b; if P_cardp = null () then do; /* We had to allocate a new one, so: */ call unlock_config_deck (); /* unlock, and */ P_cardp = cardp; /* return the pointer */ end; return; /* End of config_$init_card */ replace: entry (P_cardp1, P_cardp2); /* Replace card1 with card2 */ whoami = "config_$replace"; cardp = validate_cardp (P_cardp1); card_image = P_cardp2 -> config_card; /* Copy it into our stack frame */ call get_config_size (); /* Locks the config_deck */ cardp -> config_card = card_image; /* Copy the image in */ call unlock_config_deck (); /* All done */ return; /* End of config_$replace */ add: entry (P_cardp, P_after_cardp); /* Add a card, after after_card if non-null -- note that this cannot make a card first in the deck */ whoami = "config_$add"; card_image = P_cardp -> config_card; /* Copy it into our stack frame */ if P_after_cardp ^= null () then after_cardp = validate_cardp (P_after_cardp); else after_cardp = null (); call get_config_size (); /* Locks the config_deck */ if config_n_cards >= config_max_cards then /* Not bloody likely.... */ if get_ring_ () = 0 then call syserr (CRASH, "^a: The config_deck is full.", whoami); else call sub_err_ (0, whoami, ACTION_CANT_RESTART, null (), (0), "The config deck is full."); if after_cardp ^= null () then /* Find the card we are to add this after */ after_idx = divide (binary (rel (after_cardp), 18), size (config_card), 17, 0) + 1; else after_idx = config_n_cards; /* If none specified, add after the last */ config_n_cards = config_n_cards + 1; /* It has gotten larger */ do idx = (config_n_cards - 1) to (after_idx + 1) by -1; /* Move the later ones up */ config_deck.cards (idx + 1) = config_deck.cards (idx); end; config_deck.cards (after_idx + 1) = card_image; /* Pop it in */ call unlock_config_deck (); /* All done */ return; /* End of config_$add */ delete: entry (P_cardp); /* Delete a card */ whoami = "config_$delete"; cardp = validate_cardp (P_cardp); call get_config_size (); /* Locks the config_deck */ delete_idx = divide (binary (rel (cardp), 18), size (config_card), 17, 0) + 1; do idx = delete_idx + 1 to config_n_cards; /* Move the remaining ones down */ config_deck.cards (idx - 1) = config_deck.cards (idx); end; config_deck.cards (config_n_cards).word = FREE_CARD_WORD; /* Clear out the last card */ config_deck.cards (config_n_cards).data_field (*) = EMPTY_FIELD; unspec (config_deck.cards (config_n_cards).type_word) = ""b; call unlock_config_deck (); /* All done */ return; /* End of config_$delete */ update: entry (); /* Writes the config_deck back to disk, synchronously */ whoami = "config_$update"; if (get_ring_ ()) ^= 0 then /* Do nothing in test environment */ return; if sys_info$initialization_state < 2 then return; /* and nothing within bce */ call get_config_size; /* sets config_seg_size */ astep = get_ptrs_$given_segno (bin (baseno (configp), 15)); call pc_wired$write_wait (astep, 0, 4); call unlock_config_deck; return; get_config_size: proc (); /* * This procedure sets n_cards and max_cards appropriately, by examining * the information in the config_deck segment. If the segment is empty, * it is initialized appropriately. */ dcl idx fixed bin; /* First, lock the config_deck to this process. This is always done before any operation which references or modifies the config_deck. However, any putative card pointers should be validated before this step. */ call lock_config_deck (); config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0); /* Assume four page default (other programs know this limit, this might as well) */ configp = addr (config_deck$); /* Make addressable */ if config_deck.cards (1).word = ZERO_CARD_WORD then do; /* It's empty already */ config_deck.cards (1).word = FREE_CARD_WORD; /* Make config_$clear work */ call clear (); /* Clear it out completely */ config_n_cards = 0; /* And return a size of zero */ return; /* All done */ end; do idx = 1 to config_max_cards; /* Otherwise, look for the first free card */ if config_deck.cards (idx).word = FREE_CARD_WORD then goto FOUND_FREE_CARD; end; FOUND_FREE_CARD: config_n_cards = idx - 1; /* Last card used is one before the free one */ return; /* All done */ end get_config_size; validate_cardp: proc (P_validate_cardp) returns (pointer); /* * This procedure verifies that cardp is, indeed, a pointer into the config_deck * and points at the beginning of a config card. It does not, however, catch all * possible cases which would result from format errors in the config_deck. */ dcl P_validate_cardp pointer parameter; dcl return_cardp pointer; if substr (unspec (P_validate_cardp), (37 - 6), 6) ^= "43"b3 then do; INVALID_CARD_POINTER: if get_ring_ () = 0 then call syserr (CRASH, "^a: Invalid card pointer ^p does not point to a valid config card.", whoami, P_validate_cardp); else call sub_err_ (0, whoami, ACTION_CAN_RESTART, null (), (0), "Invalid card pointer ^p does not point to a valid config card.", P_validate_cardp); return (null ()); /* In case someone typed GO */ end; return_cardp = P_validate_cardp; if baseno (return_cardp) ^= baseno (addr (config_deck$)) then goto INVALID_CARD_POINTER; if mod (binary (rel (return_cardp), 18), size (config_card)) ^= 0 then goto INVALID_CARD_POINTER; if verify (rtrim (return_cardp -> config_card.word), VALID_CARD_WORD_CHARACTERS) ^= 0 then goto INVALID_CARD_POINTER; return (return_cardp); end validate_cardp; lock_config_deck: proc (); /* This procedure locks the config_deck lock if it can, and sets lock_sw if it does. If it can't be locked because of a mylock error, this is ignored, and lock_sw is not set. */ /* For now, it does nothing at all */ lock_sw = "0"b; if (get_ring_ ()) ^= 0 then /* Test environment, do nothing */ return; return; end lock_config_deck; unlock_config_deck: proc (); /* This procedure unlocks the config_deck lock if lock_sw is set. */ /* For now, it does nothing at all */ lock_sw = "0"b; if (get_ring_ ()) ^= 0 then /* Test environment, do nothing */ return; return; end unlock_config_deck; /* format: off */ %page; %include config_deck; %page; %include config_prph_card; %page; %include sub_err_flags; %page; %include syserr_constants; /* BEGIN MESSAGE DOCUMENTATION Message: config_$find_table: TBLS card specifies no value for NAME. S: $beep M: The config deck does not specify a value for NAME. A: One should be added. Message: config_$ENTRY: the config deck is full. S: $crash M: No space remained in the config deck for additional cards. A: If this recurs, try another boot tape. Remove unneccessary config cards. END MESSAGE DOCUMENTATION */ end config_;  cplx_dec_ops_.alm 11/11/89 1150.6rew 11/11/89 0805.2 68013 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " cplx_dec_ops_ -- a set of operators to do complex decimal multiplication and division " " Written 8 October 1973 by RAB " " These routines are called with a pointer to a work area in the ab and a pointer " to a string of 2 or 3 descriptors in the bp. " name cplx_dec_ops_ " equ tbp,38 contains segment number of calling program equ dtemp1,0 equ dtemp2,16 equ dtemp3,32 " " mpcdec -- complex decimal multiplication " " (a + bi) * (c + di) = (ac - bd) + (ad + bc)i " segdef mpcdec mpcdec: tsx4 cplx_setup " mp3d (pr,id),(pr,id),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp1,61 mp3d (pr,id,x2),(pr,id,x3),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp2,61 xec sb3d,al pick the instruction on the basis of target type desc9fl ab|dtemp2,61 desc9fl ab|dtemp1,61 arg bp|0 " mp3d (pr,id),(pr,id,x3),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp1,61 mp3d (pr,id,x2),(pr,id),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp2,61 xec ad3d,al desc9fl ab|dtemp1,61 desc9fl ab|dtemp2,61 arg bp|0 tra sp|tbp,*0 " sb3d: sb3d (pr),(pr),(pr,id),round sb3d (pr),(pr),(pr,id) ad3d: ad3d (pr),(pr),(pr,id,x1),round ad3d (pr),(pr),(pr,id,x1) " " dvcdec -- complex decimal / complex decimal " " (a + bi) (ac + bd) (bc - ad)i " -------- = --------- + ---------- " (c + di) 2 2 2 2 " c + d c + d " segdef dvcdec dvcdec: tsx4 cplx_setup " mp3d (pr,id),(pr,id),(pr),round arg bp|2 arg bp|2 desc9fl ab|dtemp1,61 mp3d (pr,id,x3),(pr,id,x3),(pr),round arg bp|2 arg bp|2 desc9fl ab|dtemp2,61 ad2d (pr),(pr),round desc9fl ab|dtemp2,61 desc9fl ab|dtemp1,61 " mp3d (pr,id),(pr,id),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp2,61 mp3d (pr,id,x2),(pr,id,x3),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp3,61 ad2d (pr),(pr),round desc9fl ab|dtemp3,61 desc9fl ab|dtemp2,61 tsx4 dv3d_real_vector,al divide sequence depends on target type " mp3d (pr,id,x2),(pr,id),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp2,61 mp3d (pr,id),(pr,id,x3),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp3,61 sb2d (pr),(pr),round desc9fl ab|dtemp3,61 desc9fl ab|dtemp2,61 tra dv3d_imag_vector,al " " dvrcdec -- real decimal / complex decimal " " a ac (ad)i " ------ = ------- - ------- " c + di 2 2 2 2 " c + d c + d segdef dvrcdec dvrcdec: tsx4 cplx_setup " mp3d (pr,id),(pr,id),(pr),round arg bp|2 arg bp|2 desc9fl ab|dtemp1,61 mp3d (pr,id,x3),(pr,id,x3),(pr),round arg bp|2 arg bp|2 desc9fl ab|dtemp2,61 ad2d (pr),(pr),round desc9fl ab|dtemp2,61 desc9fl ab|dtemp1,61 " mp3d (pr,id),(pr,id),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp2,61 tsx4 dv3d_real_vector,al " mp3d (pr,id),(pr,id,x3),(pr),round arg bp|1 arg bp|2 desc9fl ab|dtemp2,61 mp2d (0),(pr),round desc9ls minus_1,2,0 desc9fl ab|dtemp2,61 tra dv3d_imag_vector,al " minus_1: aci "-1" " dv3d_real_vector: tra dv3d_float_real tra dv3d_fixed_real dv3d_imag_vector: tra dv3d_float_imag tra dv3d_fixed_imag " dv3d_float_real: dv3d (pr),(pr),(pr) desc9fl ab|dtemp1,61 desc9fl ab|dtemp2,61 desc9fl ab|dtemp3,63 mvn (pr),(pr,id),round desc9fl ab|dtemp3,63 arg bp|0 tra 0,4 " dv3d_fixed_real: dv3d (pr),(pr),(pr,id) desc9fl ab|dtemp1,61 desc9fl ab|dtemp2,61 arg bp|0 tra 0,4 " " dv3d_float_imag: dv3d (pr),(pr),(pr) desc9fl ab|dtemp1,61 desc9fl ab|dtemp2,61 desc9fl ab|dtemp3,63 mvn (pr),(pr,id,x1),round desc9fl ab|dtemp3,63 arg bp|0 tra sp|tbp,*0 " dv3d_fixed_imag: dv3d (pr),(pr),(pr,id,x1) desc9fl ab|dtemp1,61 desc9fl ab|dtemp2,61 arg bp|0 tra sp|tbp,*0 " " cplx_setup: lda bp|0 get first descriptor eax1 0,al put lower half into x1 anx1 63,du mask to get the length ars 12 shift type code into low order bit ana 1,dl mask out rest of a lxl2 bp|1 get second descriptor anx2 63,du mask to get length lxl3 bp|2 anx3 63,du tra 0,4 return " " " 2 2 " abs(a + bi) = sqrt(a + b ) " segdef cabs cabs: tsx4 cplx_setup " mp3d (pr,id),(pr,id),(pr),round arg bp|1 arg bp|1 desc9fl ab|dtemp1,61 mp3d (pr,id,x2),(pr,id,x2),(pr),round arg bp|1 arg bp|1 desc9fl ab|dtemp2,61 ad2d (pr),(pr),round desc9fl ab|dtemp2,61 desc9fl ab|dtemp1,61 " tsx4 decimal_sqrt_ " tra sp|tbp,*0 " equ result,dtemp2 equ arg,dtemp3 equ atemp,48 equ i,64 " " decimal_sqrt_ uses repeated subtractions to calculate its result. " It expects a float dec(59) argument at ab|dtemp1 and calculates " a float dec(59) result which it then assigns to the target at bp|0,*. " decimal_sqrt_: sreg sp|8 save registers " ldq ab|dtemp1+15 get exponent qls 1 " qrs 28 " " " This algorithm requires that we imagine the decimal point to be at " the left of the string, so we add 59 to the exponent. " adq 59,dl " " Our intermediate calculations will use fixed dec(61) " mvn (0),(pr) desc9ls zero,2,0 desc9ls ab|result,62,0 mvn (0),(pr) desc9ls zero,2,0 desc9ls ab|arg,62,0 " " Move in the argument left normalized " tct (pr) scan for first non-zero desc9a ab|dtemp1(1),59 arg zero_table-12 arg sp|46 ttn ds_done " lda sp|46 get offset of non-zero character ana 262143,dl mask eax2 0,al save neg 0 sta sp|46 store negated result adq sp|46 adjust exponent by amount chopped off eax3 59,al get length to move " mlr (pr,rl,x2),(pr,rl) desc9a ab|dtemp1(1),x3 desc9a ab|arg(1),x3 " " Initialize length registers " eax2 62 iprec = 61 eax3 2 rprec1 = 1 eax4 3 iprec1 = 2 " " Initialize i to +01000...0 " mvn (0),(pr) desc9ls zero,2,0 desc9ls ab|i,62,0 lda =o061000,dl stba ab|i,10 " " If the exponent is odd, i and the exponent must be adjusted. " canq 1,dl tze set_exp " adq 1,dl exp = exp + 1 eax4 2 iprec1 = 1 lda =o000061060000 change i to +1000...0 stba ab|i,30 " " Get result exponent by dividing by 2 " set_exp: qrs 1 " " We repeatedly subtract until we get a negative number " sloop: sb3d (pr,rl),(pr),(pr) atemp = arg - i desc9ls ab|i,x2,0 desc9ls ab|arg,62,0 desc9ls ab|atemp,62,0 tmi new_round " mvn (pr),(pr) arg = atemp desc9ls ab|atemp,62,0 desc9ls ab|arg,62,0 ad2d (0),(pr,rl) i = i + 2 desc9ls two,2,0 desc9ls ab|i,x4,0 ad2d (0),(pr,rl) result = result + 1 desc9ls one,2,0 desc9ls ab|result,x3,0 tra sloop " " Shift precisions for next round " new_round: eax3 1,x3 rprec1 = rprec1 + 1 cmpx3 60,du tpnz ds_done " eax4 1,4 iprec1 = iprec1 + 1 sb2d (0),(pr,rl) i = i - 9 desc9ls nine,2,0 desc9ls ab|i,x4,0 sbx2 1,du iprec = iprec - 1 tra sloop " " Return sequence " " First move decimal pt back to right end of string " ds_done: sbq 59,dl " " Convert result to floating point " anq 255,dl form a fixed bin(7) and convert to string qls 27 shift into position stbq ab|result+15,40 store exponent lreg sp|8 restore registers xec dsmove,al desc9fl ab|result,61 arg bp|0 tra 0,4 return " dsmove: mvn (pr),(pr,id),round mvn (pr),(pr,id) " zero: aci "+0" one: aci "+1" two: aci "+2" nine: aci "+9" " zero_table: oct 000001002003,004005006007,010011000000 end  dec_ops_.alm 11/11/89 1150.6r w 11/11/89 0805.3 36900 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " dec_ops_ a package of runtime routines to support decimal arithmetic " " Written by Richard A. Barnes 17 October 1973. " Modified by RAB 11 September 1975 to fix 1398 " Modified by RAB 23 September 1975 to fix 1422 " name dec_ops_ " include stack_frame " include stack_header " equ mod_extension_size,32 equ tbp,38 equ indicators,46 equ qmask,55 " segdef truncate truncate: tsx2 trunc tra sp|tbp,*0 " segdef ceil ceil: tsx2 trunc tmi sp|tbp,*0 ceil(neg x) = trunc(x) cmpx1 0,du tze sp|tbp,*0 exit if no truncation xec ad2d,al ceil(pos x) = trunc(x) + 1 desc9ls one,2,0 arg bp|0 tra sp|tbp,*0 " ad2d: ad2d (0),(pr,id),round ad2d (0),(pr,id) " segdef floor floor: tsx2 trunc tpl sp|tbp,*0 floor(pos x) = trunc(x) cmpx1 0,du tze sp|tbp,*0 exit if no truncation xec sb2d,al floor(neg x) = trunc(x) - 1 desc9ls one,2,0 arg bp|0 tra sp|tbp,*0 " sb2d: sb2d (0),(pr,id),round sb2d (0),(pr,id) " one: aci "+1" " trunc: tsx1 setup " cmpn (0),(pr,id) set indicators for source desc9ls zero,2,0 arg bp|1 sti sp|indicators save indicators ldi =o4000,dl and suppress overflows " cmpa 0,dl tnz 2,ic sbq 1,dl adjust precision if float " eax1 0 assume no truncation mvn (pr,id),(pr,rl) arg bp|1 desc9ls ab|0,ql,0 tov trunc1 cmpn (pr,id),(pr,rl) check for truncation of nonzero digits arg bp|1 desc9ls ab|0,ql,0 tze 2,ic eax1 1 remember truncation xec mv_temp,al desc9ls ab|0,ql,0 arg bp|0 restore: ldi sp|indicators restore indicators with source info tra 0,2 " trunc1: xec move,al arg bp|1 arg bp|0 tra restore " mv_temp: mvn (pr,rl),(pr,id),round mvn (pr,rl),(pr,id) move: mvn (pr,id),(pr,id),round mvn (pr,id),(pr,id) " segdef sign sign: cmpn (0),(pr,id) desc9ls zero,2,0 arg bp|0 tmi s_neg tze s_zero ldq 1,dl tra sp|tbp,*0 s_zero: ldq 0,dl tra sp|tbp,*0 s_neg: lcq 1,dl tra sp|tbp,*0 " zero: aci "+0" " segdef mod mod: tsx1 setup " " must check for case mod(x,0) = x " cmpn (0),(pr,id) desc9ls zero,2,0 arg bp|2 tnz m_start xec move,al arg bp|1 arg bp|0 tra sp|tbp,*0 " " get work space " m_start: eax1 sp|0 get offset of stack frame stx1 sp|qmask lcx1 sp|qmask get - offset eppap sp|stack_frame.next_sp,* get ptr to extension eax2 mod_extension_size asx2 sp|stack_frame.next_sp+1 asx2 sp|stack_header.stack_end_ptr+1,1 " " compute float temp = op2/op3 " dv3d (pr,id),(pr,id),(pr) arg bp|2 arg bp|1 desc9fl ap|16,63 mvn (pr),(pr),round desc9fl ap|16,63 desc9fl ap|0,61 " " compute float temp = floor(op2/op3) " sti sp|indicators save indicators (and sign of op2/op3) ldi =o4000,dl prevent overflow fault " mvn (pr),(pr) desc9fl ap|0,61 desc9ls ap|16,60,0 tov mod1 ldi sp|indicators get sign of op2/op3 tpl mod2 cmpn (pr),(pr) desc9fl ap|0,61 desc9ls ap|16,60,0 tze mod2 " sb2d (0),(pr) desc9ls one,2,0 desc9ls ap|16,60,0 " mod2: mvn (pr),(pr),round desc9ls ap|16,60,0 desc9fl ap|0,61 " " compute float temp = op3 * floor(op2/op3) " mod1: mp2d (pr,id),(pr),round arg bp|2 desc9fl ap|0,61 " " subtract from op2 to get answer " xec sb3d,al desc9fl ap|0,61 arg bp|1 arg bp|0 " " free work space and return " eax2 -mod_extension_size asx2 sp|stack_frame.next_sp+1 asx2 sp|stack_header.stack_end_ptr+1,1 eppap |[operator_table] ldi sp|indicators tra sp|tbp,*0 " sb3d: sb3d (pr),(pr,id),(pr,id),round sb3d (pr),(pr,id),(pr,id) " setup: lda bp|0 get type of target ars 12 "" ana 1,dl " ldq bp|1 get length of source anq 63,dl " tra 0,1 end  double_arc_sine_.alm 11/11/89 1150.6rew 11/11/89 0805.3 119151 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-07-15,Ginter), approve(86-07-15,MCR7287), " audit(86-07-16,Mabey), install(86-07-28,MR12.0-1104): " Change by M Mabey (installed by Ginter) to do a dfcmg instead of fcmg " when testing for the upper bound on input (bound_4). " END HISTORY COMMENTS name double_arc_sine_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on the GCOS routine '7nam'. " " Function: Approximate to double precision the arcsine or arccosine of " a value in the range [-1:1]. " " Modified: May 10, 1985 by M Mabey - do a dfcmg instead of fcmg when " testing for the upper bound on input (bound_4). " " Entry: through the appropriately named entry point with: " EAQ = a value in the range [-1:1] " PR2 = the address of a 20 word, even-word aligned scratch area. " 12 words are used in this program and another 8 are allocated " for the double_square_root_ routine. " PR3 = the return address. " " Exit: EAQ = the desired angle. " " Uses: X2, X3, X4, PR5 " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. " X3 = saves a return address from arcsine. " X4 = saves a return address from part_arcsine. " PR5 = a temporary " The X register usage starts at X2 because this function calls " double_square_root_ which uses registers X0 through X2. Register " X2 is used for the same purpose in both routines. " " Since double_square_root_ expects the return address in PR3, " this register must be saved before the call is made. In addition, " double_square_root_ expects PR2 to point to an even-word aligned, " 8 word long working storage area. segdef double_arc_sine_radians_ segdef hfp_double_arc_sine_radians_ segdef double_arc_sine_degrees_ segdef hfp_double_arc_sine_degrees_ segdef double_arc_cosine_radians_ segdef hfp_double_arc_cosine_radians_ segdef double_arc_cosine_degrees_ segdef hfp_double_arc_cosine_degrees_ segref math_constants_,half_pi,hfp_half_pi,hfp_one_radian,one_radian,pi,quarter_pi equ abs_x,0 equ arg_x,2 equ y,4 equ yy,6 equ q,8 equ space_used,10 equ qq,q equ temp,abs_x equ x_minus_one,temp equ BFP,0 equ HFP,2 equ ACOS,0 equ ASIN,1 bool P1.0H,002040 " yields HFP +1.0 under 'du' modification bool P2.0H,002100 " yields HFP +2.0 under 'du' modification bool P90.0H,004264 " yields HFP +90.0 under 'du' modification hfp_double_arc_sine_radians_: eax2 HFP " 2 word offset for HFP constants tsx3 arcsine dfrd 0 tra pr3|0 " Return to caller double_arc_sine_radians_: eax2 BFP tsx3 arcsine dfrd 0 tra pr3|0 " Return to caller hfp_double_arc_sine_degrees_: eax2 HFP tsx3 arcsine dfmp hfp_one_radian " Convert to degrees dfrd 0 tra pr3|0 " Return to caller double_arc_sine_degrees_: eax2 BFP tsx3 arcsine dfmp one_radian " Convert to degrees dfrd 0 tra pr3|0 " Return to caller hfp_double_arc_cosine_radians_: eax2 HFP fcmp hfp_bound_2 " is the number close to one? tmi hfp_acos_rad_not_near_one dfcmg hfp_bound_4 " is the number greater than one? tpnz arcsine_domain_error fsb P1.0H,du " EAQ := x - 1 dfst pr2|x_minus_one fad P2.0H,du " EAQ := 1 + x fneg 0 " EAQ := -(1 + x) dfmp pr2|x_minus_one " EAQ := -(1+x)(x-1) = 1+x**2 epp5 pr3|0 " save return pointer tsp3 |[hfp_double_square_root_] epp3 pr5|0 " restore return pointer tsx3 arcsine " EAQ := asin (sqrt(1+x**2)) dfrd 0 tra pr3|0 " return to caller hfp_acos_rad_not_near_one: tsx3 arcsine fneg 0 dfad hfp_half_pi " convert to cosine dfrd 0 tra pr3|0 " Return to caller double_arc_cosine_radians_: eax2 BFP fcmp bound_2 " is the number close to one? tmi acos_rad_not_near_one dfcmg bound_4 " is the number greater than one? tpnz arcsine_domain_error fsb =1.0,du " EAQ := x - 1 dfst pr2|x_minus_one fad =2.0,du " EAQ := 1 + x fneg 0 " EAQ := -(1 + x) dfmp pr2|x_minus_one " EAQ := -(1+x)(x-1) = 1+x**2 epp5 pr3|0 " save return pointer tsp3 |[double_square_root_] epp3 pr5|0 " restore return pointer tsx3 arcsine " EAQ := asin (sqrt(1+x**2)) dfrd 0 tra pr3|0 " return to caller acos_rad_not_near_one: tsx3 arcsine fneg 0 dfad half_pi " convert to cosine dfrd 0 tra pr3|0 " Return to caller hfp_double_arc_cosine_degrees_: eax2 HFP fcmp hfp_bound_2 " is the number close to one? tmi hfp_acos_deg_not_near_one dfcmg hfp_bound_4 " is the number greater than one? tpnz arcsine_domain_error fsb P1.0H,du " EAQ := x - 1 dfst pr2|x_minus_one fad P2.0H,du " EAQ := 1 + x fneg 0 " EAQ := -(1 + x) dfmp pr2|x_minus_one " EAQ := -(1+x)(x-1) = 1+x**2 epp5 pr3|0 " save return pointer tsp3 |[hfp_double_square_root_] epp3 pr5|0 " restore return pointer tsx3 arcsine " EAQ := asin (sqrt(1+x**2)) dfmp hfp_one_radian " convert to degrees dfrd 0 tra pr3|0 " return to caller hfp_acos_deg_not_near_one: tsx3 arcsine dfmp hfp_one_radian " convert to degrees fneg 0 fad P90.0H,du " convert to cosine dfrd 0 tra pr3|0 " Return to caller double_arc_cosine_degrees_: eax2 BFP fcmp bound_2 " is the number close to one? tmi acos_deg_not_near_one dfcmg bound_4 " is the number greater than one? tpnz arcsine_domain_error fsb =1.0,du " EAQ := x - 1 dfst pr2|x_minus_one fad =2.0,du " EAQ := 1 + x fneg 0 " EAQ := -(1 + x) dfmp pr2|x_minus_one " EAQ := -(1+x)(x-1) = 1+x**2 epp5 pr3|0 " save return pointer tsp3 |[double_square_root_] epp3 pr5|0 " restore return pointer tsx3 arcsine " EAQ := asin (sqrt(1+x**2)) dfmp one_radian " convert to degrees dfrd 0 tra pr3|0 " return to caller acos_deg_not_near_one: tsx3 arcsine dfmp one_radian " convert to degrees fneg 0 fad =90.0,du " convert to cosine dfrd 0 tra pr3|0 " Return to caller arcsine: fad =0.0,du " normalize input ("arg_x") dfst pr2|arg_x " store sign of arg_x. tpl 2,ic " abs_x=abs(arg_x) fneg 0 dfst pr2|abs_x " determine what range abs_x is in. A binary search is not used as " each higher range is much smaller than the previous one. Once the " range is determined, perform the appropriate polynomial scaling to " get abs_x into [0, .5], and then transfer to part_arcsine. " Upon return, scale the result back. fcmg =0.5,du " is abs_x in the range [0,.5) tpl above_bound_1 " no, find the correct range dfld pr2|arg_x tsx4 part_arcsine tra 0,x3 " Return to entry above_bound_1: fcmg bound_2,x2 " is abs_x in the range [.5, .866) tpl above_bound_2 " no, find correct range dfmp pr2|abs_x " EAQ = abs_x**2 fmp two,x2 " EAQ = 2 * abs_x**2 fsb one,x2 " EAQ = 2 * abs_x**2 - 1 tsx4 part_arcsine dfad half_pi,x2 " EAQ = part_asin + pi/2 fmp =0.5,du " EAQ = .5*part_asin + pi/4 fszn pr2|arg_x " was arg_x negative tpl 0,x3 " no, return to entry fneg 0 " EAQ = -EAQ tra 0,x3 " Return to entry above_bound_2: fcmg bound_3,x2 " is abs_x in the range [.866, .966) tpl above_bound_3 " no, find correct range dfmp pr2|abs_x " EAQ = abs_x**2 dfstr pr2|temp fmp eight,x2 " EAQ = 8*abs_x**2 fsb eight,x2 " EAQ = 8*abs_x**2 - 8 dfmp pr2|temp " EAQ = 8*abs_x**4 - 8*abs_x**2 fad one,x2 " EAQ = 8*abs_x**4 - 8*abs_x**2 + 1 tsx4 part_arcsine dfad three_pi_by_two,x2 " EAQ = part_asin + 3*pi/2 dfmp one_quarter,x2 " EAQ = part_asin/4 + 3*pi/8 fszn pr2|arg_x " was arg_x negative tpl 0,x3 " no, return to entry fneg 0 " EAQ = -EAQ tra 0,x3 " return to entry above_bound_3: dfcmg bound_4,x2 " is abs_x in the range [.966, 1] tpnz arcsine_domain_error fmp =0.5,du " EAQ = abs_x/2 fneg 0 " EAQ = - abs_x/2 fad =0.5,du " EAQ = .5 - abs_x/2 or (1-abs_x)/2 epp5 pr3|0 " save the return address epp2 pr2|space_used " increment PR2 for sqrt tsp3 double_square_root,x2 " call sqrt function epp2 pr2|-space_used " restore PR2 epp3 pr5|0 " restore PR3 tsx4 part_arcsine " EAQ = sqrt ((1 - abs_x)/2) fmp two,x2 " EAQ = 2*part_asin fneg 0 " EAQ = - 2*part_asin dfad half_pi,x2 " EAQ = pi/2 - 2*part_asin fszn pr2|arg_x " was arg_x negative tpl 0,x3 " no, return to entry fneg 0 " EAQ = -EAQ tra 0,x3 " return to entry " Transfer Table double_square_root: tra |[double_square_root_] nop tra |[hfp_double_square_root_] arcsine_domain_error: " abs_x > 1 ldq 65,dl tsx0 |[call_math_error_] fld =0.0,du tra pr3|0 " return to caller " This next subroutine calculates the arcsine of a value in the " range [0, .5]. part_arcsine: fcmg formula_bound,x2 " Can we use a short polynomial? tmi small_formula " Yup. dfstr pr2|y dfmp pr2|y dfstr pr2|yy " yy = y*y dfad q5,x2 " EAQ = q5+yy dfmp pr2|yy " EAQ = yy*(q5+yy) dfad q4,x2 " EAQ = q4+yy*(q5+yy) dfmp pr2|yy " EAQ = yy*(q4+yy*(q5+yy)) dfad q3,x2 " EAQ = q3+yy*(q4+yy*(q5+yy)) dfmp pr2|yy " EAQ = yy*(q3+yy*(q4+yy*(q5+yy))) dfad q2,x2 " EAQ = q2+yy*(q3+yy*(q4+yy*(q5+yy))) dfmp pr2|yy " EAQ = yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy)))) dfad q1,x2 " EAQ = q1+yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy)))) dfmp pr2|yy " EAQ = yy*(q1+yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy))))) dfad q0,x2 " EAQ = q0+yy*(q1+yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy))))) dfstr pr2|q dfld pr2|yy dfmp p6,x2 " EAQ = yy*p6 dfad p5,x2 " EAQ = p5+yy*p6 dfmp pr2|yy " EAQ = yy*(p5+yy*p6) dfad p4,x2 " EAQ = p4+yy*(p5+yy*p6) dfmp pr2|yy " EAQ = yy*(p4+yy*(p5+yy*p6)) dfad p3,x2 " EAQ = p3+yy*(p4+yy*(p5+yy*p6)) dfmp pr2|yy " EAQ = yy*(p3+yy*(p4+yy*(p5+yy*p6))) dfad p2,x2 " EAQ = p2+yy*(p3+yy*(p4+yy*(p5+yy*p6))) dfmp pr2|yy " EAQ = yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6)))) dfad p1,x2 " EAQ = p1+yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6)))) dfmp pr2|yy " EAQ = yy*(p1+yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6))))) dfad p0,x2 " EAQ = p0+yy*(p1+yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6))))) dfmp pr2|y " EAQ = y*p dfdv pr2|q " EAQ = y*p/q tra 0,x4 " Return from part_arcsine small_formula: fcmg epsilon,x2 " Is any calculation necessary? tmi 0,x4 " No. Small number. Just return. dfstr pr2|y dfmp pr2|y dfstr pr2|yy " yy = y*y dfad qq3,x2 " EAQ = qq3+yy dfmp pr2|yy " EAQ = yy*(qq3+yy) dfad qq2,x2 " EAQ = qq2+yy*(qq3+yy) dfmp pr2|yy " EAQ = yy*(qq2+yy*(qq3+yy)) dfad qq1,x2 " EAQ = qq1+yy*(qq2+yy*(qq3+yy)) dfmp pr2|yy " EAQ = yy*(qq1+yy*(qq2+yy*(qq3+yy))) dfad qq0,x2 " EAQ = qq0+yy*(qq1+yy*(qq2+yy*(qq3+yy))) dfstr pr2|qq dfld pr2|yy " EAQ = yy dfmp pp3,x2 " EAQ = yy*pp3 dfad pp2,x2 " EAQ = pp2+yy*pp3 dfmp pr2|yy " EAQ = yy*(pp2+yy*pp3) dfad pp1,x2 " EAQ = pp1+yy*(pp2+yy*pp3) dfmp pr2|yy " EAQ = yy*(pp1+yy*(pp2+yy*pp3)) dfad pp0,x2 " EAQ = pp0+yy*(pp1+yy*(pp2+yy*pp3)) dfmp pr2|y " EAQ = y*pp dfdv pr2|qq " EAQ = y*pp/qq tra 0,x4 " Return from part_arcsine " Constants: (Hex values are given in octal) even p0: dec .53849190607669366114d03 oct 006103237366,616400151323 p1: dec -.15568739285411701684d04 oct 007475310043,070061210252 p2: dec .16924399892857508174d04 oct 006323434121,443221617414 p3: dec -.85268159839800034482d03 oct 007625324301,304347124404 p4: dec .19645634637912159609d03 oct 004610723230,734277152672 p5: dec -.17029424630829249399d02 oct 005735741675,011634416260 p6: dec .27091596623264652521d00 oct 000212552775,356736703045 pp0: dec .44005608326359226844d03 oct 006067003455,571015755233 pp1: dec -.67036113799980663993d03 oct 007654150706,165612763251 pp2: dec .28631086818069079154d03 oct 006043623712,416472674304 pp3: dec -.30034170270689843770d02 oct 005703735004,737634420665 q0: dec .53849190607669366114d03 oct 006103237366,616400151323 q1: dec -.16466225795539524453d04 oct 007462130117,240261166607 q2: dec .19264901929223241968d04 oct 006360637276,510424163636 q3: dec -.10743064209874076849d04 oct 007571554307,144720432455 q4: dec .28817015748752908509d03 oct 006044012707,560730155410 q5: dec -.32508459966449899385d02 oct 005676767254,425030557322 qq0: dec .44005608326359226844d03 oct 006067003455,571015755233 qq1: dec -.74370381854373868468d03 oct 007643022751,214210513617 qq2: dec .37725729835987782917d03 oct 006057120357,116121765360 qq3: dec -.56777961133209015623d02 oct 005616343274,240351671144 bound_2: dec .866025404d0 hfp_bound_2: oct 000673317272,000000000000 " sin(pi/3) bound_3: dec .965925826d0 oct 000756433521,000000000000 " sin(5*pi/12) bound_4: dec 1.0d0 hfp_bound_4: oct 002040000000,000000000000 three_pi_by_two: dec .471238898038468985787763d01 oct 002226627617,714620722152 one_quarter: dec 0.25d0 oct 000200000000,000000000000 one: dec 1.0d0 oct 002040000000,000000000000 two: dec 2.0d0 oct 002100000000,000000000000 eight: dec 8d0 oct 002400000000,000000000000 formula_bound: dec 0.13052619d0 oct 000102650520,000000000000 epsilon: dec 5.7031627d-10 oct 762116304341,000000000000 end  double_arc_tangent_.alm 11/11/89 1150.6rew 11/11/89 0805.3 101493 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** " HISTORY COMMENTS: " 1) change(86-07-14,BWong), approve(86-07-14,MCR7413), " audit(86-07-16,Ginter), install(86-07-28,MR12.0-1104): " Make code more efficient. " END HISTORY COMMENTS name double_arc_tangent_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on the GCOS routine '7nan'. " " Function: Approximate to double precision the principal value, in radians " or degrees, of the arctangent of (x, y) or z where z=x/y for any " valid input argument(s). For atan(z) the answer is in quadrant 1 " or 4 (-pi/2<=atan<=pi/2, -90<=atan<=90). For atan(x,y) the answer " will be in the correct quadrant (-pi<=atan2<=pi, -180<=atan2<=180). " " Modified: March 18, 1986 by B. Wong - Make code more efficient by " replacing " " range_0_to_1: fcmg tan_pi_by_32,x2 " tmi range_0 " range_1: tra calculate_for_range_1_to_7 " range_0: " " with " " range_0_to_1: fcmg tan_pi_by_32,x2 " range_1: tpl calculate_for_range_1_to_7 " range_0: " " Entry: through the appropriately named entry point with: " EAQ = the first argument (z or x). " PR1 = the address of the second argument (y). " PR2 = the address of a 14 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired arctangent in radians or degrees. " " Uses: X0, X1, X2, X3, X4 " X0 = saves a return address from arctan " X1 = saves a return address from arctan2 " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. " X3 = saves a return address from part_arctan " X4 = index to tables segref math_constants_,half_pi,hfp_one_radian,one_radian,pi equ BFP,0 equ HFP,2 equ z,0 equ zz,2 equ arctan_z,4 equ x,6 equ y,8 equ indicators,10 equ abs_z_minus_u,12 segdef double_arc_tan_degrees_,double_arc_tangent_degrees_ segdef double_arc_tan_degrees_2_,double_arc_tangent_degrees_2_ segdef double_arc_tan_radians_,double_arc_tangent_radians_ segdef double_arc_tan_radians_2_,double_arc_tangent_radians_2_ segdef hfp_double_arc_tan_degrees_ segdef hfp_double_arc_tan_degrees_2_ segdef hfp_double_arc_tan_radians_ segdef hfp_double_arc_tan_radians_2_ double_arc_tangent_degrees_: double_arc_tan_degrees_: eax2 BFP " no offset for BFP constants tsx0 arctan " EAQ := arctan (x) dfmp one_radian " convert radians to degrees dfrd 0 tra pr3|0 " return double_arc_tangent_degrees_2_: double_arc_tan_degrees_2_: eax2 BFP " no offset for BFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) dfmp one_radian " convert radians to degrees dfrd 0 tra pr3|0 " return double_arc_tangent_radians_: double_arc_tan_radians_: eax2 BFP " no offset for BFP constants tsx0 arctan " EAQ := arctan (x) dfrd 0 tra pr3|0 " return double_arc_tangent_radians_2_: double_arc_tan_radians_2_: eax2 BFP " no offset for BFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) dfrd 0 tra pr3|0 " return hfp_double_arc_tan_degrees_: eax2 HFP " 2 word offset for HFP constants tsx0 arctan " EAQ := arctan (x) dfmp hfp_one_radian " convert radians to degrees dfrd 0 tra pr3|0 " return hfp_double_arc_tan_degrees_2_: eax2 HFP " 2 word offset for HFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) dfmp hfp_one_radian " convert radians to degrees dfrd 0 tra pr3|0 " return hfp_double_arc_tan_radians_: eax2 HFP " 2 word offset for HFP constants tsx0 arctan " EAQ := arctan (x) dfrd 0 tra pr3|0 " return hfp_double_arc_tan_radians_2_: eax2 HFP " 2 word offset for HFP constants tsx1 arctan2 " EAQ := arctan2 (x,y) dfrd 0 tra pr3|0 " return arctan: fad =0.0,du " normalize input and set indicators dfst pr2|arctan_z " store argument z " Find which of the 9 ranges abs(z) lies in using a binary search. " Set X4 as the range indicator. X4 is set to X4+4*(range-1) since double " precision tables with decimal BFP and octal HFP values are used. eax4 0,x2 " initialize the table index with BFP or HFP offset fcmg tan_7_pi_by_32,x2 tmi range_0_to_3 fcmg tan_13_pi_by_32,x2 tmi range_4_to_6 fcmg tan_15_pi_by_32,x2 tmi range_7 range_8: " range = 8, abs (z) >= tan_15_pi_by_32 dfcmg eps1,x2 tmi 3,ic " if abs (z) < 1e71b: dfld half_pi,x2 " EAQ := radians = half_pi tra set_to_quadrant_1_or_4 " else: fad =0.0,du tpl 2,ic fneg 0 " EAQ := abs (z) dfdi =-1.0d0 " EAQ := -1/abs_z tsx3 part_arctan " calculate part_arctan (-1/abs_z) " which is equivalent to - (part_arctan (1/abs_z)) dfad half_pi,x2 " EAQ := radians = half_pi - part_arctan (1/abs_z) tra set_to_quadrant_1_or_4 range_7: adx4 =24,du " range = 7, tan_13_pi_by_32 <= abs (z) < tan_15_pi_by_32 tra calculate_for_range_1_to_7 range_4_to_6: fcmg tan_11_pi_by_32,x2 tmi range_4_to_5 range_6: adx4 =20,du " range = 6, tan_11_pi_by_32 <= abs (z) < tan_13_pi_by_32 tra calculate_for_range_1_to_7 range_4_to_5: fcmg tan_9_pi_by_32,x2 tmi range_4 range_5: adx4 =16,du " range = 5, tan_9_pi_by_32 <= abs (z) < tan_11_pi_by_32 tra calculate_for_range_1_to_7 range_4: adx4 =12,du " range = 4, tan_7_pi_by_32 <= abs (z) < tan_9_pi_by_32 tra calculate_for_range_1_to_7 range_0_to_3: fcmg tan_3_pi_by_32,x2 tmi range_0_to_1 fcmg tan_5_pi_by_32,x2 tmi range_2 range_3: adx4 =8,du " range = 3, tan_5_pi_by_32 <= abs (z) < tan_7_pi_by_32 tra calculate_for_range_1_to_7 range_2: adx4 =4,du " range = 2, tan_3_pi_by_32 <= abs (z) < tan_5_pi_by_32 tra calculate_for_range_1_to_7 range_0_to_1: fcmg tan_pi_by_32,x2 range_1: " range = 1, tan_pi_by_32 <= abs (z) < tan_3_pi_by_32 tpl calculate_for_range_1_to_7 range_0: " range = 0, abs (z) < tan_pi_by_32 fad =0.0,du tpl 2,ic fneg 0 " EAQ := abs (z) tsx3 part_arctan " EAQ := part_arctan (abs_z) tra set_to_quadrant_1_or_4 calculate_for_range_1_to_7: fad =0.0,du tpl 2,ic fneg 0 " EAQ := abs (z) dfsb u,x4 " EAQ := abs_z - u(range) dfst pr2|abs_z_minus_u dfad u,x4 " EAQ := abs_z dfmp u,x4 " EAQ := abs_z * u(range) fad one,x2 " EAQ := 1 + abs_z*u(range) dfdi pr2|abs_z_minus_u " EAQ := t tsx3 part_arctan " EAQ := part_arctan (t) dfad arctan_of_u,x4 " EAQ := radians = part_arctan (t) + arctan(u(range)) set_to_quadrant_1_or_4: fszn pr2|arctan_z " set indicators tpl 0,x0 " if z >= 0 then return (radians) fneg 0 " else return (-radians) tra 0,x0 part_arctan: " EAQ contains z arg fcmg eps2,x2 " if abs (z) < 5.7031627e10 tmi 0,x3 " then return (z) dfstr pr2|z dfmp pr2|z " calculate zz = z*z dfstr pr2|zz dfmp p7,x2 " calculate p(zz) dfad p6,x2 dfmp pr2|zz dfad p5,x2 dfmp pr2|zz dfad p4,x2 dfmp pr2|zz dfad p3,x2 dfmp pr2|zz dfad p2,x2 dfmp pr2|zz dfad p1,x2 dfmp pr2|zz dfad one,x2 dfmp pr2|z " calculate z*p(zz) tra 0,x3 " return arctan2: fad =0.0,du " normalize x dfst pr2|x " save normalized x for quadrant check dfld pr1|0 " load y fad =0.0,du " normalize y dfst pr2|y " save normalized y for quadrant check tnz y_not_zero fszn pr2|x " test if x = 0 also tze arctan2_domain_err " 0/0 is error dfld half_pi,x2 " atan(x/0) = + or - (half_pi) fszn pr2|x tpl 0,x1 " if x >= 0 then return (radians) fneg 0 " else return (-radians) tra 0,x1 y_not_zero: sti pr2|indicators " save indicators ldi no_overflow,x2 dfdi pr2|x " EAQ := x/y teo quotient_too_large " if overflow, atan(x,y) = pi/2 or -pi/2 teu quotient_too_small " if underflow, atan(x,y) = 0 ldi pr2|indicators " restore previous indicators fad =0.0,du " set indicators tpl 2,ic " calculate z = abs (x,y) fneg 0 tsx0 arctan " EAQ := arctan(z) set_quadrant: fszn pr2|y " set the quadrant tpl 3,ic " if y < 0 then fneg 0 " radians = pi-radians dfad pi,x2 fszn pr2|x tpl 0,x1 " if x >= 0 then return (radians) fneg 0 " else return (-radians) tra 0,x1 " error when x=0 and y=0 arctan2_domain_err: ldq 24,dl tsx0 |[call_math_error_] fld =0.0,du tra pr3|0 " return to caller quotient_too_small: ldi pr2|indicators " restore indicators fld =0.0,du " radians = 0.0 tra set_quadrant quotient_too_large: ldi pr2|indicators " restore indicators dfld half_pi,x2 " radians = half_pi tra set_quadrant even eps1: oct 220400000000,000000000000 " 2**71 = 2.36e21 oct 044400000000,000000000000 eps2: dec 5.7031627d-10 oct 762116304341,000000000000 no_overflow: oct 000000004000,000000000000 " bit 25 is the overflow mask oct 000000004010,000000000000 " bit 33 is the hex indicator " This is the table of ranges. tan_pi_by_32: dec .98491403d-1 " tan(pi/32) oct 000062332734,000000000000 tan_3_pi_by_32: dec .30334668d00 " tan(3*pi/32) oct 000233240406,000000000000 tan_5_pi_by_32: dec .53451114d00 " tan(5*pi/32) oct 000421526707,000000000000 tan_7_pi_by_32: dec .82067879d00 " tan(7*pi/32) oct 000644140013,000000000000 tan_9_pi_by_32: dec 1.2185035d00 " tan(9*pi/32) oct 002046773754,000000000000 tan_11_pi_by_32: dec 1.8708684d00 " tan(11*pi/32) oct 002073674236,000000000000 tan_13_pi_by_32: dec 3.2965582d00 " tan(13*pi/32) oct 002151372636,000000000000 tan_15_pi_by_32: dec 10.153170d00 " tan(15*pi/32) oct 002504715423,000000000000 " This table is values of u, where u(i)=... u: dec 1.98912367379658006912d-01 " tan(pi/16) oct 000145657536,012514254010 dec 4.14213562373095048802d-01 " tan(2*pi/16) oct 000324047463,177167462204 dec 6.68178637919298919998d-01 " tan(3*pi/16) oct 000526067012,533771440573 dec 1.0d0 " tan(4*pi/16) oct 002040000000,000000000000 dec 1.49660576266548901760d00 " tan(5*pi/16) oct 002057710307,045516430250 dec 2.41421356237309504880d00 " tan(6*pi/16) oct 002115202363,147747363110 dec 5.02733949212584810451d00 " tan(7*pi/16) oct 002240677734,220443561021 " This table is values of arctan(u(i)). arctan_of_u: dec .19634954084936207740d00 " pi/16 oct 000144417665,210413214107 dec .39269908169872415481d00 " 2*pi/16 oct 000311037552,421026430215 dec .58904862254808623221d00 " 3*pi/16 oct 000455457437,631441644324 dec .78539816339744830962d00 " 4*pi/16 oct 000622077325,042055060432 dec .98174770424681038702d00 " 5*pi/16 oct 000766517212,252470274541 dec 1.17809724509617246442d00 " 6*pi/16 oct 002045545743,763144164432 dec 1.37444678594553454182d00 " 7*pi/16 oct 002053766737,233564735237 " These constants are used to approximate atan over the range [0,tan(pi/32)]. one: dec 1.0d0 oct 002040000000,000000000000 p1: dec -.33333333333333333154d00 oct 001525252525,252525252546 p2: dec +.19999999999999612046d00 oct 000146314631,463146206723 p3: dec -.14285714285394000547d00 oct 001666666666,667047430233 p4: dec +.1111111098121285609d00 oct 000070707070,555661001627 p5: dec -.9090880462996335d-01 oct 001721350632,623104337257 p6: dec +.76888077127566d-01 oct 000047273577,013343060615 p7: dec -.64430854376d-01 oct 001737005655,071501356653 end  double_exponential_.alm 11/11/89 1150.6rew 11/11/89 0804.2 54378 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name double_exponential_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7naq'. " " Function: Calculates the exponential function 'e**x' to double precision " accuracy in either BFP or HFP mode. " " Entry: through the appropriately named entry point with: " EAQ = the argument x. " PR2 = the address of a 8 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired exponential " " Uses: X0, X1, X2 " X0 = saves a return address from part_exp2 " X1 = index to the table 'two_to_the' " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. segref math_constants_,almost_one,hfp_almost_one,log_2_of_e,max_value equ BFP,0 equ HFP,2 equ iy,0 equ four_ry,2 equ z,2 equ zz,4 equ p,2 equ q_minus_p,6 equ result,6 equ x,0 bool bfp_exponent_of_log2_of_e,002000 bool hfp_exponent_of_log16_of_e,000000 bool M0.5H,001400 " yields HFP -0.5 under 'du' modification bool P1.0H,002040 " yields HFP +1.0 under 'du' modification bool P2.0H,002100 " yields HFP +2.0 under 'du' modification segdef double_exponential_,hfp_double_exponential_ double_exponential_: eax2 BFP " 2 word offset for BFP constants dfcmp lb " if x <= -89.4159862922329449148: tpnz 3,ic fld =0.0,du " result = 0 tra pr3|0 " return dfcmp ub " if x >= 88.0296919311130543 goto overflow_error tpl overflow_error dfst pr2|x ldaq bfp_mantissa_of_log2_of_e lde bfp_exponent_of_log2_of_e,du dfmp pr2|x fad =1.0,du " EAQ := y + 1 ufa =7b25,du " AQ := 8/floor(y+1),64/fraction part of y sta pr2|iy ora =o776000,du " AQ := 8/-1,64/fraction part of y lde =7b25,du " EAQ := ry = unnormalized y - floor(y+1) fad =0.0,du " EAQ := ry = normalized y - floor(y+1) dfcmp =-0.5d0 tmi 3,ic " if ry >= -0.5 tsx0 part_exp2 " then result = part_exp2 (ry) tra 4,ic " else fad =1.0,du " EAQ := ry + 1 tsx0 part_exp2 " EAQ := part_exp2 (ry + 1) fmp =0.5,du " result = 0.5*part_exp2 (ry + 1) ade pr2|iy " addr (result) -> expon = addr (result) -> expon + iy tra pr3|0 " return result in EAQ hfp_double_exponential_: eax2 HFP " 2 word offset for HFP constants dfcmp hfp_lb " if x <= -357.663945168931779659: tpnz 3,ic fld =0.0,du " result = 0 tra pr3|0 " return dfcmp hfp_ub " if x >= 352.1187677244522171839 goto overflow_error tpl overflow_error dfcmg hfp_eps " if abs (x) < 1.08420217248550443e-19: tpl 3,ic fld P1.0H,du " result = 1.0 tra pr3|0 " return dfst pr2|x ldaq hfp_mantissa_of_log16_of_e lde hfp_exponent_of_log16_of_e,du dfmp pr2|x fad P1.0H,du " EAQ := y + 1 fmp P2.0H,du ufa =2b25,du " AQ := 8/floor(y+1),64/fraction part of y sta pr2|iy ora =o776000,du " AQ := 8/-1,64/fraction part of y lde =2b25,du " EAQ := unnormalized 2*(y - floor(y+1)) fad =0.0,du " EAQ := 2*(y - floor(y+1)) fmp P2.0H,du " EAQ := 4*(y - floor(y+1)) dfst pr2|four_ry fad =0.5,du " EAQ := 4 * ry + 0.5 " The next four instructions truncate a floating point number in the EAQ " to an integer in the AQ in effect calculating s = floor (4 * ry + 0.5). dufa hfp_almost_one dufs hfp_almost_one ufm P2.0H,du ufa =18b25,du " AQ := s = floor (4*ry + 0.5) eax1 0,ql " X2 := s = floor (4*ry + 0.5) " The next two instructions will convert the current representation of s " to a floating point representation. fad =0.0,du fmp M0.5H,du " EAQ := -(s) dfad pr2|four_ry " EAQ := 4*ry - s tsx0 part_exp2 " result = part_exp2 (4*ry -s) fmp two_to_the,x1 " result = two_to_the (s) * part_exp2 (4*ry - s) ade pr2|iy " addr (result) -> expon = addr (result) -> expon + iy tra pr3|0 " return result in EAQ " The function part_exp2 calculates 2**z, given z in the range [-0.5, 0.5) " in the EAQ. part_exp2: fad =0.0,du " normalize z fcmg eps,x2 tpl 3,ic " if abs (z) < 1.56417309e-19: fld one,x2 " result = 1.0 tra 0,x0 " return dfstr pr2|z dfmp pr2|z " zz = z*z dfstr pr2|zz dfmp p2,x2 " calculate p = z*(p0 + zz*(p1 + zz*p2)) dfad p1,x2 dfmp pr2|zz dfad p0,x2 dfmp pr2|z dfstr pr2|p dfld pr2|zz " calculate q = q0 + zz*(q1 + zz*(q2 + zz)) dfad q2,x2 dfmp pr2|zz dfad q1,x2 dfmp pr2|zz dfad q0,x2 dfsb pr2|p " calculate q - p dfstr pr2|q_minus_p dfad pr2|p " restore q dfad pr2|p " calculate q + p dfdv pr2|q_minus_p " calculate result = (q + p) / (q - p) tra 0,x0 " return to caller overflow_error: dfld max_value dfad max_value " cause an overflow dfld max_value tra pr3|0 " return to caller even eps: dec 1.56417309d-19 oct 742134252166,000000000000 hfp_eps: oct 742100000427,165257035710 " 1.0842202172485504434d-19 bfp_mantissa_of_log2_of_e: oct 270524354512,701376056737 hfp_mantissa_of_log16_of_e: oct 134252166245,340577027370 one: dec 1.0d0 oct 002040000000,000000000000 p0: dec 2.0803843466946630014d6 oct 014077372002,614037317645 p1: dec 3.0286971697440362990d4 oct 010354473706,022472775644 p2: dec 6.0614853300610808416d1 oct 004171165470,152076602243 q0: dec 6.0027203602388325282d6 oct 014267140402,703423455073 q1: dec 3.2772515180829144230d5 oct 012240013223,334720774015 q2: dec 1.7492876890930764038d3 oct 006332522322,776034267264 ub: dec 8.80296919311130543d01 " 2**127 - 2**64 = e**88.0296919311130543 lb: dec -8.94159862922329449148d01 " 2**(-129) = e**-89.4159862922329449148 hfp_lb: oct 007723225403,660372147166 " 16**(-129) = e**-357.663945168931779659 hfp_ub: oct 006054007463,617610536654 " 16**127 - 16**64 = e**352.1187677244522171839 " Table of two_to_the oct 000040000000 " 0.0625 oct 000100000000 " 0.125 oct 000200000000 " 0.25 oct 000400000000 " 0.5 two_to_the: oct 002040000000 " 1.0 end  double_logarithm_.alm 11/11/89 1150.6rew 11/11/89 0805.3 59220 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name double_logarithm_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7nar'. " " Function: Calculates the logarithm functions log_base_e(x), log_base_2(x), " and log_base_10(x) to double precision accuracy in either BFP or " HFP mode. " " Entry: through the appropriately named entry point with: " EAQ = the argument x. " PR2 = the address of a 16 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired logarithm " " Uses: X0, X1, X2, X3 " X0 = saves a return address from call_math_error_ " or saves a return address from log2 " X1 = saves a return address from part_log2_of_ratio " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. " X3 = address of second argument for part_log2_of_ratio segref math_constants_,hfp_log_10_of_2,hfp_log_e_of_2,log_10_of_2,log_e_of_2,max_value equ BFP,0 equ HFP,2 equ xe,0 equ xm,2 equ bias,4 equ shift,6 equ x_plus_y,8 equ z,10 equ zz,12 equ zp,14 segdef double_log_base_10_,hfp_double_log_base_10_ segdef double_log_base_2_,hfp_double_log_base_2_ segdef double_log_base_e_,hfp_double_log_base_e_ double_log_base_10_: tsx0 log2 " calculate log2 (x) dfmp log_10_of_2 " EAQ := log_10_of_2 * log2 (x) dfrd 0 tra pr3|0 " return to caller double_log_base_2_: tsx0 log2 " calculate log2 (x) dfrd 0 tra pr3|0 " return to caller double_log_base_e_: tsx0 log2 " calculate log2 (x) dfmp log_e_of_2 " EAQ := log_e_of_2 * log2 (x) dfrd 0 tra pr3|0 " return to caller hfp_double_log_base_10_: tsx0 hfp_log2 " calculate log2 (x) dfmp hfp_log_10_of_2 " EAQ := hfp_log_10_of_2 * log2 (x) dfrd 0 tra pr3|0 " return to caller hfp_double_log_base_2_: tsx0 hfp_log2 " calculate log2 (x) dfrd 0 tra pr3|0 " return to caller hfp_double_log_base_e_: tsx0 hfp_log2 " calculate log2 (x) dfmp hfp_log_e_of_2 " EAQ := hfp_log_e_of_2 * log2 (x) dfrd 0 tra pr3|0 " return to caller log_of_negative: ldq 21,dl tsx0 |[call_math_error_] dfld max_value fneg 0 tra pr3|0 log_of_zero: ldq 20,dl tsx0 |[call_math_error_] dfld max_value fneg 0 tra pr3|0 log2: eax2 BFP " no offset for BFP constants fad =0.0,du " normalize input and set indicators tmi log_of_negative tze log_of_zero dfcmp square_root_two " check for x in the range [.707,1.414] tpl 6,ic dfcmp square_root_half tmi 4,ic " if square_root_half >= x & x <= square_root_two eax3 one " X3 := addr (1.0) eax1 0,x0 " copy return address tra part_log2_of_ratio " result = part_log2_of_ratio (x, 1) " else ste pr2|xe " store addr (x) -> expon in xe lde =0,du " addr (xm) -> expon = 0 dfst pr2|xm lda pr2|xe " A := 8/xe,10/0,18/garbage lrs 72-18 " AQ := 62/xe,10/0 lde =61b25,du " EAQ := unnormalized float(xe) fsb =0.5,du " EAQ := float(xe) - 0.5 fst pr2|bias dfld pr2|xm eax3 square_root_half " X3 := addr (square_root_half) tsx1 part_log2_of_ratio " EAQ := part_log2_of_ratio (x, square_root_half) fad pr2|bias " EAQ := part_log2_of_ratio (x, square_root_half) + bias (= log2(x)) tra 0,x0 " return result hfp_log2: eax2 HFP " 2 word offset for HFP constants fad =0.0,du " normalize input and set indicators tmi log_of_negative tze log_of_zero dfcmp hfp_square_root_two " check for x in the range [.707,1.414] tpl 6,ic dfcmp hfp_square_root_half tmi 4,ic " if square_root_half >= x & x <= square_root_two eax3 hfp_one " X3 := addr (1.0) eax1 0,x0 " copy return address tra part_log2_of_ratio " result = part_log2_of_ratio (x, 1) " else ste pr2|xe " store addr (x) -> expon in xe lde =0,du " addr (xm) -> expon = 0 " EAQ := xm stz pr2|shift " shift := 0 even do_while: " do while (xm < 0.5) dfcmp =0.5d0 tpl end_do_while lls 1 " xm = 2*xm aos pr2|shift " shift := shift + 1 tra do_while " end do_while end_do_while: dfst pr2|xm lda pr2|xe " A := 8/xe,10/0,18/garbage lrs 36-10 " AQ := 36/4*xe,8/0,28/garbage sba pr2|shift " AQ := 36/4*xe-shift,8/0,28/garbage lrs 29 " AQ := 65/4*xe-shift,7/0 lde =16b25,du " EAQ := unnormalized float(4*xe-shift) fsb =0.5,du " EAQ := float(4*xe-shift)-0.5 fst pr2|bias dfld pr2|xm eax3 hfp_square_root_half " X3 := addr (square_root_half) tsx1 part_log2_of_ratio " EAQ := part_log2_of_ratio (x, square_root_half) fad pr2|bias " EAQ := part_log2_of_ratio (x, square_root_half) + bias tra 0,x0 " return result " part_log2_of_ratio (x, y) calculates log2(x/y), where x/y is in the " range [0.5*2**0.5, 2**0.5], given x in the EAQ and the address of y in X3. part_log2_of_ratio: dfad 0,x3 " EAQ := x + y dfst pr2|x_plus_y dfsb 0,x3 " EAQ := x dfsb 0,x3 " EAQ := x - y dfdv pr2|x_plus_y " calculate z = (x - y) / (x + y) fcmg eps,x2 tpnz 4,ic " if abs(z) < 1.27420168d-11 dfmp p0,x2 " EAQ = z * p0 dfdv q0,x2 " EAQ = z * p0 / q0 tra 0,x1 " return to caller dfstr pr2|z dfmp pr2|z " calculate zz = z*z dfstr pr2|zz " calculate p(zz) dfmp p3,x2 dfad p2,x2 dfmp pr2|zz dfad p1,x2 dfmp pr2|zz dfad p0,x2 dfmp pr2|z " calculate z*p(zz) dfstr pr2|zp dfld pr2|zz " calculate q(zz) dfad q3,x2 dfmp pr2|zz dfad q2,x2 dfmp pr2|zz dfad q1,x2 dfmp pr2|zz dfad q0,x2 dfdi pr2|zp " calculate z*p(zz)/q(zz) tra 0,x1 " return to caller even eps: dec 1.27420168d-11 oct 756700243611,000000000000 one: dec 1.0d0 hfp_one: oct 002040000000,000000000000 p0: dec .51390458864923992069d03 oct 006100171711,437121505724 p1: dec -.79210250577344319906d03 oct 007634771341,056376644076 p2: dec .34070763364903118663d03 oct 006052455223,572450215316 p3: dec -.35419160305337449948d02 oct 005671122617,220231325351 q0: dec .17810575834951956203d03 oct 004544154227,652616712022 q1: dec -.33389039541217149928d03 oct 007726207007,413660334102 q2: dec .19375591463035879517d03 oct 004603406034,760376537401 q3: dec -.35526251110400238735d02 oct 005670745074,667153071771 square_root_half: dec 7.071067811865475244008d-01 hfp_square_root_half: oct 000552023631,477473631102 square_root_two: dec 1.414213562373095048801d+00 hfp_square_root_two: oct 002055202363,147747363110 end  double_principal_angle_.alm 11/11/89 1150.6rew 11/11/89 0805.3 62811 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** name double_principal_angle_ " Modification history: " Written by H. Hoover, M. Mabey and B. Wong, April 1985. " " Function: Scale an angle into the range -pi/4 to pi/4. " " Entry: through the appropriately named entry point with: " EAQ = input angle to be scaled. " X0 = the return address. " X2 = a two word offset for HFP constants - this register is used " by all of the floting point math_routines for the same thing. " PR2 = points to an even word aligned, 14 word long, scratch area. " " Exit: EAQ = the scaled angle. " X1 = mod ((input EAQ)/HALF_PI + 0.5), 4) " " Uses: X1 " X1 = used to return mod ((input EAQ)/HALF_PI + 0.5), 4) segdef double_principal_degrees_,double_principal_radians_ segref math_constants_,pi,half_pi,almost_one bool P2.0H,002100 " yields HFP +2.0 under 'du' modification bool P45.0H,004132 " yields HFP +45.0 under 'du' modification equ angle,0 equ temp,angle equ n1,2 equ n2,3 equ t1,4 equ t2,6 equ t3,8 equ t4,10 equ t5,12 equ HFP,2 double_principal_degrees_: cmpx2 HFP,du tze hfp_principal_degrees bfp_principal_degrees: dfrd 0 dfcmg two_pwr_54 " is the EAQ too large tpnz angle_too_big " Yup. dfst pr2|angle dfdv ninety " EAQ = EAQ/90 fad =0.5,du " EAQ = EAQ/90 + 0.5 dufa almost_one dufs almost_one ufa =71b25,du " AQ = EAQ/90 + 0.5 in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/90 + 0.5) in floating point form fmp =90.0,du " EAQ = floor(EAQ/90 + 0.5)*90 fneg 0 " EAQ = -floor(EAQ/90 + 0.5)*90 dfad pr2|angle " EAQ = angle-floor(EAQ/90 + 0.5)*180 tra 0,x0 " return to caller hfp_principal_degrees: dfrd 0 dfcmg hfp_two_pwr_48 " is the EAQ too large tpnz angle_too_big " Yup. dfst pr2|angle dfdv ninety,x2 " EAQ = EAQ/90 fad =0.5,du " EAQ = EAQ/90 + 0.5 dufa almost_one dufs almost_one ufm P2.0H,du ufa =18b25,du " AQ = EAQ/90 + 0.5 eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/90 + 0.5)*2 fmp P45.0H,du " EAQ = floor(EAQ/90 + 0.5)*90 in floating point form fneg 0 " EAQ = -floor(EAQ/90 + 0.5)*90 dfad pr2|angle " EAQ = angle-floor(EAQ/90 + 0.5)*90 tra 0,x0 " return to caller double_principal_radians_: cmpx2 HFP,du tze hfp_principal_radians bfp_principal_radians: dfrd 0 dfst pr2|angle dfcmg two_pwr_27 " is the EAQ too large tpnz bfp_big_angle " Yup. dfmp one_over_half_pi " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufa =71b25,du " AQ = EAQ/half_pi + 0.5 in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ tra small_angle_join " goto common code for HFP and BFP hfp_principal_radians: dfrd 0 dfst pr2|angle dfcmg hfp_two_pwr_24 " is the EAQ too large tpnz hfp_big_angle " Yup. dfmp one_over_half_pi,x2 " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufm P2.0H,du ufa =18b25,du " AQ = EAQ/half_pi + 0.5 in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/half_pi + 0.5)*2 fmp =0.5,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ small_angle_join: fmp half_pi1,x2 dfst pr2|t1 " t1 = n1*half_pi1 fld pr2|n1 fmp half_pi2,x2 dfst pr2|t2 " t2 = n1*half_pi2 fld pr2|n1 fmp half_pi3,x2 dfst pr2|t3 " t3 = n1*half_pi3 fld pr2|n1 fmp half_pi4,x2 dfst pr2|t4 " t4 = n1*half_pi4 fld pr2|n1 dfmp half_pi5,x2 dfst pr2|t5 " t5 = n1*half_pi5 dfld pr2|angle " answer = angle - t1 - t2 - t3 - t4 - t5 dfsb pr2|t1 dfsb pr2|t2 dfsb pr2|t3 dfsb pr2|t4 dfsb pr2|t5 tra 0,x0 hfp_big_angle: dfcmg hfp_two_pwr_48 " is the EAQ too large? tpnz angle_too_big " Yup. dfmp one_over_half_pi,x2 " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufm P2.0H,du ufa =18b25,du " AQ = EAQ/half_pi + 0.5 in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/half_pi + 0.5)*2 fmp =0.5,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ tra big_angle_join bfp_big_angle: dfcmg two_pwr_54 " is the EAQ too large? tpnz angle_too_big " Yup. dfmp one_over_half_pi " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufa =71b25,du " AQ = EAQ/half_pi + 0.5 in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ big_angle_join: fsb pr2|n1 fst pr2|n2 " n2 = n - n1 fld pr2|n1 fmp half_pi1,x2 dfst pr2|t1 " t1 = n1*half_pi1 fld pr2|n1 " calculate n1*half_pi2 + n2*half_pi1 fmp half_pi2,x2 dfst pr2|t2 fld pr2|n2 fmp half_pi1,x2 dfad pr2|t2 dfst pr2|t2 " t2 = (n1*half_pi2 + n2*half_pi1) fld pr2|n1 " calculate n1*half_pi3 + n2*half_pi2 fmp half_pi3,x2 dfst pr2|t3 fld pr2|n2 fmp half_pi2,x2 dfad pr2|t3 dfst pr2|t3 " t3 = (n1*half_pi3 + n2*half_pi2) fld pr2|n1 " calculate n1*half_pi4 + n2*half_pi3 fmp half_pi4,x2 dfst pr2|t4 fld pr2|n2 fmp half_pi3,x2 dfad pr2|t4 dfst pr2|t4 " t4 = (n1*half_pi4 + n2*half_pi3) fld pr2|n1 " calculate n1*half_pi5 + n2*half_pi4 dfmp half_pi5,x2 dfst pr2|t5 fld pr2|n2 fmp half_pi4,x2 dfad pr2|t5 dfst pr2|t5 " t5 = (n1*half_pi5 + n2*half_pi4) dfld pr2|angle " answer = angle - t1 - t2 - t3 - t4 - t5 dfsb pr2|t1 dfsb pr2|t2 dfsb pr2|t3 dfsb pr2|t4 dfsb pr2|t5 tra 0,x0 " return to caller. The indicators are set. angle_too_big: ldq code,x2 " load the error code stx0 pr2|temp " save X0 tsx0 |[call_math_error_] ldx0 pr2|temp " restore X0 eax1 0 " X1 = 0 fld =0.0,du " EAQ = 0, set indicators tra 0,x0 " return to caller " Constants: even ninety: dec 90.0d0 oct 004264000000,000000000000 one_over_half_pi: dec 6.3661977236758134307553d-1 oct 000505746033,344710405225 hfp_two_pwr_24: oct 016040000000,000000000000 two_pwr_27: oct 070400000000,000000000000 hfp_two_pwr_48: oct 032040000000,000000000000 two_pwr_54: oct 156400000000,000000000000 oct 034200000000,000000000000 half_pi1: oct 002622077325,000000000000 oct 002062207732,000000000000 half_pi2: oct 706420550604,000000000000 oct 766050420550,000000000000 half_pi3: oct 616646114314,000000000000 oct 752060432304,000000000000 half_pi4: oct 526505600670,000000000000 oct 736061461213,000000000000 half_pi5: oct 434715045101,000000000000 oct 722040156034,642244022341 code: dec 72,0,73 end  double_sine_.alm 11/11/89 1150.6rew 11/11/89 0805.3 56736 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name double_sine_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on the GCOS routine '7nat'. " " Function: Approximate to double precision the sine or cosine of an " angle given in degrees or radians. " " Entry: through the appropriately named entry point with: " EAQ = the angle whose sine or cosine is desired. " PR2 = the address of a 14 word, even-word aligned scratch area. " 4 words are used in this program and 14 are used by the " routine "double_principal_angle_". The storage for " double_sine_ and double_principal_angle_ overlap. " PR3 = the return address. " " Exit: EAQ = the desired sine or cosine. " " Uses: X0, X1, X2. " X0 = saves a return address from double_principal_angle_ routines " X1 = shift (returned by double_principal_angle_ routines) " X2 = indicates BFP or HFP mode - all of the floating point math " math routines use this register for the same thing. " The double_principal_angle_ routines use registers X1 and X2. segref math_constants_,half_pi,one_degree,pi segref double_principal_angle_,double_principal_radians_,double_principal_degrees_ equ BFP,0 equ HFP,2 equ x,0 equ xx,2 segdef double_cosine_degrees_,hfp_double_cosine_degrees_ segdef double_cosine_radians_,hfp_double_cosine_radians_ segdef double_sine_degrees_,hfp_double_sine_degrees_ segdef double_sine_radians_,hfp_double_sine_radians_ hfp_double_cosine_degrees_: eax2 HFP " 2 word offset for HFP constants tra double_cosine_degrees double_cosine_degrees_: eax2 BFP " no offset for BFP constants double_cosine_degrees: fad =0.0,du " normalize input dfcmg one_eighty,x2 " if abs_angle <= 180: tmi case1_degrees " then no angle reduction is necessary tsx0 double_principal_degrees_ tra case_degrees+1,x1 " select appropriate case hfp_double_cosine_radians_: eax2 HFP " 2 word offset for HFP constants tra double_cosine_radians double_cosine_radians_: eax2 BFP " no offset for BFP constants double_cosine_radians: fad =0.0,du " normalize input and set indicators dfcmg pi,x2 " if abs (angle) <= pi tmi case1_radians " then no angle reduction is necessary tsx0 double_principal_radians_ tra case_radians+1,x1 " select appropriate case hfp_double_sine_degrees_: eax2 HFP " 2 word offset for HFP constants tra double_sine_degrees double_sine_degrees_: eax2 BFP " no offset for BFP constants double_sine_degrees: fad =0.0,du " normalize input dfcmg ninety,x2 " if abs (angle) < pi/2 tmi case0_degrees " then no angle reduction is necessary tsx0 double_principal_degrees_ tra case_degrees,x1 " select appropriate case hfp_double_sine_radians_: eax2 HFP " 2 word offset for HFP constants tra double_sine_radians double_sine_radians_: eax2 BFP " no offset for BFP constants double_sine_radians: fad =0.0,du " normalize input dfcmg half_pi,x2 " if abs (angle) <= pi/2 tmoz case0_radians " then no angle reduction is necessary tsx0 double_principal_radians_ tra case_radians,x1 " Case select appropriate case_radians case_radians: tra case0_radians tra case1_radians tra case2_radians tra case3_radians tra case0_radians case1_radians: fad =0.0,du " set indicators tmi 2,ic " EAQ = - abs (EAQ) negl 0 " fneg underflows at o400400000000 dfad half_pi1,x2 dfad half_pi2,x2 tra part_sine_radians case2_radians: fneg 0 tra part_sine_radians case3_radians: fad =0.0,du " set indicators tpl 2,ic " EAQ = abs (EAQ) fneg 0 dfsb half_pi1,x2 dfsb half_pi2,x2 tra part_sine_radians case_degrees: tra case0_degrees tra case1_degrees tra case2_degrees tra case3_degrees tra case0_degrees case1_degrees: fad =0.0,du " set indicators tmi 2,ic " EAQ = - abs (EAQ) negl 0 " fneg underflows at o400400000000 fad ninety,x2 tra part_sine_degrees case2_degrees: fneg 0 tra part_sine_degrees case3_degrees: fad =0.0,du " set indicators tpl 2,ic " EAQ = abs (EAQ) fneg fsb ninety,x2 " tra part_sine_degrees case0_degrees: " case0_degrees is just part_sine_degrees part_sine_degrees: dfcmg eps2,x2 " if conversion to radians underflows tpl 2,ic fld =0.0,du " then use zero dfmp one_degree,x2 " convert to radians. " tra part_sine_radians case0_radians: " case0_radians is just part_sine_radians " Procedure part_sine (x) calculates 'sin(x)' for 'x' in the range " [-pi/2, pi/2] given 'x' in the EAQ. part_sine_radians: dfrd 0 dfcmg eps3,x2 "if abs (x) < 5e-10: tmi pr3|0 " sine is x for small x dfst pr2|x dfmp pr2|x " calculate xx = x*x dfstr pr2|xx dfmp p9,x2 " calculate p(xx) dfad p8,x2 dfmp pr2|xx dfad p7,x2 dfmp pr2|xx dfad p6,x2 dfmp pr2|xx dfad p5,x2 dfmp pr2|xx dfad p4,x2 dfmp pr2|xx dfad p3,x2 dfmp pr2|xx dfad p2,x2 dfmp pr2|xx dfad p1,x2 dfmp pr2|xx fad p0,x2 dfmp pr2|x " return x*p(xx) dfrd 0 tra pr3|0 " Constants: even eps1: dec 1.886591d-8 oct 764242035115,000000000000 eps2: dec 8.418858142948452884d-38 oct 402162456701,514360373670 " 2.670821537926801391d-154 eps3: dec 5.0d-10 oct 762104560276,404665512263 half_pi1: oct 002622077325,042055060432 " 1.570796326794896619d0 oct 002062207732,504205506043 " 1.570796326794896619d0 half_pi2: oct 602611431424,270033407150 " 8.333742918520878328d-20 oct 742461143142,427003340714 " 5.170182981794105568d-19 ninety: dec 90.0d0 oct 004264000000,000000000000 one_eighty: dec 180.0d0 oct 004550000000,000000000000 p0: dec 9.9999999999999999998d-1 " this rounds to 1.0d0 oct 002040000000,000000000000 p1: dec -1.6666666666666666664d-1 oct 001652525252,525252525253 p2: dec 8.333333333333332952d-3 oct 776104210421,042104210331 p3: dec -1.9841269841269648946d-4 oct 773137713771,377140131713 p4: dec 2.7557319223936401884d-6 oct 770134357072,252646307133 p5: dec -2.5052108378101760587d-8 oct 765450633523,013112232534 p6: dec 1.60590431721336921d-10 oct 760541110601,052315030325 p7: dec -7.647126379076958d-13 oct 755121402455,333370604367 p8: dec 2.8101852815318d-15 oct 750624773046,213725310300 p9: dec -7.9798971356d-18 oct 745331460002,411662206514 end  double_square_root_.alm 11/11/89 1150.6rew 11/11/89 0805.3 38835 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name double_square_root_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7nau'. " " Function: Approximate to double precision the square root of a number. " " Entry: through the appropriately named entry point with: " EAQ = the number whose square root is desired. " PR2 = the address of an 8 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired square root. " " Uses: X0, X1 " X0 = temporary storage for exponent of input argument " and saves a return address from call_math_error_ " X1 = index to scale table equ root_m,0 equ x,2 equ m,4 equ e,6 bool P4.0H,002200 " yields HFP +4.0 under 'du' modification segdef double_square_root_,hfp_double_square_root_ hfp_double_square_root_: fad =0.0,du " normalize input arg tze pr3|0 " if x = 0 return (0) tpl hfp_calc_square_root " if x < 0: fneg 0 " x = -x dfst pr2|x ldq 22,dl tsx0 |[call_math_error_] dfld pr2|x hfp_calc_square_root: dfst pr2|x " store EAQ := input arg ldx0 pr2|x " X0 := addr (x) -> expon " m = x lde =0b25,du " addr (m) -> expon = 0 eax1 0 " scale = 0.5 dfcmp one_quarter tpl 3,ic " if m >= .25: scale = 0.5 eax1 2 " else: scale = 0.25 fmp P4.0H,du " EAQ := m = 4*m canx0 =1b25,du " calculate mod (e, 2) tze 2,ic " if mod (e, 2) = 1: adx1 =1,du " scale = 0.25*scale dfst pr2|m " store EAQ := m ldq pr2|x " Q := 8/expon,28/garbage qrs 28 " Q := 28/0,8/expon adq =1,dl " calculate e+1 qrs 1 " calculate divide (e+1, 2, 7) qls 28 " position result in exponent field stq pr2|e " store Q := e = divide (e+1, 2, 7) dfld pr2|m fmp hfp_p2 " calculate root_m_top = p(m) fad hfp_p1 fmp pr2|m fad hfp_p0 fst pr2|root_m fdi pr2|m " calculate root_m = .5 * (root_m_top + m_top/root_m_top) fad pr2|root_m fmp =0.5,du dfrd 0 dfst pr2|root_m dfdi pr2|m " calculate root_m = .5 * (root_m + m/root_m) dfad pr2|root_m fmp =0.5,du dfrd 0 dfst pr2|root_m " calculate root_m + m/root_m dfdi pr2|m dfad pr2|root_m fmp scale,x1 " root_m = scale * (root_m + float (m, 63)/root_m) " root_x = root_m ade pr2|e " calculate addr (root_x) -> expon = " addr (root_x) -> expon + divide (e+1, 2, 7) dfrd 0 tra pr3|0 " return (root_x) double_square_root_: fad =0.0,du " normalize input arg tze pr3|0 " if x = 0 return (0) tpl calc_square_root " if x < 0: fneg 0 " x = -x dfst pr2|x ldq 22,dl tsx0 |[call_math_error_] dfld pr2|x calc_square_root: dfst pr2|x " store EAQ := input arg ldx0 pr2|x " X0 := addr (x) -> expon " m = x lde =0b25,du " addr (m) -> expon = 0 canx0 =1b25,du " calculate mod (e, 2) tze 2,ic " if mod (e, 2) = 1: lde =-1b25,du " EAQ := m = .5*m dfst pr2|m " store EAQ := m ldq pr2|x " Q := 8/expon,28/garbage qrs 28 " Q := 28/0,8/expon adq =1,dl " calculate e+1 qrs 1 " calculate divide (e+1, 2, 7) qls 28 " position result in exponent field stq pr2|e " store Q := e = divide (e+1, 2, 7) dfld pr2|m fmp p2 " calculate root_m_top = p(m) fad p1 fmp pr2|m fad p0 fst pr2|root_m fdi pr2|m " calculate root_m = .5 * (root_m_top + m_top/root_m_top) fad pr2|root_m fmp =0.5,du dfrd 0 dfst pr2|root_m dfdi pr2|m " calculate root_m = .5 * (root_m + m/root_m) dfad pr2|root_m fmp =0.5,du dfrd 0 dfst pr2|root_m " calculate root_m + m/root_m dfdi pr2|m dfad pr2|root_m ade =-1b25,du " root_m = .5 * (root_m + float (m, 63)/root_m) " root_x = root_m ade pr2|e " calculate addr (root_x) -> expon = " addr (root_x) -> expon + divide (e+1, 2, 7) dfrd 0 tra pr3|0 " return (root_x) even one_quarter: oct 000200000000,000000000000 " 0.25 p0: dec 2.5927688d-1 hfp_p0: oct 000204577702,000000000000 p1: dec 1.0521212d0 hfp_p1: oct 002041525750,000000000000 p2: dec -3.1632214d-1 hfp_p2: oct 001536026031,000000000000 scale: oct 000400000000 " 0.5 oct 000100000000 " 0.25*0.5 = 0.125 oct 000200000000 " 0.25 oct 000040000000 " 0.25*0.25 = 0.0625 end  double_tangent_.alm 11/11/89 1150.6rew 11/11/89 0805.3 66978 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name double_tangent_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7nav'. " " Function: Approximate to double precision the tangent or cotangent of an " angle given in degrees or radians. " " Entry: through the appropriately named entry point with: " EAQ = the angle whose tangent is desired. " PR2 = the address of a 14 word, even-word aligned scratch area. " 6 words are used in this program and 14 are used by the " routine "double_principal_angle_". The storage for " double_tangent_ and double_principal_angle_ overlap. " PR3 = the return address. " " Exit: EAQ = the desired tangent or cotangent. " " Uses: X0, X1, X2, X3. " X0 = saves a return address from double_principal_angle_ routines " X1 = shift (returned by double_principal_angle_ routines) " X2 = indicates BFP or HFP mode - all of the floating point math " routines use this register for the same thing. " X3 = indicates Tangent or Cotangent function " The double_principal_angle_ routines use registers X1 and X2. segref math_constants_,max_value,one_degree,quarter_pi segref double_principal_angle_,double_principal_radians_,double_principal_degrees_ equ BFP,0 equ HFP,2 equ Cotangent,-1 equ Tangent,1 equ sign,0 equ x,0 equ xx,2 equ q,4 segdef double_cotangent_degrees_,hfp_double_cotangent_degrees_ segdef double_cotangent_radians_,hfp_double_cotangent_radians_ segdef double_tangent_degrees_,hfp_double_tangent_degrees_ segdef double_tangent_radians_,hfp_double_tangent_radians_ hfp_double_cotangent_degrees_: eax2 HFP " 2 word offset for HFP constants tra cotangent_degrees double_cotangent_degrees_: eax2 BFP " no offset for BFP constants cotangent_degrees: fad =0.0,du " normalize input eax1 0 " initialize X1 := shift = 1 dfcmg forty_five,x2 tmoz 2,ic " if abs (angle) > 45: " call double_principal_degrees_ tsx0 double_principal_degrees_ dfcmg eps1,x2 " if conversion to radians underflows tmi infinity " return (infinity (degrees)) " else: dfmp one_degree,x2 " EAQ := degrees * one_degree canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Cotangent " X3 := Cotangent tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, degrees*one_degree)) " else if shift = 1 | shift = 3 eax3 Tangent " X3 := Cotangent fneg 0 " EAQ := -degrees*one_degree tra part_tan_or_cot " return (part_tan_or_cot (Tangent, -(degrees*one_degree))) hfp_double_cotangent_radians_: eax2 HFP " 2 word offset for HFP constants tra cotangent_radians double_cotangent_radians_: eax2 BFP " no offset for BFP constants cotangent_radians: fad =0.0,du " normalize input dfcmg quarter_pi,x2 tpl 3,ic " if abs (angle) > quarter_pi: eax3 Cotangent " X3 := Cotangent tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, radians) " call double_principal_radians_ tsx0 double_principal_radians_ canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Cotangent " X3 := Cotangent tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, radians)) " else if shift = 1 | shift = 3 eax3 Tangent " X3 := Cotangent fneg 0 " EAQ := -radians tra part_tan_or_cot " return (part_tan_or_cot (Tangent, -radians)) hfp_double_tangent_degrees_: eax2 HFP " 2 word offset for HFP constants tra tangent_degrees double_tangent_degrees_: eax2 BFP " no offset for BFP constants tangent_degrees: fad =0.0,du " normalize input eax1 0 " initialize X1 := shift = 1 dfcmg forty_five,x2 tmoz 2,ic " if abs (angle) > 45: " call double_principal_degrees_ tsx0 double_principal_degrees_ dfcmg eps1,x2 " if conversion to radians underflows tpl 2,ic fld =0.0,du " then use zero " else: dfmp one_degree,x2 " EAQ := degrees * one_degree canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Tangent " X3 := Tangent tra part_tan_or_cot " return (part_tan_or_cot (Tangent, degrees*one_degree)) " else if shift = 1 | shift = 3 eax3 Cotangent " X3 := Cotangent fneg 0 " EAQ := -radians tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, -(degrees*one_degree))) hfp_double_tangent_radians_: eax2 HFP " 2 word offset for HFP constants tra tangent_radians double_tangent_radians_: eax2 BFP " no offset for BFP constants tangent_radians: fad =0.0,du " normalize input dfcmg quarter_pi,x2 tpl 3,ic " if abs (angle) <= quarter_pi: eax3 Tangent tra part_tan_or_cot " return (part_tan_or_cot (Tangent, radians)) " call double_principal_radians_ tsx0 double_principal_radians_ canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Tangent " X3 := Tangent tra part_tan_or_cot " return (part_tan_or_cot (Tangent, radians)) " else if shift = 1 | shift = 3 eax3 Cotangent " X3 := Cotangent fneg 0 " EAQ := -radians " tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, -radians)) " Procedure 'part_tan_or_cot' (function, x) calculates either 'tan(x)' " or 'cot(x)' to double precision accuracy, for 'x' in [-pi/4, pi/4]. " Argument 'x' is given in the EAQ and the function to be calculated is " given in X3. X3=-1 indicates 'cot' and X3=1 indicates 'tan'. part_tan_or_cot: fcmg eps2 " if abs(x) < 5e-10: tpl use_polynomial cmpx3 Tangent,du " if function = Tangent tnz 3,ic dfrd 0 " then return (result) tra pr3|0 dfcmg eps3,x2 " else if 1/result overflows tmoz infinity " then return (infinity (result)) dfdi one,x2 " else return (1/result) tra pr3|0 use_polynomial: dfstr pr2|x dfmp pr2|x " calculate xx = x*x dfstr pr2|xx dfad q3,x2 " calculate q = q(xx) dfmp pr2|xx dfad q2,x2 dfmp pr2|xx dfad q1,x2 dfmp pr2|xx dfad q0,x2 dfstr pr2|q dfld pr2|xx " calculate p(xx) dfmp p4,x2 dfad p3,x2 dfmp pr2|xx dfad p2,x2 dfmp pr2|xx dfad p1,x2 dfmp pr2|xx dfad p0,x2 dfmp pr2|x " calculate p = x*p(xx) cmpx3 Tangent,du tnz 3,ic " if function = Tangent dfdv pr2|q " then return (p/q) tra pr3|0 dfdi pr2|q " else return (q/p) tra pr3|0 infinity: fst pr2|sign fld max_value fad max_value " signal overflow dfld max_value fszn pr2|sign " if sign >= 0 tpl pr3|0 " then return (max_value) fneg 0 " else return (-max_value) tra pr3|0 " Constants: even eps1: dec 8.418858142948452884d-38 oct 402162456701,514360373670 " 2.670821537926801391d-154 eps2: dec 5.0d-10 oct 762104560277,000000000000 eps3: oct 404400000000,000000000001 oct 404040000000,000000000001 forty_five: dec 45.0d0 oct 004132000000,000000000000 one: dec 1.d0 oct 002040000000,000000000000 p0: dec 7.61637646334745151d5 oct 012563711322,566143202611 p1: dec -1.045644297708972282d5 oct 013714742710,772421516417 p2: dec 2.990139654186652781d3 oct 006565610740,140350661251 p3: dec -2.195407375452258719d1 oct 005724057016,450513240522 p4: dec 2.229548191006262686d-2 oct 776266512016,646767353442 q0: dec 7.61637646334745151d5 oct 012563711322,566143202611 q1: dec -3.584436452158122785d5 oct 013520765055,323105715467 q2: dec 2.091966854815805879d4 oct 010243336531,137433252357 q3: dec -3.069448235422934591d2 oct 007731503420,013262557251 end  exponential_.alm 11/11/89 1150.6rew 11/11/89 0805.5 44658 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name exponential_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7naz'. " " Function: Calculates the exponential function 'e**x' to single precision " accuracy in either BFP or HFP mode. " " Entry: through the appropriately named entry point with: " EAQ = the argument x. " PR2 = the address of a 4 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired exponential " " Uses: X0 " X0 = index to the table "scale" segref math_constants_,almost_one,hfp_almost_one,log_2_of_e,max_value equ iy,0 equ z,2 bool M0.5H,001400 " yields HFP -0.5 under 'du' modification bool P1.0H,002040 " yields HFP +1.0 under 'du' modification bool P2.0H,002100 " yields HFP +2.0 under 'du' modification segdef exponential_,hfp_exponential_ exponential_: fcmp lb " if x <= -89.415987: tpnz 3,ic fld =0.0,du " result = 0 tra pr3|0 " return fcmp ub " if x >= 88.0296926 goto overflow_error tpl overflow_error dfmp log_2_of_e " y = x*log_2_of_e fad =1.0,du " EAQ := y + 1 ufa =7b25,du " AQ := 8/floor(y+1),64/fraction part of y sta pr2|iy ora =o776000,du " AQ := 8/-1,64/fraction part of y lde =7b25,du " EAQ := ry = unnormalized y - floor(y+1) fad =0.0,du " EAQ := ry = normalized y - floor(y+1) " result = part_exp2 (ry) " The function part_exp2 calculates 2**z, given z in the range [-1, 0) " in the EAQ. part_exp2: fcmg eps tpl 3,ic " if abs (z) < 1.56417309e-19: fld =1.0,du " result = 1.0 tra pr3|0 " return frd 0 fst pr2|z fmp p7 " result = p(z) dfad p6 fmp pr2|z dfad p5 fmp pr2|z dfad p4 fmp pr2|z dfad p3 fmp pr2|z dfad p2 fmp pr2|z dfad p1 fmp pr2|z dfad p0 ade pr2|iy " addr (result) -> expon = addr (result) -> expon + iy tra pr3|0 " return result in EAQ hfp_exponential_: fcmp hfp_lb " if x <= -357.6639451: tpnz 3,ic fld =0.0,du " result = 0 tra pr3|0 " return fcmp hfp_ub " if x >= 352.1187677 goto overflow_error tpl overflow_error fcmg hfp_eps " if abs (x) < 1.0842021e-19: tpl 3,ic fld P1.0H,du " result = 1.0 tra pr3|0 " return dfmp hfp_log_16_of_e " y = x*log_16_of_e fad P1.0H,du " EAQ := y + 1 fmp P2.0H,du ufa =2b25,du " AQ := 8/floor(y+1),64/fraction part of y sta pr2|iy ora =o776000,du " AQ := 8/-1,64/fraction part of y lde =2b25,du " EAQ := unnormalized 2*(y - floor(y+1)) fad =0.0,du " EAQ := 2*(y - floor(y+1)) fmp P2.0H,du " EAQ := ry = 4*(y - floor(y+1)) eax0 0 " scale = 1.0 even do_while_ry_less_than_neg_one: dfcmp =-1.0d0 " do while ry < -1.0: tpl hfp_part_exp2 adx0 =1,du " scale = 0.5*scale fad P1.0H,du " ry = ry + 1 tra do_while_ry_less_than_neg_one " result = part_exp2 (ry) " The function hfp_part_exp2 calculates 2**z, given z in the range [-1, 0) " in the EAQ. hfp_part_exp2: fcmg hfp_eps1 tpl 3,ic " if abs (z) < 1.56417309e-19: fld P1.0H,du " result = 1.0 tra pr3|0 " return frd 0 fst pr2|z fmp hfp_p7 " result = p(z) dfad hfp_p6 fmp pr2|z dfad hfp_p5 fmp pr2|z dfad hfp_p4 fmp pr2|z dfad hfp_p3 fmp pr2|z dfad hfp_p2 fmp pr2|z dfad hfp_p1 fmp pr2|z dfad hfp_p0 fmp scale,x0 " result = scale * part_exp2 (ry) ade pr2|iy " addr (result) -> expon = addr (result) -> expon + iy tra pr3|0 " return result in EAQ overflow_error: fld max_value fad max_value " cause an overflow fld max_value tra pr3|0 " return to caller even eps: dec 1.56417309d-19 hfp_eps: oct 742100000427,000000000000 " 1.08422022d-19 hfp_eps1: oct 742134252166,000000000000 " 1.56417309d-19 hfp_log_16_of_e: oct 000270524354,512701376057 " log_16_of_e = 0.36067376022224085183998d0 p0: dec 0.999999999959788989221d00 hfp_p0: oct 000777777777,775171146650 p1: dec 0.693147175773076184335d00 hfp_p1: oct 000542710277,064122746306 p2: dec 0.240226411617528907564d00 hfp_p2: oct 000172775723,130414032243 p3: dec 0.555033746338694398430d-01 hfp_p3: oct 776706536015,336576334575 p4: dec 0.961531912935043645900d-02 hfp_p4: oct 776116611444,463376701613 p5: dec 0.132743818109838796600d-02 hfp_p5: oct 774255772674,464260106540 p6: dec 0.147007243118869978000d-03 hfp_p6: oct 772464227646,455135010071 p7: dec 0.107493818486964670000d-04 hfp_p7: oct 770550540762,530201244720 ub: dec 8.802969265d01 " 2**127 - 2**100 = e**88.0296926 lb: dec -8.9415987d01 " 2**(-129) = e**-89.415987 hfp_ub: oct 006054007464,000000000000 " 16**127 - 16**100 = e**352.1187677 hfp_lb: oct 007723225403,000000000000 " 16**(-129) = e**-357.6639541 scale: oct 002040000000 " 1 oct 000400000000 " 0.5 oct 000200000000 " 0.25 oct 000100000000 " 0.125 oct 000040000000 " 0.0625 end  find_bit_.alm 11/11/89 1150.6rew 11/11/89 0805.2 305811 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1986 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-05-08,GDixon), approve(86-05-16,MCR7357), " audit(86-07-10,Farley), install(86-07-17,MR12.0-1097): " Created find_bit_ subroutine. " END HISTORY COMMENTS " * * * * * * * * * * * * * * ** * * * * * * * * * * * " " Name: find_bit_ " " This subroutine uses the EIS compare bit (CMPB) and test character and " translate (TCT) instructions to search for an on or off bit in a bit string. " The bit index of the first bit found in the desired state is returned. " Searching is performed either from the left (beginning) or from the " right-hand side (end) of the string. The code uses a pre-defined " test/translate table for the TCT portion of the scanning. " " Entry: find_bit_$first_on " " Function: This entrypoint returns the index (bit position) of the first " (leftmost) bit which is on ("1"b) in a bit string. " " Syntax: " dcl find_bit_$first_on entry (bit(*)) returns (fixed bin(24)) reducible; " index = find_bit_$first_on (bit_string); " " Arguments: " bit_string " is the bit string to be examined. (In) " index " is the bit position of the first "1"b bit within the bit string. If no " "1"b bits are found, then 0 is returned. (Out) " " Entry: find_bit_$first_off " " Function: This entrypoint returns the index (bit position) of the first " (leftmost) bit which is off ("0"b) in a bit string. " " Syntax: " dcl find_bit_$first_off entry (bit(*)) returns (fixed bin(24)) reducible; " index = find_bit_$first_off (bit_string); " " Arguments: " bit_string " is the bit string to be examined. (In) " index " is the bit position of the first "0"b bit within the bit string. If no " "0"b bits are found, then 0 is returned. (Out) " " Entry: find_bit_$last_on " " Function: This entrypoint returns the index (bit position) of the last " (rightmost) bit which is on ("1"b) in a bit string. " " Syntax: " dcl find_bit_$last_on entry (bit(*)) returns (fixed bin(24)) reducible; " index = find_bit_$last_on (bit_string); " " Arguments: " bit_string " is the bit string to be examined. (In) " index " is the bit position of the last "1"b bit within the bit string. If no " "1"b bits are found, then 0 is returned. (Out) " " Entry: find_bit_$last_off " " Function: This entrypoint returns the index (bit position) of the last " (rightmost) bit which is on ("0"b) in a bit string. " " Syntax: " dcl find_bit_$last_on entry (bit(*)) returns (fixed bin(24)) reducible; " index = find_bit_$last_off (bit_string); " " Arguments: " bit_string " is the bit string to be examined. (In) " index " is the bit position of the last "0"b bit within the bit string. If no " "0"b bits are found, then 0 is returned. (Out) " " * * * * * * * * * * * * * * ** * * * * * * * * * * * include its " ----------------------------------------------------------------------------- " Segname definitions: " ----------------------------------------------------------------------------- name find_bit_ segdef first_on segdef first_off segdef last_on segdef last_off " ----------------------------------------------------------------------------- " Data Values and Register name assignments: " ----------------------------------------------------------------------------- equ arg_list,0 " pr0 -> argument list equ bit_string,1 " pr1 -> bit_string equ index,2 " pr2 -> result (after return) equ bit_length,2 " pr2 -> length(bit_string) " (before return) equ byte_str,3 " pr3 -> 1st full byte of bit_string equ table,4 " pr4 -> tct table equ test_bit,5 " pr5 -> type of bit we are looking " for (either on or off) equ direction,0 " x0 = entrypoint indicator. equ FIRST,0 " find first desired bit equ LAST,1 " find last desired bit equ bits_prior_1st_byte,1 " x1 = bits prior to first full byte " of bit_string. equ bits_after_Nth_byte,2 " x2 = bits after last full byte " of bit_string. equ do_index,3 " x3 = a do group index. equ table_char,4 " x4 = tctr translated result char. equ BITS_PER_BYTE,9 even " Selected bit values: on_bit: " on bit ("1"b), one of the possible oct 400000000000 " values we can search for. off_bit: " off bit ("0"b), the other possible oct 000000000000 " value we can search for. desc_length_mask: " ANDing mask to extract char string oct 000077777777 " length from an argument descriptor. string_index_mask: " ANDing mask to extract char offset oct 000777777777 " from result of TCT instruction. " ----------------------------------------------------------------------------- " Code for find_bit_$(first last)_(on off): " Setup entrypoint indicator, table pointer, and test bit pointer. " " Out: pr(table) -> TCT test/translate table for selecting first/last " on/off bit from a string of full bytes. " pr(test_bit) -> type of bit we are looking for (on or off). " x(direction) = choice of first/last, based upon entrypoint. " " ----------------------------------------------------------------------------- " first_on: entry (bit_string) returns(index); " ----------------------------------------------------------------------------- first_on: ldx direction,FIRST,du epp table,first_on_bit_table epp test_bit,on_bit tra common " ----------------------------------------------------------------------------- " first_off: entry (bit_string) returns(index); " ----------------------------------------------------------------------------- first_off: ldx direction,FIRST,du epp table,first_off_bit_table epp test_bit,off_bit tra common " ----------------------------------------------------------------------------- " last_on: entry (bit_string) returns(index); " ----------------------------------------------------------------------------- last_on: ldx direction,LAST,du epp table,last_on_bit_table epp test_bit,on_bit tra common " ----------------------------------------------------------------------------- " last_off: entry (bit_string) returns(index); " ----------------------------------------------------------------------------- last_off: ldx direction,LAST,du epp table,last_off_bit_table epp test_bit,off_bit tra common " ----------------------------------------------------------------------------- " Get address of input and output parm. " In: pr(arg_list) -> the argument list. " Out: pr(bit_string) -> bit string to be searched (input parm). " pr(index) -> bit index within string (output parm). " ----------------------------------------------------------------------------- common: epp bit_string,arg_list|2,* " get addr(bit_string). epp index,arg_list|4,* " get addr(index). " ----------------------------------------------------------------------------- " Since the TCT instruction is byte-oriented, we must special-case bits which " precede the first full byte, and which follow the last full byte of " bit_string. Compute number of bits which precede the first full byte of the " bit_string. " In: pr(bit_string) -> bit string to be searched. " Out: x(bits_prior_1st_byte) = bits preceding first full byte of bit_string " ----------------------------------------------------------------------------- ldx bits_prior_1st_byte,0,du epaq bit_string|0 " get bit offset of addr(bit_string) anq its.bit_offset_mask,dl " QL now contains bit offset div BITS_PER_BYTE,dl " test if bit_string is byte_aligned cmpa 0,dl " mod(bit_offset,9) = 0? tze get_length " yes. There are no bits before byte neg ada BITS_PER_BYTE,dl eax bits_prior_1st_byte,0,al " number of bits in bit_string which " precede the first full byte. " ----------------------------------------------------------------------------- " Get length (bit_string). Because we don't want to pay the expense of pushing " a stack frame, this program writes in only one word of memory, its output " argument (index). length(bit_string) will be saved temporarily in index. " " NB: bit_length and index are two names for the same pointer register " (pr2). When the location pointed by pr2 contains length(bit_string), it " is referenced as bit_length|0. When it contains the resulting index " within bit_string, it is referenced as index|0. " In: pr(arg_list) -> the argument list. " Out: pr(bit_length) -> length(bit_string). " ----------------------------------------------------------------------------- get_length: lxl3 arg_list|0 " get length(bit_string): cmpx3 4,du " compensate for arg lists which tze no_parent " have a parent_ptr. parent: " bit_string descriptor is 1st in ldq arg_list|8,* " arg_list (after bit_string arg, " index arg and parent_ptr). tra compute_length no_parent: ldq arg_list|6,* " bit_string descriptor is 1st in " arg_list (after bit_string arg " and index arg). compute_length: anq desc_length_mask " mask out all but bit length from desc stq bit_length|0 " ----------------------------------------------------------------------------- " Branch depending upon whether search is for first (left-to-right) or " last (right-to-left) on/off bit. " In: x(direction) = choice of first/last. " ----------------------------------------------------------------------------- tra direction_vector,direction direction_vector: tra find_first_in_lead_bits tra find_last_in_trail_bits " ----------------------------------------------------------------------------- " LOOKING FOR FIRST BIT (left-to-right search): " Loop thru bits prior to first full byte: check for desired (on or off) bit. " In: x(bits_prior_1st_byte) = bits preceding first full byte of " bit_string. These must be processed one at " a time. Full bytes are processed later. " pr(bit_length) -> length(bit_string). " pr(bit_string) -> bit_string to be searched. " pr(test_bit) -> bit value searching for (on or off). " Out: q-reg = index in bit_string of desired bit, if match " occurs. " ----------------------------------------------------------------------------- find_first_in_lead_bits: fflb: eaq 0,bits_prior_1st_byte tmoz find_first_in_bytes " Byte-aligned bit string? Skip " checking of leading bits. " if bits_prior_first_byte > 0 then qrs 18 " do do_index = min(length(bit_string), cmpq bit_length|0 " bits_prior_1st_byte) to 0 by -1 tmi fflb_long_bit_string ldq bit_length|0 fflb_long_bit_string: eax do_index,1,ql ldq 1,dl fflb_loop: sbx do_index,1,du tze find_first_in_bytes " Leading bits exhausted, no match. even cmpb (pr,ql),(pr) " Compare leading bit with test_bit. descb bit_string|-1(35),1 " substr(bit_string,q-reg,1)=test_bit? descb test_bit|0,1 tze match " Yes, match found. adq 1,dl " No, match not found. Continue loop. tra fflb_loop " ----------------------------------------------------------------------------- " Desired bit not found. Compute number of full bytes (byte-aligned bytes) " in bit_string. " In: x(bits_prior_1st_byte) = bits preceding first full byte of bit_string " pr(bit_length) -> length(bit_string). " Out: x(bits_after_Nth_byte) = bits following last full byte of bit_string. " q-reg = count of full bytes in bit_string. " ----------------------------------------------------------------------------- find_first_in_bytes: " Compute bits in full bytes in a-reg: eaa 0,bits_prior_1st_byte ars 18 " Put bits_prior_1st_byte into a-reg. neg " Negate value for subtraction. ada bit_length|0 " Subtract from length(bit_string). lrl 36 " Put result in q-reg for division. div BITS_PER_BYTE,dl eax bits_after_Nth_byte,0,al " Remainder of division is bits after " last byte. cmpq 0,dl " Are there any full bytes? tze find_first_in_trail_bits " No. Branch to test trailing bits. " ----------------------------------------------------------------------------- " Test full bytes to find first containing desired bit, using TCT instruction. " In: pr(bit_length) -> length(bit_string). " pr(bit_string) -> bit_string. " x(bits_prior_1st_byte) = bits preceding first full byte of bit_string " q-reg = count of full bytes in bit_string. " pr(table) -> test/translate table appropriate for desired " bit and direction. " Out: pr(index) -> result of TCT instruction, if match found. " pr(bit_length) -> length(bit_string), if match not found. " ----------------------------------------------------------------------------- lda bit_length|0 " Save full length of bit_string in " a-reg while bit_length loc holds " result of tct instruction. epp byte_str,bit_string|0 abd byte_str|0,bits_prior_1st_byte " Compute loc of first full byte even tct (pr,rl),fill(000) " Look for first instance of desired desc9a byte_str|0,ql " (on/off) bit. arg table|0 arg index|0 " result goes into index loc ttf store_tct_result " Match found in some byte? We won! sta bit_length|0 " Restore length(bit_string) into " storage to undo temp-save done above. " ----------------------------------------------------------------------------- " Loop thru bits after last full byte, checking for desired (on/off) bit. " In: x(bits_after_Nth_byte) = bits following last full byte of bit_string. " pr(bit_length) -> length(bit_string). " pr(bit_string) -> bit_string to be searched. " pr(test_bit) -> bit value searching for (on or off). " Out: q-reg = index of desired bit, if match found. " ----------------------------------------------------------------------------- find_first_in_trail_bits: fftb: eaa 0,bits_after_Nth_byte " Are there any bits after last byte? tmoz no_match " No, no match found. ars 18 " Yes, a-reg contains number of bits. neg " a-reg = length(bit_string) - ada bit_length|0 " bits_after_Nth_byte + 1 " = index of 1st bit after ada 1,dl " Nth byte. lrl 36 " Shift result to q-reg eax do_index,1,bits_after_Nth_byte fftb_loop: " do do_index = bits_after_Nth_byte sbx do_index,1,du " to 0 by -1 tze no_match " Trailing bits exhausted, no match. even cmpb (pr,ql),(pr) " Compare trailing bit with test_bit. descb bit_string|-1(35),1 " substr(bit_string,q-reg,1)=test_bit? descb test_bit|0,1 tze match " Match found. adq 1,dl tra fftb_loop " No match found-- loop. " ----------------------------------------------------------------------------- " Matching bit found in full byte. " Convert tct result to bit index, stored in q-reg. " In: pr(index) -> result of TCT instruction. " x(bits_prior_1st_byte) = bits preceding first full byte of bit_string " Out: q-reg = index in bit_string of desired bit. " ----------------------------------------------------------------------------- store_tct_result: ldq index|0 " Match found, compute bit index: anq string_index_mask " Start with byte offset (not index) mpy BITS_PER_BYTE,dl " * 9 = bit offset of selected byte lda index|0 " + translated byte value (index of arl 27 " first desired bit within byte sta index|0 " copied from test/translate adq index|0 " table by TCT into 1st byte of " TCT result) stz index|0 " + bits prior to first byte. sxl bits_prior_1st_byte,index|0 adq index|0 " ----------------------------------------------------------------------------- " Success return point: " In: q-reg = index in bit_string of desired bit. " Out: pr(index) -> index in bit_string of desired bit (result). " ----------------------------------------------------------------------------- match: stq index|0 short_return " ----------------------------------------------------------------------------- " Failure return point: " Out: pr(index) -> 0 (desired bit not found). " ----------------------------------------------------------------------------- no_match: stz index|0 short_return " ----------------------------------------------------------------------------- " LOOKING FOR LAST BIT (right-to-left search): " Compute how many bits of bit_string follow the last full byte. " In: x(bits_prior_1st_byte) = bits preceding first full byte of " bit_string. These must be processed " separately from full (byte-aligned) bytes. " pr(bit_length) -> length(bit_string). " Out: x(bits_after_Nth_byte) = bits following last full byte of bit_string. " a-reg = count of full bytes in bit_string. " ----------------------------------------------------------------------------- find_last_in_trail_bits: fltb: ldx bits_after_Nth_byte,0,du " assume no trailing bits. eaa 0,bits_prior_1st_byte " length(bit_string) - ars 18 " bits_prior_1st_byte neg ada bit_length|0 tmi find_last_in_lead_bits " Negative? No bits follow. lrl 36 div BITS_PER_BYTE,dl " mod(length,9) = eax bits_after_Nth_byte,0,al " bits after last full byte lls 36 " a-reg = number of full bytes " ----------------------------------------------------------------------------- " Loop thru bits after last full byte, checking for a desired (on/off) bit " In: pr(bit_length) -> length(bit_string). " x(bits_after_Nth_byte) = bits following last full byte of bit_string. " pr(bit_string) -> bit_string to be searched. " pr(test_bit) -> bit value searching for (on or off). " Out: q-reg = index of desired bit, if match found. " ----------------------------------------------------------------------------- ldq bit_length|0 eax do_index,1,bits_after_Nth_byte fltb_loop: " do do_index = bits_after_Nth_byte sbx do_index,1,du " to 0 by -1 tze find_last_in_bytes " Trailing bits exhausted, no match. even cmpb (pr,ql),(pr) " Compare trailing bit with test_bit. descb bit_string|-1(35),1 " substr(bit_string,q-req,1)=test_bit? descb test_bit|0,1 tze match " Match found. sbq 1,dl tra fltb_loop " No match found. Continue loop. " ----------------------------------------------------------------------------- " Test full bytes to find last containing desired bit, using TCTR instruction. " In: a-reg = count of full bytes in bit_string. " pr(bit_length) -> length(bit_string). " pr(bit_string) -> bit_string. " x(bits_prior_1st_byte) = bits preceding first full byte of bit_string " pr(table) -> test/translate table appropriate for desired " bit and direction. " Out: pr(index) -> result of TCT instruction, if match found. " pr(bit_length) -> length(bit_string), if match not found. " q-reg = count of full bytes in bit_string. " ----------------------------------------------------------------------------- find_last_in_bytes: lrl 36 " put number full bytes in q-reg lda bit_length|0 " Save length (bit_string) in a-reg " while bit_length holds tctr result. epp byte_str,bit_string|0 abd byte_str|0,bits_prior_1st_byte " Compute loc of first full byte. even tctr (pr,rl),fill(000) " Look for last instance of desired desc9a byte_str|0,ql " (on/off) bit. arg table|0 arg index|0 " result goes into index location. ttf store_tctr_result " Match found in some byte? We won! sta bit_length|0 " Restore length(bit_string) into " storage to undo temp-save done above. " ----------------------------------------------------------------------------- " Loop thru bits prior to first full byte, checking for desired (on/off) bit. " In: x(bits_prior_1st_byte) = bits preceding first full byte of " bit_string. " pr(bit_length) -> length(bit_string). " pr(bit_string) -> bit_string to be searched. " pr(test_bit) -> bit value searching for (on or off). " Out: q-reg = index in bit_string of desired bit, if match " occurs. " ----------------------------------------------------------------------------- find_last_in_lead_bits: fllb: eaq 0,bits_prior_1st_byte tmoz no_match " No leading bits? Then desired bit " not found. qrs 18 cmpq bit_length|0 " do q-reg = min (length(bit_string), tmi fllb_long_bit_string" bits_prior_to_1st_byte) to 0 by -1 ldq bit_length|0 fllb_long_bit_string: adq 1,dl fllb_loop: sbq 1,dl tmoz no_match " Leading bits exhausted, no match. even cmpb (pr,ql),(pr) " Compare leading bit with test_bit. descb bit_string|-1(35),1 " substr(bit_string,q-reg,1)=test_bit? descb test_bit|0,1 tze match " Yes, match found. tra fllb_loop " No, match not found. Continue loop. " ----------------------------------------------------------------------------- " Matching bit found in full byte. " Convert tctr result to bit index, stored in q-reg. " In: pr(index) -> result of TCTR instruction. " x(bits_prior_1st_byte) = bits preceding first full byte of bit_string " q-reg = count of full bytes in bit_string. " Out: q-reg = index in bit_string of desired bit. " ----------------------------------------------------------------------------- store_tctr_result: ldx table_char,index|0 " Save selected char from " test/translate table which TCTR " instruction put in 1st byte of " TCTR result. lda index|0 " a-reg = byte_offset_from_right_end ana string_index_mask " stq index|0 " q-reg = full_bytes_in_bit_string " (saved at find_last_in_bytes above) sba index|0 " full_bytes_in_bit_string neg " - byte_offset_from_right_end sba 1,dl " - 1 " = bytes_before_wanted_byte lrl 36 " * 9 mpy BITS_PER_BYTE,dl " = bits_in_bytes_before_wanted_byte eaa 0,table_char " + translated byte value (index of arl 27 " first desired bit within byte) sta index|0 " = bit index of wanted bit, excluding adq index|0 " bits prior to first byte. stz index|0 " + bits prior to first byte. sxl bits_prior_1st_byte,index|0 adq index|0 " = bit index of wanted bit (in q-reg) tra match " ----------------------------------------------------------------------------- " TCT test/translate tables: " " Each of the following test/translate tables is designed to work with the " TCT and TCTR instructions. The bit string being examined is broken up into " full bytes. The byte value (rank) of each byte is used as an index into the " 512 entry test/translate table. The numeric value stored in the table entry " gives the index within the byte of the desired bit (eg, the first on bit " within the byte). " " For example, when looking for the first on bit, suppose the byte being " tested has the value 003 (octal). Using PL/I bit string notation, this is " expressed as "003"b3 = "000000011"b. The index of the first on bit " within the byte is 8. 8 (decimal) = "010"b3. " " Therefore, the number 8 (= "010"b3) is stored in the test/translate table " entry corresponding to the byte "003"b in the table below. " ----------------------------------------------------------------------------- even first_on_bit_table: oct 000011010010,007007007007 " 000-007 (entry 003 " has value 010) oct 006006006006,006006006006 " 010-017 oct 005005005005,005005005005 " 020-027 oct 005005005005,005005005005 " 030-037 oct 004004004004,004004004004 " 040-047 oct 004004004004,004004004004 " 050-057 oct 004004004004,004004004004 " 060-067 oct 004004004004,004004004004 " 070-077 oct 003003003003,003003003003 " 100-107 oct 003003003003,003003003003 " 110-117 oct 003003003003,003003003003 " 120-127 oct 003003003003,003003003003 " 130-137 oct 003003003003,003003003003 " 140-147 oct 003003003003,003003003003 " 150-157 oct 003003003003,003003003003 " 160-167 oct 003003003003,003003003003 " 170-177 oct 002002002002,002002002002 " 200-207 oct 002002002002,002002002002 " 210-217 oct 002002002002,002002002002 " 220-227 oct 002002002002,002002002002 " 230-237 oct 002002002002,002002002002 " 240-247 oct 002002002002,002002002002 " 250-257 oct 002002002002,002002002002 " 260-267 oct 002002002002,002002002002 " 270-277 oct 002002002002,002002002002 " 300-307 oct 002002002002,002002002002 " 310-317 oct 002002002002,002002002002 " 320-327 oct 002002002002,002002002002 " 330-337 oct 002002002002,002002002002 " 340-347 oct 002002002002,002002002002 " 350-357 oct 002002002002,002002002002 " 360-367 oct 002002002002,002002002002 " 370-377 oct 001001001001,001001001001 " 400-407 oct 001001001001,001001001001 " 410-417 oct 001001001001,001001001001 " 420-427 oct 001001001001,001001001001 " 430-437 oct 001001001001,001001001001 " 440-447 oct 001001001001,001001001001 " 450-457 oct 001001001001,001001001001 " 460-467 oct 001001001001,001001001001 " 470-477 oct 001001001001,001001001001 " 500-507 oct 001001001001,001001001001 " 510-517 oct 001001001001,001001001001 " 520-527 oct 001001001001,001001001001 " 530-537 oct 001001001001,001001001001 " 540-547 oct 001001001001,001001001001 " 550-557 oct 001001001001,001001001001 " 560-567 oct 001001001001,001001001001 " 570-577 oct 001001001001,001001001001 " 600-607 oct 001001001001,001001001001 " 610-617 oct 001001001001,001001001001 " 620-627 oct 001001001001,001001001001 " 630-637 oct 001001001001,001001001001 " 640-647 oct 001001001001,001001001001 " 650-657 oct 001001001001,001001001001 " 660-667 oct 001001001001,001001001001 " 670-677 oct 001001001001,001001001001 " 700-707 oct 001001001001,001001001001 " 710-717 oct 001001001001,001001001001 " 720-727 oct 001001001001,001001001001 " 730-737 oct 001001001001,001001001001 " 740-747 oct 001001001001,001001001001 " 750-757 oct 001001001001,001001001001 " 760-767 oct 001001001001,001001001001 " 770-777 even first_off_bit_table: oct 001001001001,001001001001 " 000-007 oct 001001001001,001001001001 " 010-017 oct 001001001001,001001001001 " 020-027 oct 001001001001,001001001001 " 030-037 oct 001001001001,001001001001 " 040-047 oct 001001001001,001001001001 " 050-057 oct 001001001001,001001001001 " 060-067 oct 001001001001,001001001001 " 070-077 oct 001001001001,001001001001 " 100-107 oct 001001001001,001001001001 " 110-117 oct 001001001001,001001001001 " 120-127 oct 001001001001,001001001001 " 130-137 oct 001001001001,001001001001 " 140-147 oct 001001001001,001001001001 " 150-157 oct 001001001001,001001001001 " 160-167 oct 001001001001,001001001001 " 170-177 oct 001001001001,001001001001 " 200-207 oct 001001001001,001001001001 " 210-217 oct 001001001001,001001001001 " 220-227 oct 001001001001,001001001001 " 230-237 oct 001001001001,001001001001 " 240-247 oct 001001001001,001001001001 " 250-257 oct 001001001001,001001001001 " 260-267 oct 001001001001,001001001001 " 270-277 oct 001001001001,001001001001 " 300-307 oct 001001001001,001001001001 " 310-317 oct 001001001001,001001001001 " 320-327 oct 001001001001,001001001001 " 330-337 oct 001001001001,001001001001 " 340-347 oct 001001001001,001001001001 " 350-357 oct 001001001001,001001001001 " 360-367 oct 001001001001,001001001001 " 370-377 oct 002002002002,002002002002 " 400-407 oct 002002002002,002002002002 " 410-417 oct 002002002002,002002002002 " 420-427 oct 002002002002,002002002002 " 430-437 oct 002002002002,002002002002 " 440-447 oct 002002002002,002002002002 " 450-457 oct 002002002002,002002002002 " 460-467 oct 002002002002,002002002002 " 470-477 oct 002002002002,002002002002 " 500-507 oct 002002002002,002002002002 " 510-517 oct 002002002002,002002002002 " 520-527 oct 002002002002,002002002002 " 530-537 oct 002002002002,002002002002 " 540-547 oct 002002002002,002002002002 " 550-557 oct 002002002002,002002002002 " 560-567 oct 002002002002,002002002002 " 570-577 oct 003003003003,003003003003 " 600-607 oct 003003003003,003003003003 " 610-617 oct 003003003003,003003003003 " 620-627 oct 003003003003,003003003003 " 630-637 oct 003003003003,003003003003 " 640-647 oct 003003003003,003003003003 " 650-657 oct 003003003003,003003003003 " 660-667 oct 003003003003,003003003003 " 670-677 oct 004004004004,004004004004 " 700-707 oct 004004004004,004004004004 " 710-717 oct 004004004004,004004004004 " 720-727 oct 004004004004,004004004004 " 730-737 oct 005005005005,005005005005 " 740-747 oct 005005005005,005005005005 " 750-757 oct 006006006006,006006006006 " 760-767 oct 007007007007,010010011000 " 770-777 even last_on_bit_table: oct 000011010011,007011010011 " 000-007 oct 006011010011,007011010011 " 010-017 oct 005011010011,007011010011 " 020-027 oct 006011010011,007011010011 " 030-037 oct 004011010011,007011010011 " 040-047 oct 006011010011,007011010011 " 050-057 oct 005011010011,007011010011 " 060-067 oct 006011010011,007011010011 " 070-077 oct 003011010011,007011010011 " 100-107 oct 006011010011,007011010011 " 110-117 oct 005011010011,007011010011 " 120-127 oct 006011010011,007011010011 " 130-137 oct 004011010011,007011010011 " 140-147 oct 006011010011,007011010011 " 150-157 oct 005011010011,007011010011 " 160-167 oct 006011010011,007011010011 " 170-177 oct 002011010011,007011010011 " 200-207 oct 006011010011,007011010011 " 210-217 oct 005011010011,007011010011 " 220-227 oct 006011010011,007011010011 " 230-237 oct 004011010011,007011010011 " 240-247 oct 006011010011,007011010011 " 250-257 oct 005011010011,007011010011 " 260-267 oct 006011010011,007011010011 " 270-277 oct 003011010011,007011010011 " 300-307 oct 006011010011,007011010011 " 310-317 oct 005011010011,007011010011 " 320-327 oct 006011010011,007011010011 " 330-337 oct 004011010011,007011010011 " 340-347 oct 006011010011,007011010011 " 350-357 oct 005011010011,007011010011 " 360-367 oct 006011010011,007011010011 " 370-377 oct 001011010011,007011010011 " 400-407 oct 006011010011,007011010011 " 410-417 oct 005011010011,007011010011 " 420-427 oct 006011010011,007011010011 " 430-437 oct 004011010011,007011010011 " 440-447 oct 006011010011,007011010011 " 450-457 oct 005011010011,007011010011 " 460-467 oct 006011010011,007011010011 " 470-477 oct 003011010011,007011010011 " 500-507 oct 006011010011,007011010011 " 510-517 oct 005011010011,007011010011 " 520-527 oct 006011010011,007011010011 " 530-537 oct 004011010011,007011010011 " 540-547 oct 006011010011,007011010011 " 550-557 oct 005011010011,007011010011 " 560-567 oct 006011010011,007011010011 " 570-577 oct 002011010011,007011010011 " 600-607 oct 006011010011,007011010011 " 610-617 oct 005011010011,007011010011 " 620-627 oct 006011010011,007011010011 " 630-637 oct 004011010011,007011010011 " 640-647 oct 006011010011,007011010011 " 650-657 oct 005011010011,007011010011 " 660-667 oct 006011010011,007011010011 " 670-677 oct 003011010011,007011010011 " 700-707 oct 006011010011,007011010011 " 710-717 oct 005011010011,007011010011 " 720-727 oct 006011010011,007011010011 " 730-737 oct 004011010011,007011010011 " 740-747 oct 006011010011,007011010011 " 750-757 oct 005011010011,007011010011 " 760-767 oct 006011010011,007011010011 " 770-777 even last_off_bit_table: oct 011010011007,011010011006 " 000-007 oct 011010011007,011010011005 " 010-017 oct 011010011007,011010011006 " 020-027 oct 011010011007,011010011004 " 030-037 oct 011010011007,011010011006 " 040-047 oct 011010011007,011010011005 " 050-057 oct 011010011007,011010011006 " 060-067 oct 011010011007,011010011003 " 070-077 oct 011010011007,011010011006 " 100-107 oct 011010011007,011010011005 " 110-117 oct 011010011007,011010011006 " 120-127 oct 011010011007,011010011004 " 130-137 oct 011010011007,011010011006 " 140-147 oct 011010011007,011010011005 " 150-157 oct 011010011007,011010011006 " 160-167 oct 011010011007,011010011002 " 170-177 oct 011010011007,011010011006 " 200-207 oct 011010011007,011010011005 " 210-217 oct 011010011007,011010011006 " 220-227 oct 011010011007,011010011004 " 230-237 oct 011010011007,011010011006 " 240-247 oct 011010011007,011010011005 " 250-257 oct 011010011007,011010011006 " 260-267 oct 011010011007,011010011003 " 270-277 oct 011010011007,011010011006 " 300-307 oct 011010011007,011010011005 " 310-317 oct 011010011007,011010011006 " 320-327 oct 011010011007,011010011004 " 330-337 oct 011010011007,011010011006 " 340-347 oct 011010011007,011010011005 " 350-357 oct 011010011007,011010011006 " 360-367 oct 011010011007,011010011001 " 370-377 oct 011010011007,011010011006 " 400-407 oct 011010011007,011010011005 " 410-417 oct 011010011007,011010011006 " 420-427 oct 011010011007,011010011004 " 430-437 oct 011010011007,011010011006 " 440-447 oct 011010011007,011010011005 " 450-457 oct 011010011007,011010011006 " 460-467 oct 011010011007,011010011003 " 470-477 oct 011010011007,011010011006 " 500-507 oct 011010011007,011010011005 " 510-517 oct 011010011007,011010011006 " 520-527 oct 011010011007,011010011004 " 530-537 oct 011010011007,011010011006 " 540-547 oct 011010011007,011010011005 " 550-557 oct 011010011007,011010011006 " 560-567 oct 011010011007,011010011002 " 570-577 oct 011010011007,011010011006 " 600-607 oct 011010011007,011010011005 " 610-617 oct 011010011007,011010011006 " 620-627 oct 011010011007,011010011004 " 630-637 oct 011010011007,011010011006 " 640-647 oct 011010011007,011010011005 " 650-657 oct 011010011007,011010011006 " 660-667 oct 011010011007,011010011003 " 670-677 oct 011010011007,011010011006 " 700-707 oct 011010011007,011010011005 " 710-717 oct 011010011007,011010011006 " 720-727 oct 011010011007,011010011004 " 730-737 oct 011010011007,011010011006 " 740-747 oct 011010011007,011010011005 " 750-757 oct 011010011007,011010011006 " 760-767 oct 011010011007,011010011000 " 770-777 end  find_char_.alm 11/11/89 1150.6rew 11/11/89 0805.5 300600 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(74-07-01,GDixon), approve(), audit(), install(): " Create initial version of the program, called tct_. " 2) change(75-09-25,GDixon), approve(), audit(), install(): " Add $quote table segdef. " 3) change(76-03-12,GDixon), approve(), audit(), install(): " Add $verify, $reverse_verify, $search, and $reverse_search entrypoints. " 4) change(86-02-05,GDixon), approve(86-05-16,MCR7357), " audit(86-07-10,Farley), install(86-07-17,MR12.0-1097): " Renamed subr from tct_ to find_char_. Renamed all entrypoints. " Added the $make_table_of_chars_in_list and " $make_table_of_chars_not_in_list entrypoints. " Also fixed bug which prevents find_char_$last_in_table, " $translate_last_in_table, $last_in_list and $last_not_in_list " from working properly. " END HISTORY COMMENTS " * * * * * * * * * * * * * * ** * * * * * * * * * * * " " Name: find_char_ " " This subroutine uses the EIS test character and translate (TCT) " instruction to perform the function of the PL/I search and verify builtins. " The code uses either a pre-defined test/translate table, or it constructs " one "on the fly". " " Entry: find_char_$first_in_table " " Function: This entry point implements the PL/I search builtin function " with a predefined test/translate table. " " Syntax: " dcl find_char_$first_in_table entry (char(*), char(512) aligned) " returns (fixed bin(21)) reducible; " index = find_char_$first_in_table (string, table); " " Arguments: " string " is the character string to be searched. (In) " table " is the translation table. (See Notes below.) (In) " index " is the result of the search. It is a PL/I string index (character " position). (Out) " " Entry: find_char_$last_in_table " " Function: This entry point is like find_char_$first_in_table, but searches " the string in reverse, from last character to first. A PL/I string index " (character position relative to the beginning of the string) is returned. " It performs the PL/I function: " i = length(string) - search (reverse(string), table_chars) + 1 " [when char searched for is found in string] " i = 0 [when char searched for is not found.] " " " Syntax: " dcl find_char_$last_in_table entry (char(*), char(512) aligned) " returns (fixed bin(21)) reducible; " index = find_char_$last_in_table (string, table); " " Arguments: " string " is the character string to be searched. (In) " table " is the translation table. (See Notes below.) (In) " index " is the result of the search. It is a PL/I string index (character " position). (Out) " " Entry: find_char_$translate_first_in_table " " Function: This entry point performs the PL/I search function, but also " returns the translate table entry for the character which stopped the search. " See Notes below for a more explicit description of the returned " character. " " Syntax: " dcl find_char_$translate_first_in_table entry (char(*), " char(512) aligned, fixed bin(21)) returns (char(1)); " char = find_char_$translate_first_in_table (string, table, index); " " Arguments: " string " is the character string to be searched. (In) " table " is the translation table. (See Notes below.) (In) " index " is the result of the search. It is a PL/I string index (character " position). (Out) " char " is the character from the translation table into which the indexed " character of string has been translated. (Out) " " Entry: find_char_$translate_last_in_table " " Function: This entry is like find_char_$translate_first_in_table, but does " the search function in reverse, from last char of string to first. " " Syntax: " dcl find_char_$translate_last_in_table entry (char(*), " char(512) aligned, fixed bin(21)) returns (char(1)); " char = find_char_$translate_last_in_table (string, table, index); " " Arguments: " string " is the character string to be searched. (In) " table " is the translation table. (See Notes below.) (In) " index " is the result of the search. It is a PL/I string index (character " position). (Out) " char " is the character from the translation table into which the indexed " character of string has been translated. (Out) " " Entry: find_char_$first_in_list " " Function: This entry performs the PL/I function: " index = search (string, chars); " " Syntax: " dcl find_char_$first_in_list entry (char(*), char(*)) " returns(fixed bin(21)) reducible; " index = find_char_$first_in_list (string, search_list); " " Arguments: " string " is the character string to be searched. (In) " search_list " are characters to be found in the string. (In) " index " is the result of the search. It is the PL/I string index (character " position) of the first occurrence of any of the search characters in " string. (Out) " " Entry: find_char_$last_in_list " " Function: This entry returns the index (character position relative to the " beginning of the string) of the rightmost occurrence of any of the characters " being searched for. It performs the PL/I function: " index = length(string) - search (reverse(string), chars) + 1 " [when char searched for is found in string] " index = 0 [when char searched for is not found.] " " Syntax: " dcl find_char_$last_in_list entry (char(*), char(*)) " returns(fixed bin(21)) reducible; " i = find_char_$last_in_list (string, search_list); " " Arguments: " string " is the character string to be searched. (In) " search_list " are characters to be found in the string. (In) " index " is the result of the search. It is the PL/I string index (character " position) of the last occurrence of any of the search characters in " string. (Out) " " Entry: find_char_$first_not_in_list " " Function: This entry performs the PL/I function: " index = verify(string, chars) " " Syntax: " dcl find_char_$first_not_in_list entry (char(*), char(*)) " returns(fixed bin(21)) reducible; " i = find_char_$first_not_in_list (string, verify_list); " " Arguments: " string " is the character string to be searched. (In) " verify_list " are characters whose existence in the string is to be verified. (In) " index " is the result of the verify. It is the PL/I string index (character " position) of the first occurrence of a string character which is not " an element in verify_list. (Out) " " Entry: find_char_$last_not_in_list " " Function: This entry returns the index (character position relative to the " beginning of the string) of the rightmost occurrence of a char in string " which is not an element of verify_chars. It performs the PL/I function: " index = length(string) - verify (reverse(string), chars) + 1 " [when character not in chars is found in string] " index = 0 [when character not in chars is not found in string.] " " Syntax: " dcl find_char_$last_not_in_list entry (char(*), char(*)) " returns(fixed bin(21)) reducible; " i = find_char_$last_not_in_list (string, verify_list); " " Arguments: " string " is the character string to be searched. (In) " verify_list " are characters whose existence in the string is to be verified. (In) " index " is the result of the verify. It is the PL/I string index (character " position) of the last occurrence of a string character which is not " an element in verify_list. (Out) " " Entry: find_char_$make_table_of_chars_in_list " " Function: This entry constructs a test/translate table for use with the " find_char_$first_in_table and find_char_$last_in_table entrypoints. " Table entries corresponding to characters of search_list are marked with " \777 in the search table. Other table entries are filled with \000. " " Syntax: " dcl find_char_$make_table_of_chars_in_list (char(*), char(512) aligned); " call find_char_$make_table_of_chars_in_list (search_list, table); " " Arguments: " search_list " is a string of characters whose corresponding entries are to be marked in " the resulting translate table. (In) " table " is the translate table. (Out) " " Entry: find_char_$make_table_of_chars_not_in_list " " Function: This entry constructs a test/translate table for use with the " find_char_$first_in_table and find_char_$last_in_table entrypoints. " Table entries corresponding to characters of verify_list are marked with " \000 in the search table. Other table entries are filled with \777. " " Syntax: " dcl find_char_$make_table_of_chars_not_in_list " (char(*), char(512) aligned); " call find_char_$make_table_of_chars_not_in_list (verify_list, table); " " Arguments: " verify_list " is a string of characters whose corresponding entries are to remain " unmarked in the resulting translate table. (In) " table " is the translate table. (Out) " " Notes " " The test/translate table is a fixed length character string. It " should be 512 characters long to cover all possible Multics " 9-bit byte values. " " The test/translate table consists of "\000" characters and " characters which are not "\000". The search progresses as follows: " " 1) Examine the first (or next) character of the source string. " If i is the index of the character being examined, then " source_char = substr(string, i, 1) " 2) For each source_char, examine its corresponding table_char: " table_char = substr(table,rank(source_char)+1,1) " 3) If table_char = "\000", then the test fails and the search " continues with step 1. " 4) If table_char ^= "\000", then the test succeeds and the search " stops. The current value of i is returned as the index " value. For the $translate entry points, table_char is returned " as the char argument. " 5) If the source string is exhausted before the test succeeds, then " a value of 0 is returned as the index argument, and for the " $translate entry point, "\000" is returned as the char argument. " " Table: find_char_$not_ascii_table " " This is a translation table which can be used to detect any " non-ASCII characters in a character string. Non-ASCII characters " are those in which one or both of the 2 leftmost bits of the " 9-bit character byte are "1"b (i.e., character > "\177"). The " first 128 values in the table are "\000". The next 384 table " characters are set to their character offset within the table. " This means that: " substr(table,n+1,1) = "\000", for n: 000 <= n <= 127 " substr(table,n+1,1) = "\n", for n: 128 <= n <= 511 " " * * * * * * * * * * * * * * ** * * * * * * * * * * * " ----------------------------------------------------------------------------- " Segname, and entrypoint definitions. " ----------------------------------------------------------------------------- name find_char_ segdef first_in_table segdef last_in_table segdef translate_first_in_table segdef translate_last_in_table entry first_in_list entry first_not_in_list entry last_in_list entry last_not_in_list entry make_table_of_chars_in_list entry make_table_of_chars_not_in_list segdef not_ascii_table " ----------------------------------------------------------------------------- " Code for find_char_$first_in_table, $translate_first_in_table, " $last_in_table, and $translate_last_in_table, $first_in_list, " $first_not_in_list, $last_in_list and $last_not_in_list. " ----------------------------------------------------------------------------- " Register name assignments: equ arg_list,0 " pr0 -> argument list equ string,1 " pr1 -> string to be searched. equ search_list,2 " pr2 -> search_list, verify_list. equ table,3 " pr3 -> test/translate table. equ char,4 " pr4 -> value of test/translate table " element corresponding to the " string character found by tct. equ search_list_char,4 " pr4 -> a char from search_list. equ index,5 " pr5 -> character index of string " character found by tct instr. equ auto_storage,6 " pr6 -> stack frame, containing " storage for automatic vars. equ desc_offset,2 " x2 = word offset of 1st arg " descriptor in arg_list. equ do_index,3 " x3 = a do group index. equ return_loc,6 " x6 = subroutine return location. temp table_var(128) " automatic char(512) aligned table " for use in tct/tctr instructions " when $XXX_in_list make their " own table. temp search_list_char_var(1) " automatic char(1) aligned word to " hold one search_list char at " a time so its rank can be computed. desc_length_mask: " ANDing mask to extract char string oct 000077777777 " length from an argument descriptor. string_index_mask: " ANDing mask to extract char offset oct 000777777777 " from result of TCT instruction. " ----------------------------------------------------------------------------- " find_char_$first_in_table: proc (string, table) returns (index); " ----------------------------------------------------------------------------- first_in_table: ldx desc_offset,8,du " set offset of first argument " descriptor from head of arglist. tsx return_loc,get_table_parms " get parm ptr/lengths tsx return_loc,tct " execute tct instruction ttf first_in_table_match " Branch if tct found a match stz index|0 " tct failed... store 0 in result short_return first_in_table_match: " tct succeeded tsx return_loc,set_tct_index_parm short_return " ----------------------------------------------------------------------------- " find_char_$last_in_table: entry (string, table) returns (index); " ----------------------------------------------------------------------------- last_in_table: ldx desc_offset,8,du " set offset of 1st arg desc tsx return_loc,get_table_parms " get parm ptr/lengths tsx return_loc,tctr " execute tctr instruction ttf last_in_table_match " Branch if tctr found a match. stz index|0 " tctr failed... store 0 in result short_return last_in_table_match: " tctr succeeded tsx return_loc,set_tctr_index_parm short_return " ----------------------------------------------------------------------------- " find_char_$translate_first_in_table: entry (string, table, index) " returns (char); " ----------------------------------------------------------------------------- translate_first_in_table: ldx desc_offset,10,du " set offset of first argument " descriptor tsx return_loc,get_table_parms " get parm ptr/lengths tsx return_loc,tct " execute tct instruction ttf translate_first_in_table_match " Branch if tct found a match. stz index|0 " tct failed... store 0 in result tsx return_loc,set_char_parm " move \000 from index into char parm. short_return " tct failed. translate_first_in_table_match: " tct succeeded. tsx return_loc,set_char_parm " move translated char into char parm. tsx return_loc,set_tct_index_parm short_return " ----------------------------------------------------------------------------- " find_char_$translate_last_in_table: entry (string, table, index) " returns (char); " ----------------------------------------------------------------------------- translate_last_in_table: ldx desc_offset,10,du " set offset of 1st arg desc tsx return_loc,get_table_parms " get parm ptr/lengths tsx return_loc,tctr " execute tctr instruction ttf translate_last_in_table_match " Branch if tctr found a match. stz index|0 " tctr failed... store 0 in result tsx return_loc,set_char_parm " move \000 from index into char parm. short_return translate_last_in_table_match: tsx return_loc,set_char_parm " move translated char into char parm. tsx return_loc,set_tctr_index_parm short_return " ----------------------------------------------------------------------------- " make_table_of_chars_not_in_list: entry (verify_list, table); " ----------------------------------------------------------------------------- make_table_of_chars_not_in_list: push " Need automatic variables when " filling the search table. tsx return_loc,get_make_table_parms tsx return_loc,fill_table_from_list tsx return_loc,invert_table_entries return " ----------------------------------------------------------------------------- " make_table_of_chars_in_list: entry (search_list, table); " ----------------------------------------------------------------------------- make_table_of_chars_in_list: push " Need automatic variables when " filling the search table. tsx return_loc,get_make_table_parms tsx return_loc,fill_table_from_list return " ----------------------------------------------------------------------------- " first_in_list: entry (string, search_list) returns (index); " ----------------------------------------------------------------------------- first_in_list: push " Need automatic variables when " filling the search table. tsx return_loc,get_list_parms tsx return_loc,fill_table_from_list " build table from search_list tsx return_loc,tct " execute tct instruction ttf first_in_list_match " Branch if it succeeds. stz index|0 " tct failed... store 0 result. return first_in_list_match: " tct succeeded tsx return_loc,set_tct_index_parm return " ----------------------------------------------------------------------------- " last_in_list: entry (string, search_list) returns (index); " ----------------------------------------------------------------------------- last_in_list: push " Need automatic variables when " filling the search table. tsx return_loc,get_list_parms tsx return_loc,fill_table_from_list " build table from search_list tsx return_loc,tctr " execute tctr instruction ttf last_in_list_match " Branch if it succeeds. stz index|0 " tctr failed... store 0 result. return last_in_list_match: " tctr succeeded tsx return_loc,set_tctr_index_parm return " ----------------------------------------------------------------------------- " first_not_in_list: entry (string, verify_list) returns (index); " ----------------------------------------------------------------------------- first_not_in_list: push " Need automatic variables when " filling the search table. tsx return_loc,get_list_parms " get parms tsx return_loc,fill_table_from_list " build table from verify_list tsx return_loc,invert_table_entries " convert search table to verify table tsx return_loc,tct " execute tct instruction ttf first_not_in_list_match " Branch if it succeeds. stz index|0 " tct failed... store 0 result. return first_not_in_list_match: " tct succeeded tsx return_loc,set_tct_index_parm return " ----------------------------------------------------------------------------- " last_not_in_list: entry (string, verify_list) returns (index); " ----------------------------------------------------------------------------- last_not_in_list: push " Need automatic variables " filling the search table. tsx return_loc,get_list_parms tsx return_loc,fill_table_from_list " build table from verify_list tsx return_loc,invert_table_entries " convert search table to verify table tsx return_loc,tctr " execute tctr instruction ttf last_not_in_list_match " Branch if it succeeds. stz index|0 " tctr failed... store 0 result. return last_not_in_list_match: " tctr succeeded tsx return_loc,set_tctr_index_parm return " ============================================================================= " QUICK-BLOCK SUBROUTINES WHICH ACTUALLY DO THE WORK " ============================================================================= " ----------------------------------------------------------------------------- " Fill test/translate table, using specs in search_list string. " In: pr(table) -> translate/test table to be filled in. " pr(search_list) -> search_list character string to be turned " into a table. " x(do_index) = length(search_list). " pr(search_list_char) -> space to hold one char from search list, " so its rank can be computed. " x(return_loc) = location this subroutine should return to. " Out: pr(table) -> filled-in translate/test table. " ----------------------------------------------------------------------------- fill_table_from_list: even mlr (pr),(pr),fill(000) " fill table with 000's desc9a table|0,0 desc9a table|0,512 stz search_list_char|0 " clear search_list_char variable loop: cmpx do_index,0,du " exit loop when search_list exhausted tze 0,return_loc sbx do_index,1,du " decrement length(search_list) even mlr (pr,x3),(pr),fill(000) desc9a search_list|0,1 " search_list_char = " substr(search_list,do_index,1) desc9a search_list_char|0(3),1 ldq search_list_char|0 even mlr (pr),(pr,ql),fill(777) desc9a table|0,0 " move 777 into desc9a table|0,1 " table(rank(search_list_char)) tra loop " ----------------------------------------------------------------------------- " Get addr/length of string, search_list or verify_list and index parms " In: pr(arg_list) -> the argument list. " x(return_loc) = location this subroutine should return to. " Out: pr(string) -> string to be searched. " pr(search_list) -> chars in search_list or verify_list. " pr(index) -> character index within string. " a-reg = length(string). " x(do-index) = length(search_list). " pr(table) -> test/translate table. " pr(search_list_char) -> automatic variable to hold one " search_list char. " ----------------------------------------------------------------------------- get_list_parms: epp string,arg_list|2,* " get addr(string) [arg1] epp search_list,arg_list|4,* " get addr(search_list) [arg2] epp index,arg_list|6,* " get addr(index) [arg3] " get length(string) into a-reg. ldx desc_offset,8,du " offset of arg1 descriptor in lxl3 arg_list|0 " arg_list. cmpx3 4,du " does arglist have parent ptr? tze 2,ic " 4 means no parent ptr. adx desc_offset,2,du " otherwise, skip parent ptr. lda arg_list|0,desc_offset* " get length of string in a-reg. ana desc_length_mask " mask out all but length. ldq arg_list|2,desc_offset* anq desc_length_mask " get length(search_list) into q-reg. eax do_index,0,ql " get length(search_list) into x3. epp table,auto_storage|table_var epp search_list_char,auto_storage|search_list_char_var " get pointers to automatic variables tra 0,return_loc " ----------------------------------------------------------------------------- " Get addr/length of search_list or verify_list parm, and output table parm. " In: pr(arg_list) -> the argument list. " x(return_loc) = location this subroutine should return to. " Out: pr(search_list) -> chars in search_list, verify_list. " pr(table) -> test/translate table. " pr(search_list_char) -> automatic variable to hold one search_list " char. " x(do_index) = length(search_list). " ----------------------------------------------------------------------------- get_make_table_parms: epp search_list,arg_list|2,* " get addr(search_list) [arg1] epp table,arg_list|4,* " get addr(table) [arg2] ldx desc_offset,6,du " get length(search_list) from its arg lxl3 arg_list|0 " descriptor into a-reg. cmpx3 4,du " compensate if arglist has parent tze 2,ic " ptr. 4 means no parent ptr. adx desc_offset,2,du " if there, skip parent ptr. lda arg_list|0,desc_offset* " load 1st arg desc into a-reg. ana desc_length_mask " mask off all but the length. eax do_index,0,al " get length(search_list) into x3. epp search_list_char,auto_storage|search_list_char_var " get addr(search_list_char), making it tra 0,return_loc " point to an automatic variable. " ----------------------------------------------------------------------------- " Get pointers/length of find_char_$XXX_in_table parm: string, table, index. " In: pr(arg_list) -> the argument list. " x(desc_offset) = offset in arg list of arg1 descriptor. " x(return_loc) = location this subroutine should return to. " Out: pr(string) -> string to be searched. " pr(table) -> test/translate table. " pr(index) -> character index within string. " a-reg = length(string). " ----------------------------------------------------------------------------- get_table_parms: epp string,arg_list|2,* " get addr(string) [arg1] epp table,arg_list|4,* " get addr(table) [arg2] epp index,arg_list|6,* " get addr(index) [arg3] " get length(string) into a-reg. lxl3 arg_list|0 " compensate if arg list has parent cmpx3 4,du " ptr. tze 2,ic " 4 means no parent ptr. adx desc_offset,2,du " else, skip over parent ptr. lda arg_list|0,desc_offset* " load descriptor for string. ana desc_length_mask " mask out all but string length from " descriptor. tra 0,return_loc " ----------------------------------------------------------------------------- " Convert from a search table to a verify table by inverting all table bits. " In: pr(table) -> the search table (char(512) aligned) " x(return_loc) = location this subroutine should return to. " Out: pr(table) -> the verify table " ----------------------------------------------------------------------------- invert_table_entries: " invert bytes in test/translate table lxl7 (512*9),dl " (make off bytes on, on bytes off) even " since: verify(x) <=> search(^x) bool invert,014 csl (pr,rl),(pr,rl),fill(0),bool(invert) descb table|0,x7 " See fill_table_from_list below. descb table|0,x7 " Remember that the search table has tra 0,return_loc " bytes containing either \000 or " \777. ^\777 = \000, ^\000 = \777 " ----------------------------------------------------------------------------- " Move translated char (char selected from table by tct/tctr instruction) " from first byte of index (where tct/tctr put it) into translate table " char output parm (arg4). " In: pr(arg_list) -> the argument list. " pr(index) -> result of TCT or TCTR instruction: character offset " from right end of string, preceded by char " from selected table entry. " x(return_loc) = location this subroutine should return to. " Out: pr(char) -> char parm in which table char is returned. " ----------------------------------------------------------------------------- set_char_parm: epp char,arg_list|8,* " get addr(char) [arg4] even mlr (pr),(pr),fill(000) " move translated char to 4th arg desc9a index|0,1 " TCT result: 1st byte is trans_char desc9a char|0,1 " 4th arg tra 0,return_loc " ----------------------------------------------------------------------------- " Adjust index to remove translated char, and convert byte offset to a " byte index. " In: pr(index) -> result of TCT or TCTR instruction: character offset " from right end of string, preceded by char " from selected table entry. " x(return_loc) = location this subroutine should return to. " Out: pr(index) -> character index within string of selected char. " ----------------------------------------------------------------------------- set_tct_index_parm: ldq index|0 " load string offset anq string_index_mask " mask away translated char adq 1,dl " make string offset into index stq index|0 " store index tra 0,return_loc " ----------------------------------------------------------------------------- " Adjust index to remove translated char, convert byte offset to a " byte index, and shift from byte-index-relative-to-right-end of string to " byte-index-relative-to-left-end of string. " In: pr(index) -> result of TCT or TCTR instruction: character offset " from right end of string, preceded by char " from selected table entry. " x(return_loc) = location this subroutine should return to. " Out: pr(index) -> character index within string of selected char. " ----------------------------------------------------------------------------- set_tctr_index_parm: ldq index|0 " load string reverse_offset anq string_index_mask " mask away translated char adq 1,dl " make string reverse_offset into " reverse_index stq index|0 " store reverse_index sba index|0 " index = length(string) ada 1,dl " - reverse_index + 1 sta index|0 tra 0,return_loc " ----------------------------------------------------------------------------- " Execute tct instruction on string, using table. " In: pr(string) -> string to be searched. " a-reg = length(string). " pr(table) -> test/translate table. " x(return_loc) = location this subroutine should return to. " Out: pr(index) -> result of TCT instruction: character offset " within string, preceded by char from selected " table entry. " ----------------------------------------------------------------------------- even tct: tct (pr,rl),fill(000) " test and translate, using the table desc9a string|0,al " string,length-in-'a'-register arg table|0 " table arg index|0 " result of find_char_ stored in " index parm tra 0,return_loc " ----------------------------------------------------------------------------- " Execute tctr instruction on string, using table. " In: pr(string) -> string to be searched. " a-reg = length(string). " pr(table) -> test/translate table. " x(return_loc) = location this subroutine should return to. " Out: pr(index) -> result of TCTR instruction: character offset " from right end of string, preceded by char " from selected table entry. " ----------------------------------------------------------------------------- even tctr: tctr (pr,rl),fill(000) " test/translate in reverse desc9a string|0,al " string, length in 'a'-reg arg table|0 " table arg index|0 " result tra 0,return_loc even not_ascii_table: oct 000000000000,000000000000 " 000-007 oct 000000000000,000000000000 " 010-017 oct 000000000000,000000000000 " 020-027 oct 000000000000,000000000000 " 030-037 oct 000000000000,000000000000 " 040-047 oct 000000000000,000000000000 " 050-057 oct 000000000000,000000000000 " 060-067 oct 000000000000,000000000000 " 070-077 oct 000000000000,000000000000 " 100-107 oct 000000000000,000000000000 " 110-117 oct 000000000000,000000000000 " 120-127 oct 000000000000,000000000000 " 130-137 oct 000000000000,000000000000 " 140-147 oct 000000000000,000000000000 " 150-157 oct 000000000000,000000000000 " 160-167 oct 000000000000,000000000000 " 170-177 oct 200201202203,204205206207 " 200-207 oct 210211212213,214215216217 " 210-217 oct 220221222223,224225226227 " 220-227 oct 230231232233,234235236237 " 230-237 oct 240241242243,244245246247 " 240-247 oct 250251252253,254255256257 " 250-257 oct 260261262263,264265266267 " 260-267 oct 270271272273,274275276277 " 270-277 oct 300301302303,304305306307 " 300-307 oct 310311312313,314315316317 " 310-317 oct 320321322323,324325326327 " 320-327 oct 330331332333,334335336337 " 330-337 oct 340341342343,344345346347 " 340-347 oct 350351352353,354355356357 " 350-357 oct 360361362363,364365366367 " 360-367 oct 370371372373,374375376377 " 370-377 oct 400401402403,404405406407 " 400-407 oct 410411412413,414415416417 " 410-417 oct 420421422423,424425426427 " 420-427 oct 430431432433,434435436437 " 430-437 oct 440441442443,444445446447 " 440-447 oct 450451452453,454455456457 " 450-457 oct 460461462463,464465466467 " 460-467 oct 470471472473,474475476477 " 470-477 oct 500501502503,504505506507 " 500-507 oct 510511512513,514515516517 " 510-517 oct 520521522523,524525526527 " 520-527 oct 530531532533,534535536537 " 530-537 oct 540541542543,544545546547 " 540-547 oct 550551552553,554555556557 " 550-557 oct 560561562563,564565566567 " 560-567 oct 570571572573,574575576577 " 570-577 oct 600601602603,604605606607 " 600-607 oct 610611612613,614615616617 " 610-617 oct 620621622623,624625626627 " 620-627 oct 630631632633,634635636637 " 630-637 oct 640641642643,644645646647 " 640-647 oct 650651652653,654655656657 " 650-657 oct 660661662663,664665666667 " 660-667 oct 670671672673,674675676677 " 670-677 oct 700701702703,704705706707 " 700-707 oct 710711712713,714715716717 " 710-717 oct 720721722723,724725726727 " 720-727 oct 730731732733,734735736737 " 730-737 oct 740741742743,744745746747 " 740-747 oct 750751752753,754755756757 " 750-757 oct 760761762763,764765766767 " 760-767 oct 770771772773,774775776777 " 770-777 end  formline_.alm 11/11/89 1150.6r w 11/11/89 0803.9 500202 " ****************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright (c) 1987 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " ****************************************************** " Completely rewritten by B. L. Wolman on 2/3/74 to use EIS " Modified by R. K. Kanodia on 2/27/75 so that in " ASCII strings mlr would not move zero length sring. See the label mc. " Modified March 75 by Larry Johnson to fix several bugs and modify iteration logic " Modified July 75 by Larry Johnson to enable ^p to handle invalid pointers and to " implement array processing. " Modified August 1976 by Larry Johnson to implement if/then/else and " case features. " Modified May 1978 by Larry Johnson to support ^np, and to accept character " arguments for ^d,^f,^e,^o,^[,^vX etc. " Modified September 1978 by Larry Johnson to support all new pl1 and cobol " data types (primarily unsigned and 4-bit decimal). All argument " type processing was cleaned up to remove all internal coding " of data types. The include file std_descriptor_types is used. " Modified November 1978 by Larry Johnson to add ^t. The entire program was " changed to use a common procedure to move data to the output buffer. " Modified July 1979 by Larry Johnson to implement formline_$switch. This " allows formline_ to generate an unlimited amout of output to be " to be written to an I/O switch instead of using a fixed size buffer " supplied by the caller. " Modified December 1983 by Keith Loepere so i/o switch write works in bce. " Modified January 29 1984 by Tom Oke to utilize any_to_any_ re-write and " generic float decimal data type for extended exponent ranges. " call formline_(control,arg,prs,lrs,pad,alp) " control number of control string in arg list " arg number of first arg to control list in arg list " prs pointer to return string (INPUT) aligned " lrs length of return string in characters " pad one if padding required otherwise zero " alp arglist ptr -- optional (default alp is taken from preceding stack frame) " call formline_$switch(control,arg,iocbp,nl,code,alp) " control as above " arg as above " iocbp pointer to iocb of switch to write upon " nl one if newline required, otherwise 0 " code standard error code, returned by iox_$put_chars " alp as above, also optional name formline_ entry formline_ Primary entry, as called by ioa_ entry ge for output in GEBCD entry switch write output directly to I/O switch tempd argp,inptr,buffptr tempd pal,size,sizesp tempd t1,t2,t3,t4 temp precision,exponent EXPONENT MUST PRECEED TEMP1 tempd temp1(8),temp2(9),work(80) tempd save_inptr pointer to after ^ of current cmd temp save_inlen chars remaining after save_inptr temp save_x7.x5 temp storage in ext calls X7/du, X5/dl temp inlen temp dpd,length temp entry_switch -1 for switch, 0 for normal, 1 for ge temp default_precision,cur_arg,num_args,no_more_args temp movinh if >0 output movement inhibited by ^0( or bracket temp depth combined depth of parens and brackets temp iter_count(4) count of iterations - goes from negative to 0 temp iter_pointer(4) ptr to ctrl string where iteration started temp iter_length(4) chars remaining in control string at iterate start temp iter_cur_arg(4) position in argument list at start of iteration temp iter_argp(4) argument pointer when iteration started temp bracket_clause(4) current clause in brackets temp bracket_search(4) clause that should be performed temp brflags(4) flags for each level of paren and brackket bool brflags.movinh,400000 setting of movinh from previouss level bool brflags.iteration,200000 on means in parens, off means in brackets bool brflags.indefinite,100000 indefinite iteration - no count given temp array_in_progress + if in array, 0 if not, - if array checking inhibited temp array_mult multiplier (words or bits) to step thru array temp array_packed non-zero if packed array (array_mult in bits) temp array_desc description word is saved here temp array_length total elements in array (product of all dims) temp array_position current position in array temp v_not_done this switch is set if a ^vX was not evaluated because " the movinh switch prevented an arg fetch equ max_depth,4 combined max depth of parens and brackets include stack_frame include stack_header include eis_micro_ops include std_descriptor_types " Miscellaneous character definitions bool blank,040 bool minus,055 - bool nl,012 new line bool ht,011 horizontal tab bool ff,014 Form-feed/new-page bool rs,016 redshift bool bs,017 black shift bool zero,60 0 bool .,56 period bool plus,53 + bool star,52 * bool lp,50 ( bool rp,51 ) bool esc,136 ^ bool bar,174 | bool e,145 e bool v,166 v " Version II descriptor types bool packed,1 even nullptr: its -1,1 a null pointer ptrmask: oct 077777000077,777777077077 a pointer mask ge: save lda 1,dl tra form formline_: save lda 0,dl tra form switch: save lca 1,dl form: sta entry_switch save setting of output switch ldx2 ap|0 get current arglist header cmpx2 12,du six arguments? tnz no_alp No ldaq ap|12,* Yes, get arglist ptr eraq nullptr Is it null? anaq ptrmask mask out non-unique ptr bits tze no_alp it's null eppbp ap|12,* get ptr to arg 6 eppbp bp|0,* get arglist ptr supplied by caller tra *+3 no_alp: eppbp sp|stack_frame.prev_sp,* go back one stack frame eppbp bp|stack_frame.arg_ptr,* get arglist ptr from this frame spribp pal pointer to arg list ldaq bp|0 get header of arg list sta num_args save 2*number of args ldx6 num_args tnz args are there args szn entry_switch switch entry? tmi setup_output stz ap|8,* return null string return we are done args: cana =o10,dl account for space used for internal tze *+2 procedures in computing eaa 2,au sta dpd displacement to descriptor pointers " " get ptr to and length of control string " lca 1,dl load a -1 sta array_in_progress inhibit getarg from checking for arrays lda ap|2,* als 1 eax6 0,al tsx2 getarg stz array_in_progress we care about arrays now eax2 cstype we want char string tsx3 fillin tra done exit if not char string spri2 inptr save ptr and length stq inlen stz no_more_args init to "there are more args" lda ap|4,* get number of first arg sba 1,dl start 1 before 1st arg so "nextarg" will be the first als 1 multiply by 2 eax6 0,al and move to x6 stx6 cur_arg stz depth init nesting depth stz movinh output movement not inhibited " " set up output string " setup_output: stz out_moved number of characters stored lda 1,dl starting column sta out_column stz out_to_borrow szn entry_switch which entry? tpl not_switch epp2 ap|6,* ptr to switch argument spri2 put_chars_arglist+2 setup argument list for put_chars epp2 out_moved spri2 put_chars_arglist+6 epp2 ap|10,* address of error code spri2 put_chars_arglist+8 stz put_chars_arglist+8,* zero error code lda sys_info$service_system tnz call_iox epp3 put_chars_arglist+2,* -> bce_iocb_ptr epp3 pr3|0,* -> bce_iocb epp3 pr3|0,* -> io routine tra 2,ic call_iox: epp3 iox_$put_chars spri3 put_chars_codeptr lda =o000010000004 arglist header sta put_chars_arglist stz put_chars_arglist+1 ldq 256,dl use 256 character buffer in stack stq out_left stq out_size tra grow_stack not_switch: ldq ap|8,* set size stq out_left stq out_size szn entry_switch is this 6-bit mode? tze notge no, skip grow_stack: adq 3,dl convert char count to word count qrs 2 adq 15,dl make multiple of 16 anq =o777760,dl epp3 sb|stack_header.stack_end_ptr,* extend stack epp2 3|0,ql by enough to hold output spri2 sb|stack_header.stack_end_ptr spri2 sp|stack_frame.next_sp tra setout join common section notge: epp3 ap|6,* not 6-bit, get ptr to caller's buffer epp3 3|0,* setout: spri3 out_next spri3 buffptr save ptr to buffer ldx2 num_args tze done " " locate next ^ in control string " nextarg: tsx2 getargptr get ptr to next arg loop: epp2 inptr,* get ptr to input lda inlen tze no_control no ^ if zero length string scm (pr,rl),(du) look for a ^ desc9a 2|0,al vfd o9/esc,27/0 arg t1 ttf have_control " " no ^ found in rest of string, copy rest of control string into output " no_control: ldq inlen remaining length lda 0,dl tsx2 move_to_outbuf szn entry_switch $switch entry? tmi finish_switch yes, nothing to return ldq out_moved total characters generated stq ap|8,* return to caller szn ap|10,* padding requested? tze done no lda out_left move blanks to rest of buffer ldq 0,dl stz movinh don't let this be inhibited tsx2 move_to_outbuf done: szn entry_switch should we convert go GEBCD? tze thru no tpnz convert_ge finish_switch: szn ap|8,* need to append nl? tze skip_newline no stz movinh in case output inhibited epp2 new_line_char lda 1,dl ldq 1,dl tsx2 move_to_outbuf skip_newline: tsx2 put_chars_buffer tra thru convert_ge: ldq ap|8,* get number of chars (including padding) epp3 ap|6,* get ptr to beginning of caller's buffer epp3 3|0,* epp2 buffptr,* get ptr to 6-bit buffer mvt (pr,rl),(pr,rl) now translate to GEBCD in caller's buffer desc9a 2|0,ql desc6a 3|0,ql arg ascii_to_gebcd " thru: return and exit " " move string of characters before the ^ " have_control: ldq t1 get number of chars preceding the ^ tze hc1 no work to do if zero lda 0,dl tsx2 move_to_outbuf lca t1 -number of chars moved asa inlen s9bd 2|0,al bump ptr hc1: lca 1,dl account for the ^ s9bd 2|0,al asa inlen " " pick up size(s) from field " spri2 save_inptr save current location in control string lda inlen sta save_inlen tze bad_field must have some rescan_control: eax0 0 x0 counts chars in field stz v_not_done reset this switch mlr (0),(pr),fill(0) zero size,size+1,sizesp,sizesp+1 vfd 36/0 desc9a size,4*4 eax4 0 set for first size tsx5 getsize cmpc (pr,x0),(),fill(.) is char "."? desc9a 2|0,1 vfd 36/0 tnz check_key no, don't try for second size adx0 1,du account for the period sba 1,dl tze bad_field eax4 1 set for second size tsx5 getsize check_key: scm (0),(pr,x0) desc9a keys,key_length desc9a 2|0,1 arg t1 ttn bad_field error if key not known " " field ok, make sure we have an arg if we need one " lxl6 t1 get position in key string szn movinh is output inhibited by ^0(? tze arg_start no cmpx6 arg2-arg1,du see if this op is performed tmi arg_dummy no, setup dummy one cmpx6 arg4-arg1,du tmi argok always perform this arg_dummy: ldx6 dumtra-arg1,du set up dummy tra tra argok and go adjust pointers arg_start: cmpx6 arg3-arg1,du do we need an arg? tmi 3,ic no, skip check szn no_more_args tnz bad_field argok: adx0 1,du account for field sba 1,dl a9bd 2|0,0 spri2 inptr sta inlen tra *+1,6 dispatch arg1: tra put_control | tra put_control / tra put_control - tra put_control R tra put_control B tra put_control ^ tra put_blanks x tra skip s tra tab_to_column t arg2: tra lp_iterate ( tra rp_iterate ) tra semi_colon ; tra right_bracket ] arg3: tra left_bracket [ arg4: tra put_chars a tra put_decimal d tra put_decimal i tra put_octal o tra put_pointer p tra put_octal_word w tra put_float f tra put_exponential e tra put_acc A tra put_bits b dumtra: tra loop dummy tra " The order of the above tra's obviously must correspond to the string " of keys below. New control types must be positioned so that " the following relations hold: " arg1<=X source indicates pad with blanks) " pr2 -> source move_to_outbuf: szn movinh is output inhibited? tnz 0,2 yes, just return stx2 out_save_x2 spri2 out_save_pr2 stz newline_moved staq move_temp sba move_temp+1 compute amount of padding requested tpl 2,ic lda 0,dl none sta move_padding save for later cmpq 0,dl any source characters? tze move_source_done no lda out_to_borrow do we need to borrow any leading spaces? tze move_the_stuff no cmpa move_temp+1 need to borrow more that source length? tmi 2,ic no lda move_temp+1 just try for source length epp3 pl1_operators_$tct_octal_040 tct (pr,rl) desc9a 2|0,al arg 3|0 arg tct_result ttn 3,ic source is all blank lda tct_result get blank count ana =o777777777 cmpa 0,dl any leading blanks? tze nothing_to_borrow sta move_temp amount borrowed sbq move_temp adjust source length a9bd 2|0,al adjust source pointer neg asa out_to_borrow less to borrow now cmpq 0,dl source exhausted? tze move_source_done yes nothing_to_borrow: stz out_to_borrow tried as hard as possible move_the_stuff: stq left_to_move cmpq out_left will source fit in buffer? tmi 2,ic yes ldq out_left use only what fits epp3 out_next,* get current pointer mlr (pr,rl),(pr,rl) desc9a 2|0,ql desc9a 3|0,ql a9bd 3|0,ql adjust output pointer spri3 out_next epp3 2|0 compute adjust input pointer a9bd 3|0,ql spri3 rest_of_source asq out_moved accumulate characters moved stq move_temp lca move_temp asa out_left space left in output buffer asa left_to_move " scan output to adjust column position out_scan: cmpq 0,dl any characters? tze check_more_to_move no tct (pr,rl) look for interesting characters desc9a 2|0,ql arg out_scan_table arg tct_result ttn out_normal all regular vanilla characters lda tct_result get count of plain characters before interesting one ana =o777777777 asa out_column update column position for normal characters ada 1,dl char count including interesting one a9bd 2|0,al sta move_temp sbq move_temp remaining characters to scan lda tct_result arl 27 isolate tct result code tra *,al branch based on character found tra out_newline tra out_backspace tra out_tab out_newline: lda 1,dl set column back to 1 sta out_column aos newline_moved remember this tra out_scan out_backspace: lca 1,dl back up one column asa out_column tra out_scan out_tab: stq move_temp ldq out_column get current column adq 9,dl compute next tab stop div 10,dl mpy 10,dl adq 1,dl stq out_column ldq move_temp tra out_scan out_normal: asq out_column regular characters take 1 column each check_more_to_move: szn entry_switch switch entry? tpl move_source_done no szn left_to_move more stuff? tze move_source_done no tsx2 put_chars_buffer dump what we have ldq left_to_move epp2 rest_of_source,* cmpq out_size very big string to write? tmoz move_the_stuff no, routine stuff tsx2 put_chars_string write it all in one iox_ call ldqc left_to_move length to scan tra out_scan must scan to keep column accurate move_source_done: szn out_left buffer full? tnz check_padding no szn entry_switch tpl done not switch entry tsx2 put_chars_buffer check_padding: lda move_padding any padding needed at end? tze move_output_return no cmpa out_to_borrow see if some of these can be borrowed tmi move_borrows_all we should steal them all sba out_to_borrow reduce by needed columns stz out_to_borrow tra move_the_padding move_borrows_all: neg asa out_to_borrow less to borrow later tra move_output_return move_the_padding: sta left_to_move cmpa out_left room to do it all? tmi 2,ic yes lda out_left epp3 out_next,* mlr (),(pr,rl),fill(blank) desc9a 0,0 desc9a 3|0,al a9bd 3|0,al spri3 out_next asa out_column blanks take one column each asa out_moved neg asa out_left asa left_to_move tze move_output_return szn entry_switch pswitch entry? tpl move_output_return no tsx2 put_chars_buffer lda left_to_move tra move_the_padding move_output_return: szn out_left is buffer fill? tpnz move_output_exit no szn entry_switch switch entry? tpl done no tsx2 put_chars_buffer move_output_exit: epp2 out_save_pr2,* ldx2 out_save_x2 tra 0,2 return tempd move_temp,out_save_pr2,rest_of_source temp move_padding,tct_result,save_out_column,newline_moved tempd out_next,put_chars_arglist(5),put_chars_codeptr temp out_column,out_moved,out_left,out_to_borrow,out_size temp out_save_x2,left_to_move " " subroutine to dump and reset the buffer put_chars_buffer: szn out_moved tze 0,2 epp3 buffptr put_chars_join: spri3 put_chars_arglist+4 call put_chars_codeptr,*(put_chars_arglist) szn put_chars_arglist+8,* error? tnz thru yes, quit stz out_moved rest all buffer variables epp3 buffptr,* spri3 out_next ldq out_size stq out_left tra 0,2 " enter here to write a long string " q = length " pr2 -> data put_chars_string: stq out_moved spri2 out_next epp3 out_next tra put_chars_join " " routine to get ptr to next argument " getargptr: szn array_in_progress are we stepping thru an array? tnz get_next_array yes advance_cur_arg: ldx6 cur_arg adlx6 2,du update arg counter stx6 cur_arg cmpx6 num_args are there any more? tmoz getarg yes aos no_more_args no more, say so epp2 nullptr,* set null argp so not same as last time spri2 argp tra 0,2 and return getarg: eppbp pal,*6 get ptr to arg ptr ldx6 dpd get descriptor offset lda bp|0,6* get the descriptor tmi ga2 skip if Version 2 " process version 1 desciriptor lrl 18 save length field arl 3 isolate type field cmpa =16,dl convert to Version 2 types tmoz 4,ic cmpa =32,dl tpl ga3 sba =16,dl anq =o77777,du erase "decimal" bit cmpa 5,dl is this arithmetic data tpl 2,ic no, skip ldq v1prec-1,al yes, get normal v1 precision tra ga1 ga3: cmpa =514,dl tnz 3,ic lda =17,dl tra ga1 lda cvtype-518,al ga1: als 11 make it look like Version 2 lls 18 " process version 2 descriptor ga2: cana =o001700,du is this an array? tnz begin_array yes, special processing required ga5: eppbp bp|0,* get pointer to argument spribp argp and save ga4: lrl 24 save 24 bit length field qrl 12 stq length arl 4 isolate type field ana =o177,dl eax7 0,al and leave in x7 tra 0,2 all done " " come here to begin the processing or an array. The extents of the array " must be detemined and the increment (words or bits) to step thru the array " must be found. begin_array: sta array_desc save a copy of the descriptor spri3 t4 save this pointer so i can use it epp3 bp|0,6* this points to first word of descriptor ldq 3|3 get multiplier (may be words or bits) stq array_mult and save stz array_packed set switch to un-packed array cana =o002000,du test for packed array tze 2,ic it is not packed aos array_packed this means array_mult is bits, not words arl 24 get numbers of dims in al ana =o17,dl just that number eax7 0,al number of dims to x7 lda 1,dl sta array_length initialize array length sta array_position and position array_calc: ldq 3|2 upper bound of this dimension sbq 3|1 minus lower dimension adq 1,dl +1 gives number of elements mpy array_length total length is product of dims stq array_length epp3 3|3 step to next desc sblx7 1,du count dimension processed tnz array_calc loop if more epp3 t4,* restore the pointer lda array_desc restore origional descriptor aos array_in_progress now processing an array tra ga5 go setup type and length " " come here to step to next element of an array during array processing get_next_array: lda array_position current loc ada 1,dl advance by 1 cmpa array_length check for end tmoz 3,ic not past end stz array_in_progress done array processing tra advance_cur_arg go get next arg sta array_position store updated position lda array_mult increment to be added to pointer (words or bits) eppbp argp,* get current pointdr szn array_packed is this a packed array? tnz 3,ic yes eppbp bp|0,al do word addition tra 2,ic abd bp|0,al do bit adjustment spribp argp store adjusted pointer lda array_desc get origional descriptor tra ga4 go process length and type " " table to convert some Version I descriptor types to Version I types " cvtype: dec 18,19,21,20,22,17,18,19,21,20,22 " " normal precisions for v1 data " v1prec: dec 35b17,71b17,27b17,63b17 " " routine to get ptr to and length of string in arg list " x2 points at table of either char types or bit types " return 0,3 if not bit|char and return 1,3 if ok " fillin: ldq length get length epp2 argp,* get ptr to argument eaa 0,7 copy type codes ana =o777776,du erase packed bit tze 1,3 allow 0 type because of pl1 bug in returns(char(*)) cmpa 0,2 is it varying tze fill_varying yes, skip cmpa 1,2 is this non-varying tze 1,3 yes, return tra 0,3 no, error fill_varying: " the Q now holds the declared max length cmpq bp|-1 if the current length is greater than the max tmi 1,3 then return the max length ldq bp|-1 otherwise pick up the current length tpl 1,3 check for garbage (negative number). return if ok ldq length use max length. negative number causes blowups tra 1,3 return " cstype: vfd 17/varying_char_dtype char varying vfd 17/char_dtype char non-varying " bstype: vfd 17/varying_bit_dtype bit varying vfd 17/bit_dtype bit non-varying " test arg for numeric. skip return if it is test_numeric: eaa 0,7 get arg type in a ars 18+1 align and drop packed bit sba 1,dl bit offsets start at 0 cmpb (al),(),fill(0) test for numeric argument descb numeric_dtype_mask,1 descb 0,0 tnz 1,3 it is numeric tra 0,3 it isn't " " subroutine to get size from control field " entered with pr2 & x0 pointing at next char of input " remaining number of chars in input in a " x4 = 0 | 1 " this routine transfers to bad_field if string ends early " or if arg is not available for variable size specification " getsize: cmpc (pr,x0),(),fill(v) is this "v" desc9a 2|0,1 vfd 36/0 tze varsize yes, size given by variable in arglist " " not variable, look for string of digits " eax1 0 init digit count eax2 0,0 remember where string starts nextdigit: scm (),(pr,x0) is this character a digit desc9a digits,10 desc9a 2|0,1 arg t1 ttn getsize1 not a digit, skip adx1 1,du bump digit count adx0 1,du account for the digit sba 1,dl tze bad_field tra nextdigit look for another digit " bit_alpha: digits: aci "0123456789ABCDEF" " " have string of 0 or more digits " getsize1: cmpx1 0,du do we have any digits tze 0,5 no, return stc1 sizesp,4 yes, remember size specified dtb (pr,rl,x2),(pr) convert digits to binary desc9ns 2|0,x1,0 desc9a t1,4 ldq t1 store size stq size,4 tra 0,5 and return " " size is given by variable " varsize: szn movinh is output inhibited by ^0(? tze varsize1 no aos v_not_done set flag to remember this tra varsize2 varsize1: szn no_more_args error if no arg to be used tnz bad_field stc1 sizesp,4 remember size specified spri2 work save some stuff during calls which follow sta work+2 stx5 work+3 tsx5 load_fixed_bin get value of arg tra bad_field not numeric lrs 0 test for negative tpl 2,ic "normalize" it lrl 72 qrs 0 tpl 2,ic ldq 0,dl stq size,4 save size for caller tsx2 getargptr step to next arg ldx5 work+3 restore saved stuff lda work+2 epp2 work,* varsize2: adx0 1,du account for the v sba 1,dl tra 0,5 and return " out_scan_table: oct 000000000000,000000000000 000 - 007 oct 002003001001,001001000000 010 - 017 dup 124 020 - 777 oct 0 dupend " " table to convert ascii to gebcd " ascii_to_gebcd: oct 020020020020,020020020020 000 oct 020020020020,020020020020 010 oct 020020020020,020020020020 020 oct 020020020020,020020020020 030 oct 020020076013,053074032057 040 oct 035055054060,073052033061 050 oct 000001002003,004005006007 060 oct 010011015056,036075016020 070 oct 014021022023,024025026027 100 oct 030031041042,043044045046 110 oct 047050051062,063064065066 120 oct 067070071012,037034020052 130 oct 037021022023,024025026027 140 oct 030031041042,043044045046 150 oct 047050051062,063064065066 160 oct 067070071020,040020020020 170 " " edit sequences " int_edit: vfd 9/lte+3,9/blank,9/mfls,9/mfls,9/mfls,9/mfls " oct_edit6: vfd 9/mvzb+5,9/mvc+1 " oct_edit24: vfd 9/mvzb,9/mvzb+7,9/mvc+1 " float_edit: vfd 9/lte+3,9/blank,9/mfls+1,9/insb+7,9/mvc,9/mvc,9/mvc,9/mvc " exp_edit: vfd 9/lte+3,9/blank,9/mfls+9,9/enf,9/mvc+1 end  fort_math_ops_.alm 11/11/89 1150.6rew 11/11/89 0804.6 23229 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1984 * " * * " ****************************************** name fort_math_ops_ include stack_frame equ complex,56 equ temp_pt,40 macro define operator,store_inst,arg_count,approximator segdef &1 &1: &2 pr6|complex tsx0 call_&3_arg_op epp5 &4 &end define cabs,staq,1,|[cabs_] define ccos,staq,1,|[ccos_] define cexp,staq,1,|[cexp_] define clog,staq,1,|[clog_] define cmpx_p_cmpx,staq,2,|[cxp2_] define cosh,dfst,1,|[cosh_] define csin,staq,1,|[csin_] define csqrt,staq,1,|[csqrt_] define dcosh,dfst,1,|[dcosh_] define dmod,dfst,2,|[dmod_] define dsinh,dfst,1,|[dsinh_] define dtanh,dfst,1,|[dtanh_] define sinh,dfst,1,|[sinh_] define tanh,dfst,1,|[tanh_] define hfp_cabs,staq,1,|[cabs_] define hfp_ccos,staq,1,|[ccos_] define hfp_cexp,staq,1,|[cexp_] define hfp_clog,staq,1,|[clog_] define hfp_cmpx_p_cmpx,staq,2,|[cxp2_] define hfp_cosh,dfst,1,|[cosh_] define hfp_csin,staq,1,|[csin_] define hfp_csqrt,staq,1,|[csqrt_] define hfp_dcosh,dfst,1,|[dcosh_] define hfp_dmod,dfst,2,|[dmod_] define hfp_dsinh,dfst,1,|[dsinh_] define hfp_dtanh,dfst,1,|[dtanh_] define hfp_sinh,dfst,1,|[sinh_] define hfp_tanh,dfst,1,|[tanh_] call_1_arg_op: spri3 pr6|stack_frame.return_ptr save return address sti pr6|stack_frame.return_ptr+1 save indicators epp0 pr2|0 build arg list: fld 2*2048,dl staq pr0|0 set arg count epp7 pr6|complex spri7 pr0|2 set arg address epp7 pr6|temp_pt spri7 pr0|4 set result address tsx1 |[get_our_lp] xec 0,x0 PR5 = address of approximator call6 pr5|0 invoke approximator call_2_arg_op: spri3 pr6|stack_frame.return_ptr save return address sti pr6|stack_frame.return_ptr+1 save indicators epp0 pr2|0 build arg list: fld 3*2048,dl staq pr0|0 set arg count epp7 pr6|complex spri7 pr0|2 set 1st arg address spri1 pr0|4 set 2nd arg address epp7 pr6|temp_pt spri7 pr0|6 set result address tsx1 |[get_our_lp] xec 0,x0 PR5 = address of approximator call6 pr5|0 invoke approximator end  hfp_to_bfp_.alm 11/11/89 1150.6rew 11/11/89 0804.2 10737 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1983 * " * * " ****************************************** " Function: Convert a Hexadecimal Floating Point number to the " nearest Binary Floating Point number. " " Entry: EAQ = HFP number to convert. " PR2 = address of 1 word work area. " PR3 = return address. " " Exit: EAQ = BFP equivalent of original HFP number. " Written 20 Dec 83 by HH. segdef hfp_to_bfp_ equ exponent,0 equ indicators,0 hfp_to_bfp_: sti pr2|indicators save indicators ldi =o4000,dl mask overflows and enter BFP mode ste pr2|exponent fno tze return_zero ade pr2|exponent teo return_max_bfp teu return_zero ade pr2|exponent teo return_max_bfp teu return_zero ade pr2|exponent teo return_max_bfp teu return_zero ldi pr2|indicators restore indicators tra pr3|0 return return_max_bfp: ldi pr2|indicators restore indicators lde =o376000,du era =o400000,du lrs 72 era =o400000,du tra pr3|0 return return_zero: ldi pr2|indicators restore indicators fld =0.0,du load "normalized" floating zero tra pr3|0 return end  integer_power_integer_.alm 11/11/89 1150.6rew 11/11/89 0805.5 21483 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " i ** j for integer i and j " ldq i " epp1 j " epp2 work " tsp3 entry " " Modified 770412 by PG to fix 1602 (indicators not reset before rpd) " Modified 840123 by HH to work in both BFP and HFP modes. " segdef integer_power_integer_ " equ i,0 " integer_power_integer_: lda 1|0 get j stq 2|i cmpq 0,dl is i = 0 tze test cmpa 0,dl is j = 0 tze unity j = 0 => answer = 1 tmi clrt j < 0, test i tsx1 clrt+1 test i for -1 cmpa 36,dl check for exponent too bit tpl bigexp too big, unless abs(i) = 1 or 0 sba 1,dl tze done j = i, answer = i als 10 shift tally into position for rpdx: C(X0)0,7 eax0 5,al set rpdx to terminate on all overflows or carry eax1 i eax2 35 lls 36 teo 1,ic clear exponent overflow indicator tov 1,ic clear overflow indicator odd rpdx 0,0 repeat until overflow, carry, or tally runout mpf 2|0,1 lls 0,2 trc err3 lrl 36 result to q register done: adq 0,dl set indicators tra 3|0 " err3: lda 1|0 get j, if j even, ans is o377...76 ldq maxno cana 1,dl if i is +, ans is o377...76 tze txtp1 if j is odd & i is (-1), ans is o400...02 szn 2|i tpl txtp1 lcq maxno txtp1: stq 2|i err, save value to return ldq 60,dl txtp2: tsx0 |[call_math_error_] ldq 2|i tra 3|0 " bigexp: ldq 7,dl bigexp1: tsx0 |[call_math_error_] ldq maxno tra 3|0 " err1: stz 2|i 0 ** 0 ldq 1,dl tra txtp2 " unity: ldq 1,dl tra 3|0 " clear: ldq 0,dl return 0 tra 3|0 " clrt: eax1 clear cmpq 1,dl j < 0, if abs(i) > 1, ans = 0 tze unity cmpq minus1 tnz 0,1 cana 1,dl i = -1, ans = 1 if j even tze unity lcq 1,dl tra done " test: cmpa 0,dl i = 0, if j = 0 error tze err1 tpl clear ldq 2,dl tra bigexp1 " maxno: oct 377777777776 avoid "noise" word minus1: dec -1 end  ioa_.pl1 11/11/89 1150.6r w 11/11/89 0805.5 97596 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Initially coded in May 1972 by V. Voydock */ /* Modified June 1974 by B. Wolman to not pad buffer */ /* Last modified: 07/28/77 by S. Webber to merge with rest_of_ioa_ 10/28/77 by M. R. Jordan to correct call to ios_signal_ ,signalling of ioa_error, and padding of varying return strings. Modified August 1979 by Larry Johnson for unlimited ioa output. Modified November 1981 by Benson I. Margulies for better error message and correct entrypoint declarations. Modified September 1982 by BIM for Bootload Multics. Modified August 1983 by Keith Loepere for new bce switches. Modified 840309 to call arg_list_ptr_ instead of cu_$arg_list_ptr... -E. A. Ranzenbach */ /****^ HISTORY COMMENTS: 1) change(85-09-19,Coren), approve(85-09-19,MCR7266), audit(85-09-24,Margolin), install(86-02-20,MR12.0-1023): Add general_rs_control_string entry. END HISTORY COMMENTS */ %page; /* format: style2 */ ioa_: procedure options (variable); /* This procedure is the PL/I portion of the standard Multics output string formatting routine; it provides varous interfaces to formline_, which is the ALM portion. */ /* Parameters */ dcl arg char (*); dcl aiocbp ptr; dcl a_arglist_ptr ptr; dcl a_cs_argno fixed bin; dcl a_ff_argno fixed bin; dcl a_control_string char (*); dcl retstring char (*); dcl rlen fixed bin (21); dcl padsw bit (1) aligned; dcl nlsw bit (1) aligned; /* Automatic */ dcl buffer_ptr ptr; dcl buffer_length fixed bin (21); dcl pad fixed bin; dcl cs_argno fixed bin; dcl ff_argno fixed bin; dcl switch_name char (32); dcl iocbp ptr; dcl code fixed bin (35); dcl number_of_args fixed bin; dcl arg_list_arg_count fixed bin; dcl orig_arg_list_ptr pointer; dcl orig_ff_argno fixed bin; dcl system_areap ptr; dcl orig_arg fixed bin; dcl this_arg fixed bin; dcl cs_entry bit (1); dcl output_length fixed bin (21); dcl rs_type fixed bin; dcl arg_list_ptr ptr; dcl my_arg_list_ptr ptr; dcl add_nl bit (1) aligned; /* Builtins */ dcl (addr, addrel, bin, currentsize, length, min, null, string, substr) builtin; dcl cleanup condition; /* Static */ dcl nl char (1) internal static options (constant) initial (" "); /* New line char */ /* Based */ dcl system_area area (1024) based (system_areap); dcl 1 rs_arg_list based (arg_list_ptr), 2 header fixed bin (71), 2 control_string_ptr ptr, 2 return_string_ptr ptr, 2 return_len_ptr ptr; dcl return_string char (131071) based (buffer_ptr); dcl return_string_length fixed bin based (rs_arg_list.return_len_ptr); dcl varying_string_length fixed bin based (addrel (buffer_ptr, -1)); /* External */ dcl iox_$user_output ext static ptr; /* Entries */ dcl get_system_free_area_ entry () returns (ptr); dcl iox_signal_ entry (ptr, fixed bin (35)); dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl arg_list_ptr_ entry returns (ptr); dcl formline_ entry (fixed bin, fixed bin, ptr, fixed bin (21), fixed bin, ptr); dcl formline_$switch entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin (35)); dcl signal_ entry () options (variable); dcl sys_info$service_system bit (1) aligned external; dcl bce_data$put_chars external entry (ptr, ptr, fixed bin, fixed bin (35)) variable; add_nl = "1"b; go to COMMON; nnl: entry options (variable); add_nl = "0"b; COMMON: if sys_info$service_system then iocbp = iox_$user_output; else iocbp = addr (bce_data$put_chars); call formline_$switch (1, 2, iocbp, bin (add_nl), code); if code ^= 0 then do; if ^sys_info$service_system then return; call iox_signal_ (iocbp, code); go to COMMON; end; return; /* The following entries return a formatted string */ rs: entry options (variable); add_nl = "1"b; pad = 1; goto COMMON_RS; rsnnl: entry options (variable); add_nl = "0"b; pad = 1; goto COMMON_RS; rsnp: entry options (variable); add_nl = "1"b; pad = 0; goto COMMON_RS; rsnpnnl: entry options (variable); add_nl = "0"b; pad = 0; goto COMMON_RS; COMMON_RS: arg_list_ptr = arg_list_ptr_ (); buffer_ptr = rs_arg_list.return_string_ptr; rs_type = GET_RETURN_TYPE (); if rs_type = varying_char_dtype then pad = 0; else if rs_type ^= char_dtype then call signal_error; call work_in_buffer (1, 4, pad, arg_list_ptr); return_string_length = output_length; if rs_type = varying_char_dtype then varying_string_length = output_length; return; %page; /* The following entry is the generalized entry for returning formatted strings */ general_rs: entry (a_arglist_ptr, a_cs_argno, a_ff_argno, retstring, rlen, padsw, nlsw); arg_list_ptr = a_arglist_ptr; cs_argno = a_cs_argno; ff_argno = a_ff_argno; cs_entry = "0"b; go to GENERAL_RS_JOIN; /* The following entry is like general_rs except that the control string is passed explicitly, rather than being in the referenced argument list */ general_rs_control_string: entry (a_arglist_ptr, a_control_string, a_ff_argno, retstring, rlen, padsw, nlsw); orig_arg_list_ptr = a_arglist_ptr; orig_ff_argno = a_ff_argno; cs_argno = -1; cs_entry = "1"b; GENERAL_RS_JOIN: buffer_ptr = addr (retstring); buffer_length = length (retstring); add_nl = nlsw; if cs_entry /* control string supplied */ then do; /* We have to build a copy of the argument list (for passing to formline_) that contains the control string and the data args. */ number_of_args = orig_arg_list_ptr -> arg_list.arg_count; system_areap = get_system_free_area_ (); arg_list_ptr = null (); on cleanup begin; if arg_list_ptr ^= null () then free arg_list_ptr -> arg_list; end; arg_list_arg_count = number_of_args - orig_ff_argno + 2; /* the original data args, + 1 for the control string */ allocate arg_list in (system_area) set (arg_list_ptr); arg_list_ptr -> arg_list.arg_count = arg_list_arg_count; arg_list_ptr -> arg_list.pad1 = "0"b; arg_list_ptr -> arg_list.call_type = Interseg_call_type; arg_list_ptr -> arg_list.desc_count = arg_list_arg_count; arg_list_ptr -> arg_list.pad2 = "0"b; arg_list_ptr -> arg_list.arg_ptrs (1) = addr (a_control_string); orig_arg = orig_ff_argno; do this_arg = 2 to arg_list_arg_count; /* copy the other arg pointers */ arg_list_ptr -> arg_list.arg_ptrs (this_arg) = orig_arg_list_ptr -> arg_list.arg_ptrs (orig_arg); orig_arg = orig_arg + 1; end; /* Now copy the descriptor for the control string from *this entry's* argument list */ my_arg_list_ptr = arg_list_ptr_ (); arg_list_ptr -> arg_list.desc_ptrs (1) = my_arg_list_ptr -> arg_list.desc_ptrs (2); /* Now copy in the other descriptor pointers */ orig_arg = orig_ff_argno; if orig_arg_list_ptr -> arg_list.call_type = Envptr_supplied_call_type then do this_arg = 2 to arg_list_arg_count; arg_list_ptr -> arg_list.desc_ptrs (this_arg) = orig_arg_list_ptr -> arg_list_with_envptr.desc_ptrs (orig_arg); orig_arg = orig_arg + 1; end; else do this_arg = 2 to arg_list_arg_count; arg_list_ptr -> arg_list.desc_ptrs (this_arg) = orig_arg_list_ptr -> arg_list.desc_ptrs (orig_arg); orig_arg = orig_arg + 1; end; cs_argno = 1; ff_argno = 2; end; call work_in_buffer (cs_argno, ff_argno, bin (padsw, 1), arg_list_ptr); rlen = output_length; if cs_entry then free arg_list_ptr -> arg_list; return; %page; /* The following entries use an I/O switch or switch name as target */ ioa_switch: entry (aiocbp); add_nl = "1"b; iocbp = aiocbp; goto FOUND_SWITCH_PTR; ioa_switch_nnl: entry (aiocbp); add_nl = "0"b; iocbp = aiocbp; goto FOUND_SWITCH_PTR; ioa_stream: entry (arg); add_nl = "1"b; goto FIND_SWITCH_PTR; ioa_stream_nnl: entry (arg); add_nl = "0"b; goto FIND_SWITCH_PTR; FIND_SWITCH_PTR: switch_name = arg; if sys_info$service_system then call iox_$find_iocb (switch_name, iocbp, (0)); else iocbp = addr (bce_data$put_chars); FOUND_SWITCH_PTR: call formline_$switch (2, 3, iocbp, bin (add_nl), code); if code ^= 0 then do; if ^sys_info$service_system then return; call iox_signal_ (iocbp, code); go to FOUND_SWITCH_PTR; end; return; %page; /* Subroutine to do the actual work when the data is returned to the callers buffer */ work_in_buffer: proc (cs_arg_no, ff_arg_no, pad, ap); dcl (cs_arg_no, ff_arg_no, pad) fixed bin; dcl ap ptr; output_length = buffer_length; call formline_ (cs_arg_no, ff_arg_no, buffer_ptr, output_length, pad, ap); if add_nl then do; output_length = min (output_length + 1, buffer_length); substr (return_string, output_length, 1) = nl; end; return; end work_in_buffer; signal_error: procedure; %include condition_info_header; declare 1 CI aligned like condition_info_header; declare error_table_$bad_arg external static fixed bin (35); CI.length = currentsize (CI); CI.version = 1; string (CI.action_flags) = ""b; CI.cant_restart = "1"b; CI.info_string = "A return string argument to an ioa_$rs* entrypoint was not a character or varying character string."; CI.status_code = error_table_$bad_arg; call signal_ ("ioa_error", null (), addr (CI)); return; end signal_error; /* This procedure sets buffer_length as a side effect */ GET_RETURN_TYPE: procedure returns (fixed bin); if arg_list_ptr -> arg_list.desc_count = 0 then return (-1); if arg_list_ptr -> arg_list.call_type = Interseg_call_type then arg_descriptor_ptr = arg_list_ptr -> arg_list.desc_ptrs (2); else arg_descriptor_ptr = arg_list_ptr -> arg_list_with_envptr.desc_ptrs (2); buffer_length = arg_descriptor.size; return (arg_descriptor.type); end GET_RETURN_TYPE; %page; %include arg_descriptor; %page; %include arg_list; %page; %include std_descriptor_types; end ioa_;  logarithm_.alm 11/11/89 1150.6rew 11/11/89 0805.2 58014 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name logarithm_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7naf'. " " Function: Calculates the logarithm functions log_base_e(x), log_base_2(x), " and log_base_10(x) to single precision accuracy in either BFP or " HFP mode. " " Entry: through the appropriately named entry point with: " EAQ = the argument x. " PR2 = the address of a 14 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired logarithm " " Uses: X0, X1, X3 " X0 = saves a return address from call_math_error_ " or saves a return address from log2 " X1 = saves a return address from part_log2_of_ratio " X3 = address of second argument for part_log2_of_ratio segref math_constants_,hfp_log_10_of_2,hfp_log_e_of_2,log_10_of_2,log_e_of_2,max_value equ xe,0 equ xm,2 equ bias,4 equ shift,6 equ x_plus_y,8 equ z,10 equ zz,12 segdef log_base_10_,hfp_log_base_10_ segdef log_base_2_,hfp_log_base_2_ segdef log_base_e_,hfp_log_base_e_ log_base_10_: tsx0 log2 " calculate log2 (x) dfmp log_10_of_2 " EAQ := log_10_of_2 * log2 (x) frd 0 tra pr3|0 " return to caller log_base_2_: tsx0 log2 " calculate log2 (x) frd 0 tra pr3|0 " return to caller log_base_e_: tsx0 log2 " calculate log2 (x) dfmp log_e_of_2 " EAQ := log_e_of_2 * log2 (x) frd 0 tra pr3|0 " return to caller hfp_log_base_10_: tsx0 hfp_log2 " calculate log2 (x) dfmp hfp_log_10_of_2 " EAQ := hfp_log_10_of_2 * log2 (x) frd 0 tra pr3|0 " return to caller hfp_log_base_2_: tsx0 hfp_log2 " calculate log2 (x) frd 0 tra pr3|0 " return to caller hfp_log_base_e_: tsx0 hfp_log2 " calculate log2 (x) dfmp hfp_log_e_of_2 " EAQ := hfp_log_e_of_2 * log2 (x) frd 0 tra pr3|0 " return to caller log_of_negative: ldq 10,dl tsx0 |[call_math_error_] fld max_value fneg 0 tra pr3|0 log_of_zero: ldq 9,dl tsx0 |[call_math_error_] fld max_value fneg 0 tra pr3|0 log2: fad =0.0,du " normalize input and set indicators tmi log_of_negative tze log_of_zero fcmp square_root_two " check for x in the range [.707,1.414] tpl 6,ic fcmp square_root_half tmi 4,ic " if square_root_half >= x & x <= square_root_two eax3 one " X3 := addr (1.0) eax1 0,x0 " copy return address tra part_log2_of_ratio " result = part_log2_of_ratio (x, 1) " else ste pr2|xe " store addr (x) -> expon in xe lde =0,du " addr (xm) -> expon = 0 fst pr2|xm lda pr2|xe " A := 8/xe,10/0,18/garbage lrs 72-18 " AQ := 62/xe,10/0 lde =61b25,du " EAQ := unnormalized float(xe) fsb =0.5,du " EAQ := float(xe) - 0.5 fst pr2|bias fld pr2|xm eax3 square_root_half " X3 := addr (square_root_half) tsx1 part_log2_of_ratio " EAQ := part_log2_of_ratio (x, square_root_half) fad pr2|bias " EAQ := part_log2_of_ratio (x, square_root_half) + bias (= log2(x)) tra 0,x0 " return result " part_log2_of_ratio (x, y) calculates log2(x/y), where x/y is in the " range [0.5*2**0.5, 2**0.5], given x in the EAQ and the address of y in X3. part_log2_of_ratio: dfad 0,x3 " EAQ := x + y dfst pr2|x_plus_y dfsb 0,x3 " EAQ := x dfsb 0,x3 " EAQ := x - y dfdv pr2|x_plus_y " calculate z = (x - y) / (x + y) fcmg eps tpnz 3,ic " if abs(z) < 4.1968417d-11 dfmp p0 " EAQ := z * p0 tra 0,x1 " return to caller dfst pr2|z fmp pr2|z " calculate zz = z*z fst pr2|zz " calculate p(zz) fmp p3 dfad p2 fmp pr2|zz dfad p1 fmp pr2|zz dfad p0 dfmp pr2|z " calculate z*p(zz) tra 0,x1 " return to caller hfp_log2: fad =0.0,du " normalize input and set indicators tmi log_of_negative tze log_of_zero fcmp hfp_square_root_two " check for x in the range [.707,1.414] tpl 6,ic fcmp hfp_square_root_half tmi 4,ic " if square_root_half >= x & x <= square_root_two eax3 hfp_one " X3 := addr (1.0) eax1 0,x0 " copy return address tra hfp_part_log2_of_ratio " result = hfp_part_log2_of_ratio (x, 1) " else ste pr2|xe " store addr (x) -> expon in xe lde =0,du " addr (xm) -> expon = 0 " EAQ := xm stz pr2|shift " shift := 0 even do_while: " do while (xm < 0.5) fcmp =0.5,du tpl end_do_while lls 1 " xm = 2*xm aos pr2|shift " shift := shift + 1 tra do_while " end do_while end_do_while: fst pr2|xm lda pr2|xe " A := 8/xe,10/0,18/garbage lrs 36-10 " AQ := 36/4*xe,8/0,28/garbage sba pr2|shift " AQ := 36/4*xe-shift,8/0,28/garbage lrs 29 " AQ := 65/4*xe-shift,7/0 lde =16b25,du " EAQ := unnormalized float(4*xe-shift) fsb =0.5,du " EAQ := float(4*xe-shift)-0.5 fst pr2|bias fld pr2|xm eax3 hfp_square_root_half " X3 := addr (square_root_half) tsx1 hfp_part_log2_of_ratio " EAQ := hfp_part_log2_of_ratio (x, square_root_half) fad pr2|bias " EAQ := hfp_part_log2_of_ratio (x, square_root_half) + bias tra 0,x0 " return result " hfp_part_log2_of_ratio (x, y) calculates log2(x/y), where x/y is in the " range [0.5*2**0.5, 2**0.5], given x in the EAQ and the address of y in X3. hfp_part_log2_of_ratio: dfad 0,x3 " EAQ := x + y dfst pr2|x_plus_y dfsb 0,x3 " EAQ := x dfsb 0,x3 " EAQ := x - y dfdv pr2|x_plus_y " calculate z = (x - y) / (x + y) fcmg hfp_eps tpnz 3,ic " if abs(z) < 4.1968417d-11 dfmp hfp_p0 " EAQ := z * p0 tra 0,x1 " return to caller dfst pr2|z fmp pr2|z " calculate zz = z*z fst pr2|zz " calculate p(zz) fmp hfp_p3 dfad hfp_p2 fmp pr2|zz dfad hfp_p1 fmp pr2|zz dfad hfp_p0 dfmp pr2|z " calculate z*p(zz) tra 0,x1 " return to caller even eps: dec 4.1968417d-11 hfp_eps: oct 760134224171,000000000000 one: dec 1.0d0 hfp_one: oct 002040000000,000000000000 p0: dec .288539007275213810d01 hfp_p0: oct 002134252166,176530650277 p1: dec .961800759210250522d00 hfp_p1: oct 000754342230,541156441462 p2: dec .576584541348266310d00 hfp_p2: oct 000447154133,107411741772 p3: dec .434255940790007142d0 hfp_p3: oct 000336255455,574455321266 square_root_half: dec 7.071067811865475244008d-01 hfp_square_root_half: oct 000552023631,477473631102 square_root_two: dec 1.414213562373095048801d+00 hfp_square_root_two: oct 002055202363,147747363110 end  math_constants_.alm 11/11/89 1150.6rew 11/11/89 0805.5 23400 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " " Rewritten: 13 Feb 85 by HH to put the HFP constant values " immediately after the equivalent BFP values. This was " done for the sake of the math routines that use X " register offsets to differentiate between the HFP and BFP " values. name math_constants_ segdef almost_one,hfp_almost_one almost_one: hfp_almost_one: oct 000777777777,777777777777 segdef half_pi,hfp_half_pi half_pi: dec 1.570796326794896619231d+00 hfp_half_pi: oct 002062207732,504205506043 segdef log_10_of_2,hfp_log_10_of_2 log_10_of_2: dec 3.010299956639811952137d-01 hfp_log_10_of_2: oct 000232101152,047674776746 segdef log_10_of_e,hfp_log_10_of_e log_10_of_e: dec 4.342944819032518276511d-01 hfp_log_10_of_e: oct 000336267542,511562416145 segdef log_2_of_e,hfp_log_2_of_e log_2_of_e: dec 1.442695040888963407359d+00 hfp_log_2_of_e: oct 002056125073,122560277414 segdef log_e_of_2,hfp_log_e_of_2 log_e_of_2: dec 6.931471805599453094172d-01 hfp_log_e_of_2: oct 000542710277,575071736326 segdef max_value,hfp_max_value max_value: hfp_max_value: oct 376777777777,777777777777 segdef one_degree,hfp_one_degree one_degree: dec 1.745329251994329576923d-02 hfp_one_degree: oct 776216764324,224516471053 segdef one_over_pi,hfp_one_over_pi one_over_pi: dec 3.183098861837906715377d-01 hfp_one_over_pi: oct 000242763015,562344202512 segdef one_radian,hfp_one_radian one_radian: dec 5.729577951308232087679d+01 hfp_one_radian: oct 004162456701,514360373670 segdef pi,hfp_pi pi: dec 3.141592653589793238462d+00 hfp_pi: oct 002144417665,210413214107 segdef quarter_pi,hfp_quarter_pi quarter_pi: dec 7.853981633974483096156d-01 hfp_quarter_pi: oct 000622077325,042055060432 segdef square_root_half,hfp_square_root_half square_root_half: dec 7.071067811865475244008d-01 hfp_square_root_half: oct 000552023631,477473631102 segdef square_root_three,hfp_square_root_three square_root_three: dec 1.732050807568877293527d+00 hfp_square_root_three: oct 002067331727,205411452472 segdef square_root_two,hfp_square_root_two square_root_two: dec 1.414213562373095048801d+00 hfp_square_root_two: oct 002055202363,147747363110 end  math_routines_.alm 11/11/89 1150.6rew 11/11/89 0804.6 7254 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " this routine must be bound before any of the math " routines in bound_pl1_operators_. It is used by " default_errror_handler_ " segdef math_routines_ math_routines_: vfd 36/* end  math_routines_end_.alm 11/11/89 1150.6rew 11/11/89 0803.9 7317 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " this routine must be bound after any of the math " routines in bound_pl1_operators_. It is used by " default_errror_handler_ " segdef math_routines_end_ math_routines_end_: vfd 36/* end  mrl_.alm 11/11/89 1150.6rew 11/11/89 0804.6 13221 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** " Subroutine interface to the MRL and MLR instructions " Created: 11 January 1983 by G. Palter name mrl_ " mrl_: Moves a character string copying the characters from right-to-left " dcl mrl_ entry (ptr, fixed bin(21), ptr, fixed bin(21)); " call mrl_ (input_ptr, input_lth, output_ptr, output_lth); entry mrl_ mrl_: epp1 ap|2,* " get input_ptr epp1 pr1|0,* lda ap|4,* " get input_lth epp2 ap|6,* " get output_ptr epp2 pr2|0,* ldq ap|8,* " get output_lth mrl (pr,rl),(pr,rl),fill(040) " do it desc9a pr1|0,al desc9a pr2|0,ql short_return " mlr_: Moves a character string copying the characters from left-to-right " dcl mlr_ entry (ptr, fixed bin(21), ptr, fixed bin(21)); " call mlr_ (input_ptr, input_lth, output_ptr, output_lth); entry mlr_ mlr_: epp1 ap|2,* " get input_ptr epp1 pr1|0,* lda ap|4,* " get input_lth epp2 ap|6,* " get output_ptr epp2 pr2|0,* ldq ap|8,* " get output_lth mlr (pr,rl),(pr,rl),fill(040) " do it desc9a pr1|0,al desc9a pr2|0,ql short_return end  mvt_.alm 11/11/89 1150.6r w 11/11/89 0805.2 63639 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " Utility to perform extremely fast character string translations " Created: October 1982 by G. Palter " Modified: 3 December 1982 by G. Palter to fix fencepost error in make_translation_table " Modified: 15 December 1983 by G. Palter to fix make_translation_table's handling of a " zero-length second argument (untranslated_list) name mvt_ " mvt_: Translates a character string " dcl mvt_ entry (ptr, ptr, fixed bin(21), char(512) aligned); " dcl mvt_ (input_string_ptr, output_string_ptr, string_lth, " translate_table); entry mvt_ mvt_: epp1 ap|2,* " get input_string_ptr epp1 pr1|0,* epp2 ap|4,* " get output_string_ptr epp2 pr2|0,* ldq ap|6,* " get string_lth epp3 ap|8,* " get addr(transate_table) mvt (pr,rl),(pr,rl) " translate me desc9a pr1|0,ql desc9a pr2|0,ql arg pr3|0 short_return " simple isn't it " " make_translation_table: Constructs the translate table used in calls to mvt_ " dcl mvt_$make_translation_table entry (char(*), char(*), " char(512) aligned); " call mvt_$make_translation_table (translated_list, untranslated_list, " translate_table); entry make_translation_table temp translated_lth temp untranslated_lth temp untranslated_char make_translation_table: push " need a stack frame for this one lda ap|0 " get 2*nargs into AU, code into AL cana 8,dl " is there an evironmentptr? tze 2,ic " ... no ada 2,du " ... yes epp4 ap|0,au " get addr(descriptors) epp1 ap|2,* " get addr(translated_list) lda pr4|2,* " get length(translated_list) tmi 2,ic ana =o777777,dl ana descriptor_mask sta sp|translated_lth epp2 ap|4,* " get addr(untranslated_list) lda pr4|4,* " get length(untranslated_list) tmi 2,ic ana =o777777,dl ana descriptor_mask sta sp|untranslated_lth epp3 ap|6,* " get addr(translation_table) mlr (),(pr) " initialize translation table to ... desc9a collate9,512 " ... collate9() (no translation) desc9a pr3|0,512 lda sp|untranslated_lth " loop backwards tpnz build_table return " zero-length untranslated_list build_table: mrl (pr,al),(pr),fill(000) " get rank(untranslated_char) desc9a pr2|-1(3),1 desc9a sp|untranslated_char,4 ldq sp|untranslated_char " ... into the Q cmpa sp|translated_lth " see if there's a translation given tpnz use_blank_for_translation " ... no mlr (pr,al),(pr,ql) " ... yes: put into the table desc9a pr1|-1(3),1 desc9a pr3|0,1 tra continue use_blank_for_translation: " put blank in for translation mlr (),(pr,ql),fill(040) desc9a 0,0 desc9a pr3|0,1 continue: sba 1,dl " done? tpnz build_table " ... no return " ... yes " Constants descriptor_mask: oct 000777777777 " gets length from a descriptor collate9: vfd o9/000,o9/001,o9/002,o9/003,o9/004,o9/005,o9/006,o9/007 vfd o9/010,o9/011,o9/012,o9/013,o9/014,o9/015,o9/016,o9/017 vfd o9/020,o9/021,o9/022,o9/023,o9/024,o9/025,o9/026,o9/027 vfd o9/030,o9/031,o9/032,o9/033,o9/034,o9/035,o9/036,o9/037 vfd o9/040,o9/041,o9/042,o9/043,o9/044,o9/045,o9/046,o9/047 vfd o9/050,o9/051,o9/052,o9/053,o9/054,o9/055,o9/056,o9/057 vfd o9/060,o9/061,o9/062,o9/063,o9/064,o9/065,o9/066,o9/067 vfd o9/070,o9/071,o9/072,o9/073,o9/074,o9/075,o9/076,o9/077 vfd o9/100,o9/101,o9/102,o9/103,o9/104,o9/105,o9/106,o9/107 vfd o9/110,o9/111,o9/112,o9/113,o9/114,o9/115,o9/116,o9/117 vfd o9/120,o9/121,o9/122,o9/123,o9/124,o9/125,o9/126,o9/127 vfd o9/130,o9/131,o9/132,o9/133,o9/134,o9/135,o9/136,o9/137 vfd o9/140,o9/141,o9/142,o9/143,o9/144,o9/145,o9/146,o9/147 vfd o9/150,o9/151,o9/152,o9/153,o9/154,o9/155,o9/156,o9/157 vfd o9/160,o9/161,o9/162,o9/163,o9/164,o9/165,o9/166,o9/167 vfd o9/170,o9/171,o9/172,o9/173,o9/174,o9/175,o9/176,o9/177 vfd o9/200,o9/201,o9/202,o9/203,o9/204,o9/205,o9/206,o9/207 vfd o9/210,o9/211,o9/212,o9/213,o9/214,o9/215,o9/216,o9/217 vfd o9/220,o9/221,o9/222,o9/223,o9/224,o9/225,o9/226,o9/227 vfd o9/230,o9/231,o9/232,o9/233,o9/234,o9/235,o9/236,o9/237 vfd o9/240,o9/241,o9/242,o9/243,o9/244,o9/245,o9/246,o9/247 vfd o9/250,o9/251,o9/252,o9/253,o9/254,o9/255,o9/256,o9/257 vfd o9/260,o9/261,o9/262,o9/263,o9/264,o9/265,o9/266,o9/267 vfd o9/270,o9/271,o9/272,o9/273,o9/274,o9/275,o9/276,o9/277 vfd o9/300,o9/301,o9/302,o9/303,o9/304,o9/305,o9/306,o9/307 vfd o9/310,o9/311,o9/312,o9/313,o9/314,o9/315,o9/316,o9/317 vfd o9/320,o9/321,o9/322,o9/323,o9/324,o9/325,o9/326,o9/327 vfd o9/330,o9/331,o9/332,o9/333,o9/334,o9/335,o9/336,o9/337 vfd o9/340,o9/341,o9/342,o9/343,o9/344,o9/345,o9/346,o9/347 vfd o9/350,o9/351,o9/352,o9/353,o9/354,o9/355,o9/356,o9/357 vfd o9/360,o9/361,o9/362,o9/363,o9/364,o9/365,o9/366,o9/367 vfd o9/370,o9/371,o9/372,o9/373,o9/374,o9/375,o9/376,o9/377 vfd o9/400,o9/401,o9/402,o9/403,o9/404,o9/405,o9/406,o9/407 vfd o9/410,o9/411,o9/412,o9/413,o9/414,o9/415,o9/416,o9/417 vfd o9/420,o9/421,o9/422,o9/423,o9/424,o9/425,o9/426,o9/427 vfd o9/430,o9/431,o9/432,o9/433,o9/434,o9/435,o9/436,o9/437 vfd o9/440,o9/441,o9/442,o9/443,o9/444,o9/445,o9/446,o9/447 vfd o9/450,o9/451,o9/452,o9/453,o9/454,o9/455,o9/456,o9/457 vfd o9/460,o9/461,o9/462,o9/463,o9/464,o9/465,o9/466,o9/467 vfd o9/470,o9/471,o9/472,o9/473,o9/474,o9/475,o9/476,o9/477 vfd o9/500,o9/501,o9/502,o9/503,o9/504,o9/505,o9/506,o9/507 vfd o9/510,o9/511,o9/512,o9/513,o9/514,o9/515,o9/516,o9/517 vfd o9/520,o9/521,o9/522,o9/523,o9/524,o9/525,o9/526,o9/527 vfd o9/530,o9/531,o9/532,o9/533,o9/534,o9/535,o9/536,o9/537 vfd o9/540,o9/541,o9/542,o9/543,o9/544,o9/545,o9/546,o9/547 vfd o9/550,o9/551,o9/552,o9/553,o9/554,o9/555,o9/556,o9/557 vfd o9/560,o9/561,o9/562,o9/563,o9/564,o9/565,o9/566,o9/567 vfd o9/570,o9/571,o9/572,o9/573,o9/574,o9/575,o9/576,o9/577 vfd o9/600,o9/601,o9/602,o9/603,o9/604,o9/605,o9/606,o9/607 vfd o9/610,o9/611,o9/612,o9/613,o9/614,o9/615,o9/616,o9/617 vfd o9/620,o9/621,o9/622,o9/623,o9/624,o9/625,o9/626,o9/627 vfd o9/630,o9/631,o9/632,o9/633,o9/634,o9/635,o9/636,o9/637 vfd o9/640,o9/641,o9/642,o9/643,o9/644,o9/645,o9/646,o9/647 vfd o9/650,o9/651,o9/652,o9/653,o9/654,o9/655,o9/656,o9/657 vfd o9/660,o9/661,o9/662,o9/663,o9/664,o9/665,o9/666,o9/667 vfd o9/670,o9/671,o9/672,o9/673,o9/674,o9/675,o9/676,o9/677 vfd o9/700,o9/701,o9/702,o9/703,o9/704,o9/705,o9/706,o9/707 vfd o9/710,o9/711,o9/712,o9/713,o9/714,o9/715,o9/716,o9/717 vfd o9/720,o9/721,o9/722,o9/723,o9/724,o9/725,o9/726,o9/727 vfd o9/730,o9/731,o9/732,o9/733,o9/734,o9/735,o9/736,o9/737 vfd o9/740,o9/741,o9/742,o9/743,o9/744,o9/745,o9/746,o9/747 vfd o9/750,o9/751,o9/752,o9/753,o9/754,o9/755,o9/756,o9/757 vfd o9/760,o9/761,o9/762,o9/763,o9/764,o9/765,o9/766,o9/767 vfd o9/770,o9/771,o9/772,o9/773,o9/774,o9/775,o9/776,o9/777 end  oc_trans_output_.pl1 11/11/89 1150.6rew 11/11/89 0804.2 36639 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-07-16,Farley), approve(87-07-17,MCR7735), audit(87-07-20,Fawcett), install(87-07-22,MR12.1-1044): Changed to allow PAD (\177) characters to pass through without being interpreted. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ oc_trans_output_: procedure (In_ptr, In_len, In_proc, Out_ptr, Out_words, Line_leng, Cont); /* Written by C. Hornig, April 1982 */ /* Modified 830620 to support consoles with different line lengths and to delete support of non-ASCII console types... -E. A. Ranzenbach */ dcl (In_ptr, Out_ptr) ptr parameter; dcl (In_len, In_proc) fixed bin (21) parameter; dcl Out_words fixed bin (19) parameter; dcl Cont bit (1) aligned parameter; dcl Line_leng fixed bin (17) parameter; dcl in_string char (In_len) based (In_ptr); dcl out_string char (256) based (Out_ptr); dcl c char (1) aligned; dcl b fixed bin (9); dcl out_pos fixed bin; dcl out_proc fixed bin (21); dcl n fixed bin; dcl done bit (1) aligned; dcl (byte, copy, divide, hbound, lbound, length, mod, rank, string, substr, unspec) builtin; %page; In_proc, Out_words = 0; out_proc, out_pos = 0; if In_len <= 0 then return; /* ignore null string */ if Cont then do; substr (out_string, 1, 2) = "\c"; out_proc, out_pos = 2; Cont = "0"b; end; done = "0"b; do while ((In_proc < In_len) & ^done); c = substr (in_string, In_proc + 1, 1); b = rank (c); if /* case */ (b >= 32) & (b <= 127) then do; call inc_pos (1); goto copy_char; end; else if (b < lbound (cc, 1)) | (b > hbound (cc, 1)) then do; cc (11): cc (12): call inc_pos (4); call inc_proc (4); begin; dcl oe (4) char (1) unaligned; oe (1) = "\"; unspec (oe (2)) = "06"b3 || substr (unspec (c), 1, 3); unspec (oe (3)) = "06"b3 || substr (unspec (c), 4, 3); unspec (oe (4)) = "06"b3 || substr (unspec (c), 7, 3); substr (out_string, out_proc - 3, 4) = string (oe); end; goto done_cc; end; else goto cc (b); cc (8): /* BS */ if out_pos > 0 then out_pos = out_pos - 1; goto copy_char; cc (9): /* HT */ n = 1 + mod (-out_pos - 1, 10); call inc_pos (n); call inc_proc (n); substr (out_string, out_proc - n + 1, n) = ""; goto done_cc; cc (10): /* NL */ call add_nl; done = "1"b; goto done_cc; cc (13): /* CR */ out_pos = 0; goto copy_char; cc (7): /* BEL */ copy_char: call inc_proc (1); substr (out_string, out_proc, 1) = c; done_cc: In_proc = In_proc + 1; end; finish_up: Out_words = divide (out_proc + 3, 4, 19, 0); n = 4 * Out_words - out_proc; substr (out_string, out_proc + 1, n) = copy (byte (127), n); return; /* * * * * * * * * INC_PROC * * * * * * * * */ inc_proc: procedure (N); dcl N fixed bin parameter; if out_proc + N > length (out_string) then goto finish_up; out_proc = out_proc + N; return; end inc_proc; /* * * * * * * * * * INC_POS * * * * * * * * * */ inc_pos: procedure (N); dcl N fixed bin parameter; if out_pos + N > Line_leng then do; Cont = "1"b; call add_nl; goto finish_up; end; out_pos = out_pos + N; return; end inc_pos; /* * * * * * * * * * ADD_NL * * * * * * * * * * */ add_nl: procedure; call inc_proc (2); substr (out_string, out_proc - 1, 2) = byte (13) || byte (10); out_pos = 0; return; end add_nl; end oc_trans_output_;  pc_check_tables_.pl1 11/11/89 1150.6r w 11/11/89 0805.5 222723 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,indcomtxt */ pc_check_tables_: procedure (Info_pointer, Code); /**** This procedure is invoked at fault recovery/ESD time to place the SST in a consistent state, assuming consistent interruption of page control. It is also called from the user ring to report on the state of a file system. In this case, it changes nothing. This procedure's function is to reconstruct SST based on critical sequences in all of ALM pc and pc.pl1. Every line of this procedure that changes SST is critical by same standard, and must follow same rules. This procedure assumes the following conventions, which ALM page control must continue to follow: * A ptw may be moved to full incore state. A cme with ptwp nonzero is wholly * valid. * Any out of service page can be taken non-out of service- if it was a write, * phm may be turned on. If it was a read, it may be taken out of core. * The disk dim has been trained to throw away all requests at * recovery time to validate these assumptions. An attempt is made to repair "impossible" damage, i.e., that which could not have occured as a result of clean interruption of a properly functioning page control. Rather than report each such lossage, about which nothing consistent can be done, segments so affected are marked as damaged, and pages so involved made null where possible. We even attempt to repair "garbage" in the SST (see reasonable_devaddp s/r), although in this case and the previous one, segment damage will surely result. No attempt is made to handle move_page_table in this version. A creation of Bernard Greenberg, May 1977. Modified, minimally, 03/06/81, W. Olin Sibert, for ADP conversion Modified, minutely, 06/21/82, E. N. Kittlitz, to move core map and not so minutely (auditor's orders) zap page-multilevel. Modified, 831220, E. N. Kittlitz, for pc$segmove support. Modified, 84-01-05, BIM, to finish above and use debug_check for stats. Modified, 84-01-05, BIM, to abstract as subroutine callable from user ring. */ declare Info_pointer pointer; declare Code fixed bin (35); dcl cmap ptr; /* Core map array ppr */ dcl ptp pointer; dcl (new_nused, new_nwired) fixed bin; /* Counters for re-computation */ dcl (curused, csl, nincore) fixed bin (9); /* Ast remputation stats */ dcl (cbno, ptsi, pts, astx, pno) fixed bin; /* Walking indices */ declare reported_aste bit (1) aligned; declare 1 stats aligned, 2 bad_cme_devadds fixed bin, 2 bad_cme_add_types fixed bin, 2 bad_ptw_devadds fixed bin, 2 cme_ptw_devadd_diffs fixed bin, 2 bad_cme_ptwps fixed bin, 2 ptws_os_2nd_pass fixed bin, 2 bad_ptw_addrs fixed bin, 2 valid_not_core fixed bin; dcl (offs, offdif, bno) fixed bin (18); /* used in validation */ dcl (addr, addrel, bit, divide, fixed, null, ptr, rel, size, string, substr, unspec) builtin; dcl page$cam entry; /* used in damaging */ dcl fcmep ptr; /* thread heads */ dcl lcmep ptr; /* thread tails */ dcl astagp ptr; /* AST group (pool) ptr for walk */ dcl astesize fixed bin; /* Size of whole ASTE in that pool */ dcl astagps (0:3) ptr; /* ast pool ptrs */ dcl (astlowers, astuppers, astesizes) (0:3) fixed bin (18); /* Structures */ dcl 1 ptwdevadd, /* Devadd from PTW */ 2 add fixed bin (18) unsigned unal, /* Record number (REALLY UNSIGNED!) */ 2 add_type like badd_type unal; /* add type */ dcl 1 cmedevadd, /* Devadd from CME */ 2 cmeadd fixed bin (18) unsigned unal, 2 cmeaddtype like badd_type unal; dcl 1 fdevadd aligned, /* for general work */ 2 add fixed bin (18) unsigned unal, 2 add_type bit (4) unal; dcl 1 based_comp_devadd like ptwdevadd aligned based; /* ditto */ declare error_table_$unimplemented_version fixed bin (35) ext static; dcl 1 ex_aste aligned based (astep), /* large aste */ 2 aste_proper like aste, 2 aste_ptw (0:pts - 1) like ptw aligned; dcl 1 astage (0:fixed (sst.no_aste (ptsi), 18) - 1) like ex_aste based (astagp) aligned; /* array group elements */ /* Set up some pointers. */ check_tables_info_ptr = Info_pointer; Code = 0; if check_tables_info.version ^= PC_CHECK_TABLES_INFO_VERSION_1 then do; Code = error_table_$unimplemented_version; return; end; sstp = check_tables_info.sst_ptr; cmap = setwordno (check_tables_info.core_map_ptr, wordno (sst.cmp)); pvtp = check_tables_info.pvt_ptr; pvt_arrayp = addr (pvt.array); stats = 0; /* aggregately */ astagp = setwordno (sstp, wordno (sst.astap)); do ptsi = 0 to 3; pts = sst.pts (ptsi); astagps (ptsi) = astagp; astesizes (ptsi) = size (ex_aste); astlowers (ptsi) = wordno (astagp); astagp = addwordno (astagp, size (astage)); astuppers (ptsi) = wordno (astagp); end; call CHECK_SEGMOVE; call CHECK_EVICT_PAGE; /**** First, loop through the core map. In any conflict, the core map is right. */ if check_tables_info.recover_errors then sst.usedp, sst.wusedp = "000000"b3; /* Clear thread heads */ new_nused = 0; /* Init new used count */ do cbno = sst.first_core_block to sst.last_core_block; cmep = addr (cmap -> cma (cbno)); /* Address each block */ if cme.fp & "400000"b3 then do; if check_tables_info.recover_errors then cme.fp, cme.bp = "777777"b3; /* Any negative goes deconf */ end; else if (cme.fp | cme.bp | cme.ptwp) = "000000"b3 then go to free_cme; /* unpaged space */ else if cme.ptwp = "000000"b3 then ; /* Was really free to start with. */ else do; unspec (cmedevadd) = cme.devadd; if ^reasonable_devaddp (cme.devadd) then do; if check_tables_info.flags.report_errors then do; call check_tables_info.report ("Bad devadd in CME."); call check_tables_info.display_cme (cmep); end; stats.bad_cme_devadds = stats.bad_cme_devadds + 1; go to clear_cme; end; if cmeaddtype.core then do; if check_tables_info.report_errors then do; call check_tables_info.report ("Core devadd in CME."); call check_tables_info.display_cme (cmep); end; stats.bad_cme_add_types = stats.bad_cme_add_types + 1; go to clear_cme; end; if (string (cmeaddtype) = "0000"b) then do; if check_tables_info.report_errors then do; call check_tables_info.report ("Null add_type in CME."); call check_tables_info.display_cme (cmep); end; go to clear_cme; end; ptp = ptr (sstp, cme.ptwp); /* address ptw */ if ^reasonable_ptwpp (ptp, astep) then do; if check_tables_info.report_errors then do; call check_tables_info.report ("Bad ptwp ^o in CME.", cme.ptwp); call check_tables_info.display_cme (cmep); end; stats.bad_cme_ptwps = stats.bad_cme_ptwps + 1; go to clear_cme; end; else do; /* ptw is legit */ fdevadd.add = cbno * 16; /* set up coreadd */ fdevadd.add_type = add_type.core; if ^reasonable_devaddp (mptw.devadd) then do; if check_tables_info.report_errors then do; call check_tables_info.report ("Bad devadd in PTW."); call check_tables_info.display_ptw (ptp); end; stats.bad_ptw_devadds = stats.bad_ptw_devadds + 1; if check_tables_info.recover_errors then mptw.devadd = unspec (fdevadd); /* bust segment */ go to clear_cme; end; if check_tables_info.recover_errors then cme.astep = rel (astep); if ptw.os & check_tables_info.recover_errors then do; /* out of service, may have to free cme */ if cme.notify_requested then call pnotify (ptp); if cme.io then ptw.phm1 = "1"b; /* was write */ else do; /* was a read -- evict. */ cme.fp = "066666"b3; /* Cause core to be counted used */ ptw.valid = "0"b; call page$cam; mptw.devadd = unspec (cmedevadd); cme.ptwp = "000000"b3; /* Will cause freeing */ end; ptw.os = "0"b; /* This should turn off all legit o/s */ end; if mptw.devadd ^= unspec (fdevadd) & mptw.devadd ^= unspec (cmedevadd) then do; if check_tables_info.report_errors then do; call check_tables_info .report ("PTW devadd inconsistent with CME."); call check_tables_info.display_ptw (ptp); end; stats.cme_ptw_devadd_diffs = stats.cme_ptw_devadd_diffs + 1; if check_tables_info.recover_errors then do; aste.damaged = "1"b; ptw.valid = "0"b; call page$cam; mptw.devadd = page_problem_null_addr; end; end; /* gonna get the asteps later */ end; end; if cme.ptwp = "000000"b3 then do; /* Free it */ if cme.fp ^= "777777"b3 then clear_cme: if check_tables_info.recover_errors then cme.fp = "066666"b3; free_cme: if check_tables_info.recover_errors then do; cme.astep, cme.ptwp = "000000"b3; cme.notify_requested = "0"b; end; end; if check_tables_info.recover_errors then do; if ((cme.fp | cme.ptwp | cme.bp) ^= "000000"b3) & (cme.fp ^= "777777"b3) then do; new_nused = new_nused + 1; /* count it */ if sst.usedp = "0"b then do; sst.usedp, sst.wusedp = rel (cmep); fcmep, lcmep = cmep; end; cme.fp = rel (fcmep); cme.bp = rel (lcmep); lcmep -> cme.fp = rel (cmep); fcmep -> cme.bp = rel (cmep); /* continue thread */ lcmep = cmep; end; end; sst.nused = new_nused; end; /*** Now loop through the AST. There should be no OS ptw's, except those in beginning of readin or end of io window. Any inconsistency still left is simply wrong. Damage segments. */ do ptsi = 0 to 3; astagp = astagps (ptsi); pts = sst.pts (ptsi); astesize = size (ex_aste); /* get real size */ do astx = 0 to fixed (sst.no_aste (ptsi), 18) - 1; astep = addr (astage (astx)); /* address aste */ curused, nincore, csl = 0; /* init stats */ reported_aste = "0"b; do pno = 0 to pts - 1; /* scan page table */ ptp = addr (ex_aste.aste_ptw (pno)); if ^reasonable_devaddp (mptw.devadd) then do; if check_tables_info.report_errors then do; call check_tables_info .report ("Bad PTW devadd for aste at ^o, ptw ^d", rel (astep), pno); if ^reported_aste then do; call check_tables_info.display_aste (astep); reported_aste = "1"b; end; call check_tables_info.display_ptw (ptp); end; stats.bad_ptw_devadds = stats.bad_ptw_devadds + 1; go to ptwdamage; end; unspec (ptwdevadd) = mptw.devadd; /* get stuff out */ if string (ptwdevadd.add_type) = "0000"b then ; /* true null */ else if ptwdevadd.disk then do; if ^substr (ptw.add, 1, 1) then do; /* not nulled */ csl = pno + 1; curused = curused + 1; /* count rec used */ end; end; else if ptwdevadd.core then do; cmep = addr (cmap -> cma (divide (fixed (ptw.add, 18), 16, 17, 0))); if reasonable_cmepp (cmep) then do; if cme.ptwp = rel (ptp) then do; /* all good here */ if ptw.os & check_tables_info.recover_errors then do; /* This is a complete lie-- not window, as coreadd here. cme pass should have turned these all off. */ stats.ptws_os_2nd_pass = stats.ptws_os_2nd_pass + 1; ptw.os = "0"b; go to ptwdamage; end; nincore = nincore + 1; csl = pno + 1; curused = curused + 1; end; else do; if check_tables_info.report_errors then do; call check_tables_info .report ("CME ptwp ^= ptw address."); call check_tables_info.display_ptw (ptp); call check_tables_info.display_cme (cmep); end; stats.bad_cme_ptwps = stats.bad_cme_ptwps + 1; go to ptwdamage; end; end; else do; if check_tables_info.report_errors then do; call check_tables_info.report ("Bad cmep in PTW."); call check_tables_info.display_ptw (ptp); end; stats.bad_ptw_addrs = stats.bad_ptw_addrs + 1; go to ptwdamage; end; end; else do; if check_tables_info.report_errors then do; call check_tables_info.report ("PTW devadd not core, disk, or null."); call check_tables_info.display_ptw (ptp); end; stats.bad_ptw_addrs = stats.bad_ptw_addrs + 1; ptwdamage: if check_tables_info.recover_errors then do; ptw.valid = "0"b; aste.damaged = "1"b; call page$cam; mptw.devadd = page_problem_null_addr; unspec (ptwdevadd) = page_problem_null_addr; end; end; if check_tables_info.recover_errors then ptw.os = "0"b; if ptwdevadd.core then do; if check_tables_info.recover_errors then ptw.valid = "1"b; /* Assume NO FAULTED INCORES IN THIS VERSION OF SYS */ end; else do; /* next check should never happen */ if ptw.valid then do; if check_tables_info.report_errors then do; call check_tables_info.report ("Core PTW not valid."); call check_tables_info.display_ptw (ptp); end; stats.valid_not_core = stats.valid_not_core + 1; if check_tables_info.recover_errors then do; ptw.valid = "0"b; call page$cam; end; end; if check_tables_info.recover_errors then ptw.phm, ptw.phm1 = "0"b; /* these bother pc */ end; if ptw.wired then new_nwired = new_nwired + 1; if check_tables_info.recover_errors then ptw.df_no = "01"b; /* I hate illegal segfault msgs -- Level 68 only */ end; /* page table loop */ /* CAREFUL THESE ALL DECLARED FIXED 9 */ if check_tables_info.report_errors then do; if aste.csl ^= bit (csl, 9) | aste.records ^= bit (curused, 9) | aste.np ^= bit (nincore, 9) then do; call check_tables_info.display_aste (astep); call check_tables_info.report ("Bad counter for ASTE."); if aste.csl ^= bit (csl, 9) then call check_tables_info .report (" csl = ^d, should be ^d", bin (aste.csl), csl); if aste.records ^= bit (curused, 9) then call check_tables_info .report (" records = ^d, should be ^d", bin (aste.records), curused); if aste.np ^= bit (nincore, 9) then call check_tables_info .report (" np = ^d, should be ^d", bin (aste.np), nincore); end; end; if check_tables_info.recover_errors then do; aste.csl = bit (csl, 9); aste.records = bit (curused, 9); aste.np = bit (nincore, 9); end; end; /* end ast group */ end; /* end ast pool */ if check_tables_info.recover_errors then sst.wired = new_nwired; sst.wtct = 0; /* we stopped 'em all. */ if check_tables_info.report_error_counts then if unspec (stats) ^= ""b then do; call check_tables_info.report ("Statistics:"); call stat_print ("Bad cme.devadd", stats.bad_cme_devadds); call stat_print ("Bad cme add_type", stats.bad_cme_add_types); call stat_print ("Bad ptw devadd", stats.bad_ptw_devadds); call stat_print ("ptw/cme devadd mismatch", stats.cme_ptw_devadd_diffs); call stat_print ("Bad cme ptwp", stats.bad_cme_ptwps); call stat_print ("ptw os on second pass", stats.ptws_os_2nd_pass); call stat_print ("Bad ptw address", stats.bad_ptw_addrs); call stat_print ("Valid ptw not in memory", stats.valid_not_core); end; /* Subroutines */ stat_print: procedure (what, how_many); declare what char (*); declare how_many fixed bin; if how_many > 0 then call check_tables_info.report ("^5x^5d^12t^a", how_many, what); return; end stat_print; CHECK_SEGMOVE: procedure; declare old_astep pointer; declare old_ptp pointer; declare new_astep pointer; declare new_ptp pointer; declare px fixed bin; if sst.segmove_lock.pid = ""b then return; astep = setwordno (sstp, wordno (sst.segmove_astep)); old_astep = setwordno (sstp, wordno (sst.segmove_old_addr_astep)); new_astep = setwordno (sstp, wordno (sst.segmove_new_addr_astep)); if check_tables_info.flags.report_state then do; call check_tables_info.report ("Segmove in progress, PID: ^w.", sst.segmove_lock.pid); if sst.segmove_astep = null () then call check_tables_info.report (" move astep is NULL."); else call check_tables_info . report (" move astep: ^p, size = ^d.", check_tables_info.display_ptr ((sst.segmove_astep)), sst.pts (bin (astep -> aste.ptsi))); if sst.segmove_old_addr_astep = null () then call check_tables_info.report (" old addr astep is NULL."); else call check_tables_info . report (" old addr astep: ^p, size = ^d.", check_tables_info.display_ptr ((sst.segmove_old_addr_astep)), sst.pts (bin (old_astep -> aste.ptsi))); if sst.segmove_new_addr_astep = null () then call check_tables_info.report (" new addr astep is NULL."); else call check_tables_info . report (" new addr astep: ^p, size = ^d.", check_tables_info.display_ptr ((sst.segmove_new_addr_astep)), sst.pts (bin (new_astep -> aste.ptsi))); if astep ^= null () then call check_tables_info . report (" Old PV ^a (Vtocx ^d).", check_tables_info.display_pvname (sst.segmove_pvtx), sst.segmove_vtocx); end; /**** to make code clearer, first we do display loop, then real work */ /**** old_astep need not be displayed unless move_astep ^= null indicating that some ptws have possibly been changed. */ /* leave out extensive display, you can poke w/azm */ if ^check_tables_info.recover_errors then return; /* done */ if old_astep ^= null () then old_ptp = addwordno (old_astep, sst.astsize); if new_astep ^= null () then new_ptp = addwordno (new_astep, sst.astsize); if astep ^= null () then ptp = addwordno (astep, sst.astsize); begin; declare pt (1:sst.pts (bin (astep -> aste.ptsi))) bit (36) aligned based; if sst.segmove_astep ^= null () then ptp -> pt = old_ptp -> pt; if sst.segmove_old_addr_astep ^= null () then call NULL_PT (old_ptp, segmove_old_addr_null_addr); if sst.segmove_new_addr_astep ^= null () then do; call NULL_PT (new_ptp, segmove_new_addr_null_addr); pvtep = addr (pvt_array (bin (new_astep -> aste.pvtx))); pvte.vol_trouble_count = pvte.vol_trouble_count + 1; end; NULL_PT: procedure (PTP, NullAddr); declare PTP pointer; declare NullAddr bit (22) aligned; declare px fixed bin; declare ptwp pointer; do px = lbound (PTP -> pt, 1) to hbound (PTP -> pt, 1); unspec (ptwdevadd) = PTP -> pt (px); if string (ptwdevadd.add_type) ^= "0000"b then PTP -> pt (px) = NullAddr; end; end NULL_PT; end; aste.pvtx = sst.segmove_pvtx; aste.vtocx = sst.segmove_vtocx; sst.segmove_astep, sst.segmove_old_addr_astep, sst.segmove_new_addr_astep = null (); sst.segmove_vtocx, sst.segmove_pvtx = 0; return; end CHECK_SEGMOVE; CHECK_EVICT_PAGE: procedure; /**** If evict_page was moving a page, restore the sequestered modify bit. */ if sst.evict_ptp = "000000"b3 then return; if check_tables_info.report_state then do; call check_tables_info.report ("Evict page in progess, ptw at ^o.", sst.evict_ptp); call check_tables_info.display_ptw (pointer (sstp, sst.evict_ptp)); end; ptp = ptr (sstp, sst.evict_ptp); if ^reasonable_ptwpp (ptp, astep) then do; if check_tables_info.report_errors then call check_tables_info.report ("Invalid sst.evict_ptwp"); return; /* no repair */ end; else do; if ^check_tables_info.recover_errors then return; if sst.evict_phmbit ^= "000000"b3 then ptw.phm1 = "1"b; sst.evict_phmbit = "000000"b3; sst.evict_ptp = "000000"b3; end; return; end CHECK_EVICT_PAGE; pnotify: proc (p); /* Notify page control event */ dcl p ptr; dcl pxss$notify entry (bit (36) aligned); call pxss$notify ("000000"b3 || rel (p)); end; reasonable_cmepp: proc (tcmep) returns (bit (1) aligned); /* test reasonable cmep */ dcl tcmep ptr; dcl offs fixed bin (18); offs = fixed (rel (tcmep), 18); offdif = offs - fixed (rel (cmap), 18); if offdif < 0 then return ("0"b); bno = offdif / size (cme); if bno * size (cme) ^= offdif then return ("0"b); if bno < sst.first_core_block | bno > sst.last_core_block then return ("0"b); return ("1"b); end; reasonable_ptwpp: proc (tptp, rastep) returns (bit (1) aligned); dcl tptp ptr; dcl rastep ptr; offs = fixed (rel (tptp), 18); if offs < astlowers (0) then return ("0"b); do ptsi = 0 to 3; if offs < astuppers (ptsi) then do; offdif = offs - astlowers (ptsi); bno = offdif / astesizes (ptsi); if offdif - bno * astesizes (ptsi) < size (aste) then return ("0"b); rastep = ptr (sstp, bno * astesizes (ptsi) + astlowers (ptsi)); return ("1"b); end; end; return ("0"b); end; reasonable_devaddp: proc (arg_devadd) returns (bit (1) aligned); /* tests non-garbage devadd */ dcl arg_devadd bit (22) unaligned; dcl 1 test_devadd, 2 add bit (18) unal, 2 add_type like badd_type unal; dcl LEGAL_ADD_TYPES bit (16) unal init ("1010100010000000"b) options (constant) static; unspec (test_devadd) = arg_devadd; if ^substr (LEGAL_ADD_TYPES, fixed (string (test_devadd.add_type), 4) + 1, 1) then return ("0"b); if test_devadd.add_type.core then if substr (test_devadd.add, 15, 4) then return ("0"b); return ("1"b); end; /* format: off */ %page; %include cmp; %page; %include sst; %page; %include add_type; %page; %include aste; %page; %include null_addresses; %page; %include "ptw.l68"; /* format: on */ dcl 1 ptw aligned based (ptp) like l68_ptw; dcl 1 ptw_flags unaligned like l68_ptw_flags based; dcl 1 core_ptw aligned based (ptp) like l68_core_ptw; dcl 1 special_ptw aligned based (ptp) like l68_special_ptw; dcl 1 real_disk_ptw aligned based (ptp) like l68_real_disk_ptw; dcl 1 null_disk_ptw aligned based (ptp) like l68_null_disk_ptw; /* Arrays and overlays for various purposes */ dcl 1 ptwa (0:255) based (ptp) aligned like ptw; /* page table */ dcl ptwa_bits (0:255) based (ptp) bit (36) aligned; /* page table array as raw bits */ dcl 1 mptw based (ptp) aligned, /* page table word while page is not in core */ 2 devadd bit (22) unaligned,/* device address where page resides */ 2 pad bit (14) unaligned; dcl 1 mptwa (0:1) based (ptp) aligned, /* page table while pages are not in core */ 2 devadd bit (22) unaligned,/* device address where page resides */ 2 pad bit (14) unaligned; dcl 1 atptw based (ptp) aligned, /* PL/I has problems on overlay-def based */ 2 add bit (18) unal, 2 (core, disk, pd, reserved) bit (1) unal, /* address types */ 2 pad bit (14) unal; dcl 1 atptwa (0:255) based (ptp) aligned like atptw; /* format: off */ %include pvt; %include pvte; %include syserr_constants; %include pc_check_tables_info; end pc_check_tables_;  pl1_operators_.alm 11/11/89 1150.6rew 11/11/89 0803.9 1807884 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Limited, 1984 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(87-03-05,Huen), approve(87-03-05,MCR7629), " audit(87-04-15,RWaters), install(87-05-14,MR12.1-1029): " Fix PL/1 error 2138 - " Update the comments in "call_ent_var_desc" and "call_ext_in_desc" to " indicate the offset of the argument list is in x1. Fix PL/1 error 2122 - " Allow Ceiling function work with negative fixed bin scaled numbers. " 2) change(87-06-26,Huen), approve(87-06-26,MCR7732), " audit(87-07-10,RWaters), install(87-11-30,MR12.2-1004): " Fix bug2121 " 3) change(88-06-24,Huen), approve(88-06-24,MCR7916), " audit(88-07-11,RWaters), install(88-07-15,MR12.2-1057): " Fix high priority fortran error 510 - " Fix bug causing fortran inquire statement gives incorrect response after " the call to the condition handler. " 4) change(89-01-16,Huen), approve(89-01-16,MCR8033), " audit(89-01-19,RWaters), install(89-02-28,MR12.3-1016): " Fix PL/1 error 2192 (phx21224) - " Changing indicators to allow maximum negative integer. " END HISTORY COMMENTS " NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE " " pl1_operators_ MUST be bound with conversion program any_to_any_, put_format_, put_field_, " and ALL of the math routines referenced from transfer vector " " NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE " " Operator Segment for PL/I Version II " Barry Wolman " March, 1969 " " Modified: 19 October, 1971 by BLW " Modified: 27 January, 1972 by BLW " Modified: 2 April, 1972 by BLW " Modified: 1 July, 1972 by RBSnyder for follow-on " Modified: 21 July, 1972 by BLW to fix mod operators " Modified: 21 November, 1972 by BLW to add controlled operators " Modified: 28 February, 1973 by BLW for odd base register saving " Modified: 2 June, 1973 by BLW to use EIS for string operations " Modified: 7 April, 1974 by BLW to fix bug 1078 " Modified: 10 April, 1974 by BLW to fix bug 1083 " Modified: 15 August, 1974 by BLW to fix bugs 1170, 1171, 1201, and 1202 " Modified: 1 November, 1974 by RAB to fix bug 1245 " Modified: 4 November, 1974 by RAB to add ldi to return_words " Modified: 6 November, 1974 by SHW for new call/push/return sequences " Modified: 14 November, 1974 by RAB to fix bug 1254 " Modified: 3 January, 1975 by RHS to support quick record i/o " Modified: 1 February, 1975 by RAB to fix bug 1318 " Modified: 5 May, 1975 by RAB for separate static and new trace " Modified: 22 May, 1975 by RAB to fix bug 1348 " Modified: 25 June, 1975 by RAB for new segdefs " Modified: 5 November 1975 by RAB for new area package " Modified: 29 December 1975 by RAB to fix bug 1449 " Modified: 27 February, 1976 by GDC for DFAST new entries " Modified: 2 March, 1976 by RHS for quick "put list"s, a subset of quick stream i/o " Modified: 1 June, 1976 by RAB to use free_|free_ for alloc_storage " Modified: 6 June, 1976 by RHS for quick "put edit"s " Modified: 12 October 1976 by RAB to have signal ops save and restore ALL regs properly " Modified: 3 December 1976 by RAB to implement long_profile " Modified: 16 December 1976 by RAB to fix 1564 (pointer and offset operators) " Modified: 23 December 1976 by RAB for after, before, ltrim, rtrim " Modified: 24 March 1977 by RAB for new complex divide algorithm " Modified: 10 May 1977 by MBW to use user free area instead of free_ " Modified 770619 by PG to implement clock, vclock, and stacq " Modified: 23 June 1977 by S. Webber to add ftn_open_element, ftn_file_manip_term " operators " Modified: 7/7/77 D. Levin change ftn_file_manip_term to ftn_get_area_ptr " Modified: 7/7/77 by RAB to partially fix bug 1642. This partially " removes formline_ code put in to fix bug 1074. " Modified: 16 August 1977 by RAB to complete removal of formline_ code in " returns(char(*)) " Modified: 16 August 1977 by RAB to speed up long_profile operator " Modified: 09/20/77 to extend trace interface to ALM and COBOL by P. Krupp. " Modified: 19 December 1977 by DSL - implement "static" stack frame for fortran I/O. " Refer to comments immediately preceding the label "fortran_read". " Modified: 15 Feb 1978 by PCK to implement stop, return_main, set_main_flag and " begin_return_main operators " Modified: 21 March 1978 by DSL stack_frame.incl.alm changes. stack_frame.fio_ps_ptr " changed to stack_frame.support_ptr. " Modified: 15 June 1978 by PCK to implement size_check_uns_fx1 and size_check_uns_fx2 " operators " Modified: 28 July 1978 by RAB to fix Fortran bug 169 in which amod failed if 2nd arg " was negative " Modified 781127 by PG to fix 1800 in which size_check_fx1 and size_check_uns_fx1 " changed the indicators " Modified 790223 by PG to fix 1821 (many, many operators were using signed arithmetic " on addresses in the upper when extending the stack!). Also removed " a lot of unused labels and names. " Modified 790608 by PG to add TCT tables. " Modified 790705 by PG to fix 1846 (eaa,neg sequence used by many " operators took faults on stacks = 128K. " Modified 9 July 1979 by CRD to add new operator fortran_end. " Modified 7 August 1979 by CRD to add new operator fort_dmod to fix " bug 221 and to bring dmod into inline ALM code. " Modified 791205 by PG to fix bug in TCT tables that caused code compiled by 25b " to fail if trace was used, due to misplaced even pseudo-op. " Modified 6 December 1979 by BSG for ix_rev_chars " Modified 12 February 1980 by CRD to add to fort_math_names table. " Modified 28 February 1980 by CRD to fix after/before for bit strings. (Bug 1915) " Modified 28 February 1980 by CRD to change the way many operators restore pr0. " Many operators did eppap operator_table, which doesn't work if trace " is being used. Since the entry sequences store the operator pointer, " these instructions were changed to eppap sp|stack_frame.operator_ptr,*. " Modified 6 March 1980 by CRD to add three new operators: shorten_stack_protect_ind, " save_stack_quick, and restore_stack_quick. " Modified 22 October 1980 by CRD to add new operators for new Fortran " intrinsic functions. " Modified 7 November 1980 by M. N. Davidoff to fix bug 2033 in which longbs_to_bs18 " always returned zero. " Modified 7 November 1980 by M. N. Davidoff to fix bug 2030 in which longbs_to_fx2 " didn't work for bit strings longer than 71 bits. " Modified 8 February 1980 by M. N. Davidoff to fix bug 2041 in which ix_rev_chars " failed when length(arg2)=1. " Modified 27 February 1981 by PCK to make the alm entry operators " preserve the contents of the lisp linkage pointer (pr1) " when trace is active " Modified 28 July by PCK to fix bug 2068 in which the current stack " gets trashed if an asynchronous fault such as an alarm " signal or page fault occurs when the stack is being extended " by any of the divide operators. " Modified 31 August 1981 by C R Davis to fix trans_sign_fl to set the " indicators properly, and to add the blank field to " ftn_open_element. " Modified 27 October 1981 by C R Davis to add ftn_inquire_element. " Modified 1 April 1982 by T G Oke to add fortran INTRINSICs for external reference " Modified 10 May 1982 by H Hoover to add 'mpy_overflow_check'. " Modified 27 August 1982 by T Oke to add 'fort_cleanup' and " 'fort_return_mac'. " Modified September 1982 by C. Hornig to have long_profile work with " separate_static. " Modified 21 September 1982 by T Oke to add 'fort_storage'. " Modified 5 Novemeber 1982 by T Oke to add 'VLA_words_per_seg' to " pl1_operators_ pointer referenced, and 'VLA_words_per_seg_' " entry. " Modified 14 January 1983 by T Oke to ensure indicator storage is " is done in stack_frame.return_ptr+1 on all out-calls. " References to PR6 changed to 'sp' for consistency. " Internal operator calls to pl1_support routines also save " and restore the indicators, using a new location " 'temp_indicators'. " Modified 23 November 1983 by H. Hoover to support Hexadecimal " Floating Point (HFP). " Modified 22 June 1984 by M. Mabey to add the fortran bit-shifting " functions to the fort_math_names and hfp_fort_math_names " tables. " Modified 14 February 1985 by M. Mabey to change the transfers to " the double precision arc_sine and arc_cosine routines to " reference the new routine 'double_arc_sine_' " Modified 10 April 1985 by M. Mabey to change the transfers to the " double precision tangent routine to reference the new " routine 'double_tangent_' " Modified: 15 January, 1987 by SH to correct the comments in routines " "call_ent_var_desc" and "call_ent_in_desc" to indicate " the offset of the argument list is in x1. " Modified: 16 January,1987 by SH & RW to allow ceiling function work " with negative fixed bin scaled numbers. " Modified: 24 June,1987 by SH to remove the 48 words extension instead " of all stack extension upon return from the 'call_signal_' " routine. " Modified: 24 June, 1988 by SH to adjust the next_stackframe_ptr and " perm_extension_ptr in the "ft_fast_call" routine. " Modified: 15 January, 1989 by RG & SH to fix size_check_fx1, " size_check_fx2, size_check_uns_fx1, size_check_uns_fx2. " Errors previously occurred on Maximum negative of fx1 and " fx2 in magnitude comparison. name pl1_operators_ include stack_header " We are attempting to set a standard for the storage and return of " indicators for a program. On call-out the operators will store the " indicator register in the low 18-bits of stack_frame.return_ptr+1, " the upper 18-bits are the return word offset, and are stored from " X0 typically. On return the operators will restore the indicators " from this low 18-bit portion. include stack_frame include eis_bits include iocbx include plio2_fsb include plio2_ps include fortran_ps include fortran_open_data include fortran_inquire_data " segdef alloc segdef alm_call segdef alm_entry segdef alm_operators_begin segdef alm_operators_end segdef alm_push segdef alm_return segdef alm_return_no_pop segdef alm_trace_operators_begin segdef alm_trace_operators_end segdef begin_pl1_operators segdef call_signal_ segdef end_pl1_operators segdef entry_operators segdef entry_operators_end segdef fort_math_names segdef hfp_fort_math_names segdef forward_call segdef get_our_lp segdef hfp_operator_table segdef operator_table segdef plio4 segdef put_return segdef tct_byte_0 segdef tct_byte_1 segdef tct_byte_2 segdef tct_byte_3 segdef tct_octal_040 segdef tct_octal_060 segdef trace_alm_entry segdef trace_entry_operators segdef trace_entry_operators_end segdef trace_operator_table segdef trace_hfp_operator_table segdef var_call segdef VLA_words_per_seg_ " " Definitions of variables used by operators. Since all " of the operators execute using the stack frame of the " pl/1 program for their temporary storage, locations 8-15 & 32-63 " of the pl/1 stack frame are reserved for operator use. " " sp|6 has been reserved for probe. " equ display_ptr,32 equ descriptor_ptr,34 equ linkage_ptr,36 equ text_base_ptr,38 equ tbp,38 equ temp_pt,40 string register equ ps_ptr,42 equ page,44 equ temp_indicators,45 equ double_temp,46 equ cpu,46 equ remainder,46 equ temp_size,48 equ extend_size,49 equ bit_lg1,50 string register equ char_lg1,51 string register equ t3,51 equ bit_or_char,52 string register equ t1,52 equ bit_op,53 equ t5,53 equ cat_lg1,54 equ t2,54 equ qmask,55 equ arg_list,56 equ save_regs,56 equ save_x01,56 equ label_var,56 equ complex,56 complex AQ equ temp2,58 equ lv,60 equ num,60 equ lg2,61 equ temp,62 equ t4,63 equ count,63 " " following locations used in stack extension by divide subroutine " equ divide_extension_size,32 equ qhat,0 equ rhat,1 equ carry,2 equ carrya,3 equ shift,4 equ norm_shift,5 equ div_temp,6 equ dividend,8 equ divisor,14 equ quotient,18 equ divide_lp,24 " bool rpd_bits,001400 bits for RPD instruction (A,B) " bool blank,40 " " Definitions related to Hexadecimal Floating Point (HFP) mode: " bool HFP_mask,000010 mask for bit in IR that sets HFP mode bool M2.0H,003700 yields HFP -2.0 under 'du' modification bool M0.5H,001400 yields HFP -0.5 under 'du' modification bool P0.0H,400000 yields HFP +0.0 under 'du' modification bool P0.5H,000400 yields HFP +0.5 under 'du' modification bool P1.0H,002040 yields HFP +1.0 under 'du' modification bool P2.0H,002100 yields HFP +2.0 under 'du' modification " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " MACROS USED IN THIS PROGRAM " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Macro to load PR4 with ptr to linkage section of pl1_operators_. " PR7 is set to the base of the stack. The AQ is effectively clobbered. " A subroutine of the same name also exists, when speed is not critical. " macro get_our_lp epbpsb sp|0 make sure sb is set up epaq * get ptr to ourselves lprplp sb|stack_header.lot_ptr,*au get packed ptr to linkage from lot &end " " Macro to load AU with the complement of the stack frame offset. " macro get_stack_offset eaa sp|0 get offset of stack frame in au era mask_bit_one form 2's complement of whole a-reg adla 1,dl w/o overflow &end " " The following macro (transfer_vector) is used to duplicate the transfer vector " and the constants and code which preceed it for the trace programs. All labels " in the macro should be preceeded by "&1" in order to eliminate duplicate labels. " " Any operators which are to be different for the trace vector should have " the target of the transfer preceeded by "&1". " macro transfer_vector " " Due to the presence of double-word constants (at bit_mask and mask_bit) " these instructions must presently begin on an even-word boundary. " Note that if an odd number of words is added to the front of the " operator_table region, then the following even pseudo-op must be " changed to an odd pseudo-op. If you forget, an assembly error will " result (due to clever divide-by-zero, below). " even " " The following section, from location 0 to label operator_table, is referenced " directly from PL/1 programs by means of offsets of the form ap|-n (ap pointing " at pl1_operators_$operator_table). For this reason, the order of the " following instructions must not be changed. Any new coding must be placed at " the FRONT of the segment. " " This table translates a bit number between 0 and 35 to a char number " between 0 and 3. " even &1&2bitno_to_charno_table: dup 9 dec 0 dupend dup 9 dec 1 dupend dup 9 dec 2 dupend dup 9 dec 3 dupend " " The following tables are for use with the TCT instruction. " Any single, given, character can be searched for using these " tables. " dup 115 dec -1 dupend " &1&2tct_octal_060: dup 4 dec -1 dupend " &1&2tct_octal_040: dup 8 dec -1 dupend &1&2tct_byte_0: vfd 9/0,9/-1,9/-1,9/-1 dup 127 dec -1 dupend " &1&2tct_byte_1: vfd 9/-1,9/0,9/-1,9/-1 dup 127 dec -1 dupend " &1&2tct_byte_2: vfd 9/-1,9/-1,9/0,9/-1 dup 127 dec -1 dupend " &1&2tct_byte_3: vfd 9/-1,9/-1,9/-1,9/0 dup 127 dec -1 dupend " " The number of words per segment of a FORTRAN Very Large Array. " &1&2VLA_words_per_seg_: vfd 36/256*1024 " " table of csl's for use by bool builtin function " &1&2csl_vector: csl (pr,rl),(pr,rl),bool(0) csl (pr,rl),(pr,rl),bool(1) csl (pr,rl),(pr,rl),bool(2) csl (pr,rl),(pr,rl),bool(3) csl (pr,rl),(pr,rl),bool(4) csl (pr,rl),(pr,rl),bool(5) csl (pr,rl),(pr,rl),bool(6) csl (pr,rl),(pr,rl),bool(7) csl (pr,rl),(pr,rl),bool(10) csl (pr,rl),(pr,rl),bool(11) csl (pr,rl),(pr,rl),bool(12) csl (pr,rl),(pr,rl),bool(13) csl (pr,rl),(pr,rl),bool(14) csl (pr,rl),(pr,rl),bool(15) csl (pr,rl),(pr,rl),bool(16) csl (pr,rl),(pr,rl),bool(17) " " shift table for character offset " &1&2co_to_bo: dec 0,9b17,18b17,27b17 " " shift table for half word offset " &1&2ho_to_bo: dec 0,18b17 " " store table from a, 9 bit bytes, character offset " OFFSET SIZE " &1&2store_a9_co: stba bp|0,40 0 1 stba bp|0,20 1 stba bp|0,10 2 stba bp|0,04 3 stba bp|0,60 0 2 stba bp|0,30 1 stba bp|0,14 2 stba bp|0,04 3 stba bp|0,70 0 3 stba bp|0,34 1 stba bp|0,14 2 stba bp|0,04 3 sta bp|0 0 4 stba bp|0,34 1 stba bp|0,14 2 stba bp|0,04 3 sta bp|0 0 5 stba bp|0,34 1 stba bp|0,14 2 stba bp|0,04 3 " " store table from q, 9 bit bytes, character offset " OFFSET SIZE " &1&2store_q9_co: nop 0,dl 0 2 nop 0,dl 1 nop 0,dl 2 stbq bp|1,40 3 nop 0,dl 0 3 nop 0,dl 1 stbq bp|1,40 2 stbq bp|1,60 3 nop 0,dl 0 4 stbq bp|1,40 1 stbq bp|1,60 2 stbq bp|1,70 3 stbq bp|1,40 0 5 stbq bp|1,60 1 stbq bp|1,70 2 stq bp|1 3 " " store table from a, 9 bit bytes, half word offset " OFFSET SIZE " &1&2store_a9_ho: stba bp|0,40 0 1 stba bp|0,10 1 stba bp|0,60 0 2 stba bp|0,14 1 stba bp|0,70 0 3 stba bp|0,14 1 sta bp|0 0 4 stba bp|0,14 1 sta bp|0 0 5 stba bp|0,14 1 sta bp|0 0 6 stba bp|0,14 1 " " store table from q, 9 bit bytes, half word offset " OFFSET SIZE " &1&2store_q9_ho: nop 0,dl 0 2 nop 0,dl 1 nop 0,dl 0 3 stbq bp|1,40 1 nop 0,dl 0 4 stbq bp|1,60 1 stbq bp|1,40 0 5 stbq bp|1,70 1 stbq bp|1,60 0 6 stq bp|1 1 " " store table from a, 6 bit bytes, half word offset " OFFSET SIZE " &1&2store_a6_ho: stca bp|0,40 0 1 stca bp|0,04 1 stca bp|0,60 0 2 stca bp|0,06 1 stca bp|0,70 0 3 stca bp|0,07 1 stca bp|0,74 0 4 stca bp|0,07 1 stca bp|0,76 0 5 stca bp|0,07 1 sta bp|0 0 6 stca bp|0,07 1 sta bp|0 0 7 stca bp|0,07 1 sta bp|0 0 8 stca bp|0,07 1 sta bp|0 0 9 stca bp|0,07 1 " " store table from q, 6 bit bytes, half word offset " OFFSET SIZE " &1&2store_q6_ho: nop 0,dl 0 2 nop 0,dl 1 nop 0,dl 0 3 nop 0,dl 1 nop 0,dl 0 4 stcq bp|1,40 1 nop 0,dl 0 5 stcq bp|1,60 1 nop 0,dl 0 6 stcq bp|1,70 1 stcq bp|1,40 0 7 stcq bp|1,74 1 stcq bp|1,60 0 8 stcq bp|1,76 1 stcq bp|1,70 0 9 stq bp|1 1 " " THE FOLLOWING SECTION IS DIRECTLY REFERENCED FROM PL/1 PROGRAMS BY MEANS OF " ap|offset. FOR THIS REASON, THE ORDER OF THE FOLLOWING INSTRUCTIONS MUST " NOT BE CHANGED. " &1&2operator_table: &1&2bit_mask: vfd 0/-1,72/0 vfd 1/-1,71/0 vfd 2/-1,70/0 vfd 3/-1,69/0 vfd 4/-1,68/0 vfd 5/-1,67/0 vfd 6/-1,66/0 vfd 7/-1,65/0 vfd 8/-1,64/0 vfd 9/-1,63/0 vfd 10/-1,62/0 vfd 11/-1,61/0 vfd 12/-1,60/0 vfd 13/-1,59/0 vfd 14/-1,58/0 vfd 15/-1,57/0 vfd 16/-1,56/0 vfd 17/-1,55/0 vfd 18/-1,54/0 vfd 19/-1,53/0 vfd 20/-1,52/0 vfd 21/-1,51/0 vfd 22/-1,50/0 vfd 23/-1,49/0 vfd 24/-1,48/0 vfd 25/-1,47/0 vfd 26/-1,46/0 vfd 27/-1,45/0 vfd 28/-1,44/0 vfd 29/-1,43/0 vfd 30/-1,42/0 vfd 31/-1,41/0 vfd 32/-1,40/0 vfd 33/-1,39/0 vfd 34/-1,38/0 vfd 35/-1,37/0 &1&2ones: vfd 36/-1,36/0 vfd 36/-1,1/-1,35/0 vfd 36/-1,2/-1,34/0 vfd 36/-1,3/-1,33/0 vfd 36/-1,4/-1,32/0 vfd 36/-1,5/-1,31/0 vfd 36/-1,6/-1,30/0 vfd 36/-1,7/-1,29/0 vfd 36/-1,8/-1,28/0 vfd 36/-1,9/-1,27/0 vfd 36/-1,10/-1,26/0 vfd 36/-1,11/-1,25/0 vfd 36/-1,12/-1,24/0 vfd 36/-1,13/-1,23/0 vfd 36/-1,14/-1,22/0 vfd 36/-1,15/-1,21/0 vfd 36/-1,16/-1,20/0 vfd 36/-1,17/-1,19/0 vfd 36/-1,18/-1,18/0 vfd 36/-1,19/-1,17/0 vfd 36/-1,20/-1,16/0 vfd 36/-1,21/-1,15/0 vfd 36/-1,22/-1,14/0 vfd 36/-1,23/-1,13/0 vfd 36/-1,24/-1,12/0 vfd 36/-1,25/-1,11/0 vfd 36/-1,26/-1,10/0 vfd 36/-1,27/-1,9/0 vfd 36/-1,28/-1,8/0 vfd 36/-1,29/-1,7/0 vfd 36/-1,30/-1,6/0 vfd 36/-1,31/-1,5/0 vfd 36/-1,32/-1,4/0 vfd 36/-1,33/-1,3/0 vfd 36/-1,34/-1,2/0 vfd 36/-1,35/-1,1/0 " &1&2mask_bit: vfd 0/0,36/-1,36/-1 vfd 1/0,35/-1,36/-1 vfd 2/0,34/-1,36/-1 vfd 3/0,33/-1,36/-1 vfd 4/0,32/-1,36/-1 vfd 5/0,31/-1,36/-1 vfd 6/0,30/-1,36/-1 vfd 7/0,29/-1,36/-1 vfd 8/0,28/-1,36/-1 vfd 9/0,27/-1,36/-1 vfd 10/0,26/-1,36/-1 vfd 11/0,25/-1,36/-1 vfd 12/0,24/-1,36/-1 vfd 13/0,23/-1,36/-1 vfd 14/0,22/-1,36/-1 vfd 15/0,21/-1,36/-1 vfd 16/0,20/-1,36/-1 vfd 17/0,19/-1,36/-1 vfd 18/0,18/-1,36/-1 vfd 19/0,17/-1,36/-1 vfd 20/0,16/-1,36/-1 vfd 21/0,15/-1,36/-1 vfd 22/0,14/-1,36/-1 vfd 23/0,13/-1,36/-1 vfd 24/0,12/-1,36/-1 vfd 25/0,11/-1,36/-1 vfd 26/0,10/-1,36/-1 vfd 27/0,9/-1,36/-1 vfd 28/0,8/-1,36/-1 vfd 29/0,7/-1,36/-1 vfd 30/0,6/-1,36/-1 vfd 31/0,5/-1,36/-1 vfd 32/0,4/-1,36/-1 vfd 33/0,3/-1,36/-1 vfd 34/0,2/-1,36/-1 vfd 35/0,1/-1,36/-1 vfd 36/0,36/-1 &1&2max_single_value: vfd 37/0,35/-1 vfd 38/0,34/-1 vfd 39/0,33/-1 vfd 40/0,32/-1 vfd 41/0,31/-1 vfd 42/0,30/-1 vfd 43/0,29/-1 vfd 44/0,28/-1 vfd 45/0,27/-1 vfd 46/0,26/-1 vfd 47/0,25/-1 vfd 48/0,24/-1 vfd 49/0,23/-1 vfd 50/0,22/-1 vfd 51/0,21/-1 vfd 52/0,20/-1 vfd 53/0,19/-1 vfd 54/0,18/-1 vfd 55/0,17/-1 vfd 56/0,16/-1 vfd 57/0,15/-1 vfd 58/0,14/-1 vfd 59/0,13/-1 vfd 60/0,12/-1 vfd 61/0,11/-1 vfd 62/0,10/-1 vfd 63/0,9/-1 vfd 64/0,8/-1 vfd 65/0,7/-1 vfd 66/0,6/-1 vfd 67/0,5/-1 vfd 68/0,4/-1 vfd 69/0,3/-1 vfd 70/0,2/-1 vfd 71/0,1/-1 " &1&2blanks: oct 040040040040,040040040040 oct 000040040040,040040040040 oct 000000040040,040040040040 oct 000000000040,040040040040 oct 000000000000,040040040040 oct 000000000000,000040040040 oct 000000000000,000000040040 oct 000000000000,000000000040 " &1&2ptr_mask: oct 077777000077,777777077077 mask for use in ptr comparisions " " operator to convert single fixed to double fixed " even &1&2fx1_to_fx2: llr 36 lrs 36 " " operators to convert fixed to float " odd &1&2fx1_to_fl2: xed &1&2fx1_to_fx2 " even &1&2fx2_to_fl2: ife &2,hfp_ lde =18b25,du EAQ = unnormalized 2*float(number) fad P0.0H,du EAQ = 2*float(number) fmp P0.5H,du EAQ = float(number) tra sp|tbp,*x0 return ifend ine &2,hfp_ lde =71b25,du fad =0.,du tra sp|tbp,*0 ifend " " operator to reset next stack pointer " even &1&2reset_stack: ldx0 sp|5 stx0 sp|stack_frame.next_sp+1 " " operators to convert indicators into relations " &1&2r_l_a: tmi true lda 0,dl tra sp|tbp,*0 " &1&2r_g_s: tze 2,ic trc true lda 0,dl tra sp|tbp,*0 " &1&2r_g_a: tze 2,ic tpl true lda 0,dl tra sp|tbp,*0 " &1&2r_l_s: tnc true lda 0,dl tra sp|tbp,*0 " &1&2r_e_as: tze true lda 0,dl tra sp|tbp,*0 " &1&2r_ne_as: tnz true lda 0,dl tra sp|tbp,*0 " &1&2r_le_a: tmi true tze true lda 0,dl tra sp|tbp,*0 " &1&2r_ge_s: trc true lda 0,dl tra sp|tbp,*0 " &1&2r_ge_a: tpl true lda 0,dl tra sp|tbp,*0 " &1&2r_le_s: tnc true tze true lda 0,dl tra sp|tbp,*0 " &1&2true: lda =o400000,du tra sp|tbp,*0 " " operator to set stack ptr to that of block N static " levels above the current block. Entered with N in q. " (should not be called with N = 0, but will work anyway.) " &1&2set_stack: tsx1 display_chase get ptr to proper frame eppsp bp|0 into sp tra set_stack_extend do three more instructions (added later " and since compiled code knows offsets in this " area, couldn't add the code inline) " " tables to convert to bit offset ready to be ORed into pointer " &1&2mod2_tab: dec 0,18b26 " &1&2mod4_tab: dec 0,9b26,18b26,27b26 " " transfer vector for operators not referenced directly " by the pl/1 program. new operators may be added at the " end of the list only. " &1&2op_vector: tra alloc_char_temp 0 tra alloc_bit_temp 1 tra alloc_temp 2 tra realloc_char_temp 3 tra realloc_bit_temp 4 tra save_string 5 obsolete tra pk_to_unpk 6 tra unpk_to_pk 7 tra move_chars 8 obsolete tra move_chars_aligned 9 obsolete tra move_bits 10 obsolete tra move_bits_aligned 11 obsolete tra chars_move 12 obsolete tra chars_move_aligned 13 obsolete tra bits_move 14 obsolete tra bits_move_aligned 15 obsolete tra move_not_bits 16 obsolete tra move_not_bits_aligned 17 obsolete tra ext_and_1 18 tra ext_and_2 19 tra comp_bits 20 tra cpbs3 21 obsolete tra cpbs3_aligned 22 obsolete tra cpbs4 23 obsolete tra cpcs_ext1 24 tra cpcs_ext2 25 tra cpbs_ext1 26 tra cpbs_ext2 27 tra store_string 28 tra cat_realloc_chars 29 tra cat_realloc_bits 30 tra cp_chars 31 obsolete tra cp_chars_aligned 32 obsolete tra cp_bits 33 obsolete tra cp_bits_aligned 34 obsolete tra enter_begin_block 35 tra leave_begin_block 36 tra call_ent_var_desc 37 tra call_ent_var 38 tra call_ext_in_desc 39 tra call_ext_in 40 tra call_ext_out_desc 41 tra call_ext_out 42 tra call_int_this_desc 43 tra call_int_this 44 tra call_int_other_desc 45 tra call_int_other 46 tra begin_return_mac 47 tra return_mac 48 tra cat_move_chars 49 obsolete tra cat_move_chars_aligned 50 obsolete tra cat_move_bits 51 obsolete tra cat_move_bits_aligned 52 obsolete tra cat_chars 53 obsolete tra cat_chars_aligned 54 obsolete tra cat_bits 55 obsolete tra cat_bits_aligned 56 obsolete tra set_chars 57 obsolete tra set_chars_aligned 58 obsolete tra set_bits 59 obsolete tra set_bits_aligned 60 obsolete tra and_bits 61 obsolete tra and_bits_aligned 62 obsolete tra or_bits 63 obsolete tra or_bits_aligned 64 obsolete tra move_label_var 65 tra make_label_var 66 tra &2fl2_to_fx1 67 tra &2fl2_to_fx2 68 tra longbs_to_fx2 69 tra tra_ext_1 70 tra tra_ext_2 71 tra alloc_auto_adj 72 tra longbs_to_bs18 73 tra stac_mac 74 tra sign_mac 75 tra bound_ck_signal 76 tra trans_sign_fx1 77 tra trans_sign_fl 78 tra copy_words 79 obsolete tra mpfx2 80 tra mpfx3 81 tra copy_const 82 obsolete tra copy_const_vt 83 obsolete tra sr_check 84 obsolete tra chars_move_vt 85 obsolete tra chars_move_vta 86 obsolete tra bits_move_vt 87 obsolete tra bits_move_vta 88 obsolete tra &2mdfl1 89 tra &2mdfl2 90 tra mdfx1 91 tra mdfx2 92 tra mdfx3 93 tra mdfx4 94 tra copy_double 95 obsolete tra string_store 96 obsolete tra get_chars 97 obsolete tra get_bits 98 obsolete tra pad_chars 99 tra pad_bits 100 tra signal_op 101 tra enable_op 102 tra index_chars 103 obsolete tra index_chars_aligned 104 obsolete tra index_bits 105 obsolete tra index_bits_aligned 106 obsolete tra exor_bits 107 obsolete tra exor_bits_aligned 108 obsolete tra set_bits_co 109 obsolete tra set_bits_ho 110 obsolete tra set_chars_co 111 obsolete tra set_chars_ho 112 obsolete tra string_store_co 113 obsolete tra string_store_ho 114 obsolete tra get_chars_co 115 obsolete tra get_chars_ho 116 obsolete tra get_bits_co 117 obsolete tra get_bits_ho 118 obsolete tra and_bits_co 119 obsolete tra and_bits_ho 120 obsolete tra or_bits_co 121 obsolete tra or_bits_ho 122 obsolete tra exor_bits_co 123 obsolete tra exor_bits_ho 124 obsolete tra cat_move_bits_co 125 obsolete tra cat_move_bits_ho 126 obsolete tra move_not_bits_co 127 obsolete tra move_not_bits_ho 128 obsolete tra move_bits_co 129 obsolete tra move_bits_ho 130 obsolete tra move_chars_co 131 obsolete tra move_chars_ho 132 obsolete tra cat_move_chars_co 133 obsolete tra cat_move_chars_ho 134 obsolete tra cat_chars_co 135 obsolete tra cat_chars_ho 136 obsolete tra cat_bits_co 137 obsolete tra cat_bits_ho 138 obsolete tra io_signal 139 tra index_cs_1 140 obsolete tra index_cs_1_aligned 141 obsolete tra &2fort_mdfl1 142 tra rfb1_to_cflb1 143 tra &2rfb2_to_cflb1 144 tra mpcfl1_1 145 tra mpcfl1_2 146 tra dvcfl1_1 147 tra dvcfl1_2 148 tra chars_move_vt_co 149 obsolete tra chars_move_vt_ho 150 obsolete tra chars_move_co 151 obsolete tra chars_move_ho 152 obsolete tra bits_move_vt_co 153 obsolete tra bits_move_vt_ho 154 obsolete tra bits_move_co 155 obsolete tra bits_move_ho 156 obsolete tra cp_chars_co 157 obsolete tra cp_chars_ho 158 obsolete tra cp_bits_co 159 obsolete tra cp_bits_ho 160 obsolete tra cpbs3_co 161 obsolete tra cpbs3_ho 162 obsolete tra shorten_stack 163 tra zero_bits 164 obsolete tra zero_bits_aligned 165 obsolete tra zero_bits_co 166 obsolete tra zero_bits_ho 167 obsolete tra blank_chars 168 obsolete tra blank_chars_aligned 169 obsolete tra blank_chars_co 170 obsolete tra blank_chars_ho 171 obsolete tra index_chars_co 172 obsolete tra index_chars_ho 173 obsolete tra index_bits_co 174 obsolete tra index_bits_ho 175 obsolete tra index_cs_1_co 176 obsolete tra index_cs_1_ho 177 obsolete tra index_bs_1 178 obsolete tra index_bs_1_aligned 179 obsolete tra index_bs_1_co 180 obsolete tra index_bs_1_ho 181 obsolete arg shift_bo 182 obsolete tra return_words 183 tra return_bits 184 obsolete tra return_bits_co 185 obsolete tra return_bits_ho 186 obsolete tra return_bits_al 187 obsolete &1&2entry_operators: tra &1ext_entry 188 tra &1ext_entry_desc 189 tra int_entry 190 tra int_entry_desc 191 tra val_entry 192 tra val_entry_desc 193 tra get_chars_aligned 194 obsolete tra get_bits_aligned 195 obsolete tra fetch_chars 196 tra fetch_bits 197 tra get_terminate 198 tra |[put_terminate] 199 tra put_data_aligned 200 obsolete tra get_list_aligned 201 obsolete tra get_edit_aligned 202 obsolete tra put_list_aligned 203 obsolete tra put_edit_aligned 204 obsolete tra |[stream_prep] 205 tra |[record_io] 206 tra open_file 207 tra close_file 208 tra put_data 209 obsolete tra put_data_co 210 obsolete tra put_data_ho 211 obsolete tra get_list 212 obsolete tra get_list_co 213 obsolete tra get_list_ho 214 obsolete tra get_edit 215 obsolete tra get_edit_co 216 obsolete tra get_edit_ho 217 obsolete tra put_list 218 obsolete tra put_list_co 219 obsolete tra put_list_ho 220 obsolete tra put_edit 221 obsolete tra put_edit_co 222 obsolete tra put_edit_ho 223 obsolete tra suffix_cs 224 obsolete tra suffix_bs 225 obsolete tra &2fl2_to_fxscaled 226 tra trunc_fx1 227 tra trunc_fx2 228 tra ceil_fx1 229 tra ceil_fx2 230 tra &2ceil_fl 231 tra floor_fx1 232 tra floor_fx2 233 tra &2floor_fl 234 tra &2trunc_fl 235 tra round_fx1 236 tra round_fx2 237 tra repeat 238 tra make_bit_table 239 obsolete tra make_bit_table_al 240 obsolete tra make_bit_table_co 241 obsolete tra make_bit_table_ho 242 obsolete tra verify 243 obsolete tra verify_al 244 obsolete tra verify_co 245 obsolete tra verify_ho 246 obsolete tra const_verify 247 obsolete tra const_verify_al 248 obsolete tra const_verify_co 249 obsolete tra const_verify_ho 250 obsolete tra reverse_cs 251 tra reverse_bs 252 tra form_bit_table 253 obsolete tra form_bit_table_co 254 obsolete tra form_bit_table_ho 255 obsolete tra form_bit_table_al 256 obsolete tra chars_move_ck 257 obsolete tra chars_move_ck_co 258 obsolete tra chars_move_ck_ho 259 obsolete tra chars_move_ck_al 260 obsolete tra bits_move_ck 261 obsolete tra bits_move_ck_co 262 obsolete tra bits_move_ck_ho 263 obsolete tra bits_move_ck_al 264 obsolete tra size_check_fx1 265 tra size_check_fx2 266 tra signal_stringsize 267 tra suffix_cs_ck 268 obsolete tra suffix_bs_ck 269 obsolete tra pointer_hard 270 tra alm_call 271 special for alm tra alm_push 272 special for alm tra alm_return 273 special for alm tra alm_return_no_pop 274 special for alm tra &1alm_entry 275 special for alm tra packed_to_bp 276 obsolete tra return_chars 277 obsolete tra return_chars_co 278 obsolete tra return_chars_ho 279 obsolete tra return_chars_aligned 280 obsolete tra rpd_odd_lp_bp 281 obsolete tra rpd_odd_bp_lp 282 obsolete tra rpd_even_lp_bp 283 obsolete tra rpd_even_bp_lp 284 obsolete tra offset_easy 285 tra offset_easy_pk 286 tra offset_hard 287 tra offset_hard_pk 288 tra pointer_hard_pk 289 tra pointer_easy 290 tra pointer_easy_pk 291 tra round_fl 292 tra enable_file 293 tra revert_file 294 tra alloc_block 295 tra free_block 296 tra push_ctl_data 297 tra push_ctl_desc 298 tra pop_ctl_data 299 tra pop_ctl_desc 300 tra allocation 301 tra set_chars_eis 302 tra set_bits_eis 303 tra index_chars_eis 304 tra index_bits_eis 305 tra index_cs_1_eis 306 tra index_bs_1_eis 307 tra return_chars_eis 308 tra return_bits_eis 309 tra put_data_eis 310 tra |[put_edit_eis] 311 tra put_list_eis 312 tra |[get_edit_eis] 313 tra get_list_eis 314 tra verify_eis 315 tra search_eis 316 tra fortran_read 317 tra fortran_write 318 tra fortran_manip 319 tra fortran_scalar_xmit 320 tra fortran_array_xmit 321 tra fortran_terminate 322 tra |[real_to_real_round_] 323 tra |[real_to_real_truncate_] 324 tra |[any_to_any_round_] 325 tra |[any_to_any_truncate_] 326 tra unpack_picture 327 tra pack_picture 328 tra divide_fx1 329 tra divide_fx2 330 tra divide_fx3 331 tra divide_fx4 332 tra scaled_mod_fx1 333 tra scaled_mod_fx2 334 tra scaled_mod_fx3 335 tra scaled_mod_fx4 336 tra translate_2 337 tra translate_3 338 tra |[&2square_root_] 339 tra |[&2sine_radians_] 340 tra |[&2sine_degrees_] 341 tra |[&2cosine_radians_] 342 tra |[&2cosine_degrees_] 343 tra |[&2tangent_radians_] 344 tra |[&2tangent_degrees_] 345 tra |[&2arc_sine_radians_] 346 tra |[&2arc_sine_degrees_] 347 tra |[&2arc_cosine_radians_] 348 tra |[&2arc_cosine_degrees_] 349 tra |[&2arc_tangent_radians_] 350 tra |[&2arc_tangent_degrees_] 351 tra |[&2log_base_2_] 352 tra |[&2log_base_e_] 353 tra |[&2log_base_10_] 354 tra |[&2exponential_] 355 tra |[&2double_square_root_] 356 tra |[&2double_sine_radians_] 357 tra |[&2double_sine_degrees_] 358 tra |[&2double_cosine_radians_] 359 tra |[&2double_cosine_degrees_] 360 tra |[&2double_tangent_radians_] 361 tra |[&2double_tangent_degrees_] 362 tra |[&2double_arc_sine_radians_] 363 tra |[&2double_arc_sine_degrees_] 364 tra |[&2double_arc_cosine_radians_] 365 tra |[&2double_arc_cosine_degrees_] 366 tra |[&2double_arc_tan_radians_] 367 tra |[&2double_arc_tan_degrees_] 368 tra |[&2double_log_base_2_] 369 tra |[&2double_log_base_e_] 370 tra |[&2double_log_base_10_] 371 tra |[&2double_exponential_] 372 tra |[&2arc_tangent_radians_2_] 373 tra |[&2arc_tangent_degrees_2_] 374 tra |[&2double_arc_tan_radians_2_] 375 tra |[&2double_arc_tan_degrees_2_] 376 tra |[&2integer_power_single_] 377 tra |[&2integer_power_double_] 378 tra |[&2double_power_single_] 379 tra |[&2double_power_double_] 380 tra |[&2double_power_integer_] 381 tra |[&2single_power_single_] 382 tra |[&2single_power_integer_] 383 tra |[integer_power_integer_] 384 tra signal_size 385 tra &1ss_ext_entry 386 tra &1ss_ext_entry_desc 387 tra ss_int_entry 388 tra ss_int_entry_desc 389 tra ss_val_entry 390 tra ss_val_entry_desc 391 tra |[mpcdec] 392 tra |[dvcdec] 393 tra |[dvrcdec] 394 tra |[ceil] 395 tra |[floor] 396 tra |[sign] 397 tra |[cabs] 398 tra |[truncate] 399 tra |[mod] 400 tra set_support 401 tra div_4_cplx_ops 402 tra fetch_chars_eis 403 tra signal_stringrange 404 tra ss_enter_begin_block 405 tra |[put_field] 406 tra |[put_field_chk] 407 tra |[put_control] 408 tra |[op_alloc_] 409 tra alloc_storage 410 tra |[op_freen_] 411 tra |[op_empty_] 412 tra |[&2cabs] 413 fortran only tra |[&2ccos] 414 fortran only tra |[&2cexp] 415 fortran only tra |[&2clog] 416 fortran only tra |[&2csin] 417 fortran only tra |[&2csqrt] 418 fortran only tra |[&2tanh] 419 fortran only tra |[&2dmod] 420 fortran only (obsolete) tra |[&2cmpx_p_cmpx] 421 fortran only tra &2get_math_entry 422 fortran only tra fortran_pause 423 fortran only tra fortran_stop 424 fortran only tra fortran_chain 425 fortran only tra long_profile 426 tra index_before_cs 427 tra index_before_bs 428 tra index_after_cs 429 tra index_after_bs 430 tra index_before_bs_1 431 tra index_after_bs_1 432 tra verify_for_ltrim 433 tra verify_for_rtrim 434 tra stacq_mac 435 tra clock_mac 436 tra vclock_mac 437 tra ftn_open_element 438 fortran only tra ftn_get_area_ptr 439 fortran only tra stop 440 tra return_main 441 tra set_main_flag 442 tra begin_return_main 443 tra size_check_uns_fx1 444 tra size_check_uns_fx2 445 tra fortran_end 446 fortran only tra &2fort_dmod 447 fortran only tra ix_rev_chars 448 tra verify_rev_chars 449 tra search_rev_chars 450 tra shorten_stack_protect_ind 451 tra save_stack_quick 452 tra restore_stack_quick 453 tra |[&2dtanh] 454 fortran only tra |[&2sinh] 455 fortran only tra |[&2dsinh] 456 fortran only tra |[&2cosh] 457 fortran only tra |[&2dcosh] 458 fortran only tra &2nearest_whole_number 459 fortran only tra &2nearest_integer 460 fortran only tra ftn_inquire_element 461 fortran only tra mpy_overflow_check 462 fortran only tra fort_return_mac 463 fortran only tra fort_cleanup 464 fortran only tra fort_storage 465 fortran only tra &1enter_BFP_mode 466 tra &1enter_HFP_mode 467 tra unimp 468 future expansion tra unimp 469 future expansion tra unimp 470 future expansion tra unimp 471 future expansion tra unimp 472 future expansion tra unimp 473 future expansion tra unimp 474 future expansion tra unimp 475 future expansion tra unimp 476 future expansion tra unimp 477 future expansion tra unimp 478 future expansion tra unimp 479 future expansion tra unimp 480 future expansion &end " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " END OF MACROS " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " begin_pl1_operators: transfer_vector " " The following section is not referenced directly by " the compiled pl/1 program and may be changed as " desired. " " THE FOLLOWING CONVENTIONS APPLY TO STRING OPERATORS " 1. Unless specified otherwise, a unit size is in the q register " 2. Operators whose names end in "_aligned" or "vta" deal " with aligned strings having no fractional offset. " 3. Operators whose names end in "_co" have a character offset in x7. " 4. Operators whose names end in "_ho" have a half-word offset in x7. " 5. If not one of the above, the offset is a bit offset in x7. " 6. A pointer to the string is transmitted in the bp. " 7. If name of operator ends in "_eis", the bit offset is correct in bp " and index register 7 is not used. " " allocation operators " The char and bit allocation operators reserve two extra words " the temporary is stored in the second of these. " alloc_char_temp: stq sp|char_lg1 save char length stz sp|bit_or_char indicate char temp adq 3+8,dl compute number of words with 2 more qrs 2 tsx1 alloc allocate space ldq sp|char_lg1 restore char length " act: eppbp bp|2 skip over extra 2 words stq bp|-1 save length of temp abt: spribp sp|temp_pt save pointer to temp tra sp|tbp,*0 and return to pl/1 program " alloc_bit_temp: stq sp|bit_lg1 save bit length stc1 sp|bit_or_char indicate bit temp adq 35+72,dl compute number of words (2 extra) div 36,dl tsx1 alloc allocate space ldq sp|bit_lg1 restore bit length tra act and go fill in length " alloc_temp: eax1 abt alloc N words and go save ptr " fall into alloc coding " " routine to allocate N words at end of stack. " entered with N in ql. " alloc: qls 18 shift number to qu stq sp|temp_size save number of words get_stack_offset eppbp sp|stack_header.stack_end_ptr,au* get ptr to extension adlq 15,du make size a multiple of 16 anq =o777760,du .. stq sp|extend_size adlq sp|stack_frame.next_sp+1 compute new end of stack frame stq sp|stack_frame.next_sp+1 bump next ptr stq sp|stack_header.stack_end_ptr+1,au bump stack end pointer tra 0,1 return to operator " " reallocation operators " allowance is made for the two words at the head of the string " cat_realloc_bits: lda sp|bit_lg1 set up for concatenation sta sp|cat_lg1 stq sp|bit_lg1 set new bit length adq 35+72,dl compute new length of temp div 36,dl lda sp|bit_lg1 restore bit length tsx1 realloc extend stack again tra sp|tbp,*0 an return to caller " realloc_bit_temp: sta sp|bit_lg1 set new length adq 35+72,dl compute new word length div 36,dl lda sp|bit_lg1 restore bit length tsx1 realloc extend stack tra zero_it and go zero new space " cat_realloc_chars: lda sp|char_lg1 set up for concatenation sta sp|cat_lg1 " realloc_char_temp: stq sp|char_lg1 set new char length adq 3+8,dl compute new word length qrs 2 lda sp|char_lg1 restore char lenth tsx1 realloc extend stack tra sp|tbp,*0 and exit " realloc: stx1 sp|save_x01 ldx1 sp|temp_size save end position of current temp eppbp sp|temp_pt,* get ptr to temp sta bp|-1 lda sp|save_x01 restore return offset qls 18 shift word size to qu stq sp|temp_size set new size of temp sblq sp|extend_size subtract size of extension tmi 0,au return if no extension needed adlq 15,du make increment a multiple of 16 anq =o777760,du .. stq sp|temp save increment momentarily adlq sp|extend_size update extension size stq sp|extend_size .. get_stack_offset ldq sp|temp get extension increment adlq sp|stack_frame.next_sp+1 compute new end of stack frame stq sp|stack_frame.next_sp+1 bump next sp pointer stq sp|stack_header.stack_end_ptr+1,au bump stack end pointer lda sp|save_x01 restore return offset tra 0,au return to caller " " this operator shortens the stack frame to its original length " shorten_stack: epbpab sp|0 get ptr to base of stack ldx1 sp|5 stx1 sp|stack_frame.next_sp+1 stx1 ab|stack_header.stack_end_ptr+1 tra sp|tbp,*0 " " This operator is the same as shorten_stack above, but does not change the indicators. " shorten_stack_protect_ind: sti sp|temp Save indicators epbpap sp|0 Get ptr to base of stack ldx1 sp|5 stx1 sp|stack_frame.next_sp+1 stx1 ab|stack_header.stack_end_ptr+1 ldi sp|temp Restore indicators tra sp|tbp,*0 " " This operator makes the current extension permanent, " and returns the old permanent extent in the q. " save_stack_quick: ldq sp|5 Get permanent extent ldx1 sp|stack_frame.next_sp+1 stx1 sp|5 Change it tra sp|tbp,*0 " " This operator is the inverse of save_stack_quick above. " It takes a stack offset in the Q, and makes it the permanent " stack extent. " restore_stack_quick: stq sp|5 Change permanent extent tra sp|tbp,*0 " " code added here to handle 2 extra instructions needed at set_stack " set_stack_extend: get_stack_offset eppbp sp|stack_frame.next_sp,* set up stack end ptr correctly spribp sp|stack_header.stack_end_ptr,au .. tra sp|tbp,*0 and return to pl1 program " " operator to save the string in the aq in stack so it is " accessable to long string operators. entered with bit_size " in x6 and string in aq " save_string: staq sp|double_temp save the string eppbp sp|double_temp load ptr to string eaq 0,6 move bit size to ql qrl 18 spribp sp|temp_pt save ptr to string stq sp|bit_lg1 save bit length div 9,dl compute char length stq sp|char_lg1 and save that tra sp|tbp,*0 " " operators to save info about a string in the stack. " set_chars_eis: stq sp|char_lg1 save char length stz sp|bit_or_char indicate char string spribp sp|temp_pt save ptr (with bit offset) tra sp|tbp,*0 and return " set_chars: eax1 0,7 get bit offset tra sca " set_chars_co: ldx1 co_to_bo,7 convert to bit offset tra sca " set_chars_ho: ldx1 ho_to_bo,7 convert to bit offset tra sca " set_chars_aligned: eax1 0 get zero offset sca: stq sp|char_lg1 save char length stz sp|bit_or_char indicate char string " sca1: spribp sp|temp_pt save ptr to string lxl1 shift_bo,1 shift bit offset to left sxl1 sp|temp_pt+1 and overwrite former bit offset tra sp|tbp,*0 " set_bits_eis: stq sp|bit_lg1 save bit length stc1 sp|bit_or_char indicate bit string spribp sp|temp_pt save ptr (with bit offset) tra sp|tbp,*0 and return " set_bits: eax1 0,7 get bit offset tra sba " set_bits_co: ldx1 co_to_bo,7 convert to bit offset tra sba " set_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra sba " set_bits_aligned: eax1 0 get zero offset " sba: stq sp|bit_lg1 save bit length stc1 sp|bit_or_char indicate bit temp tra sca1 " " operator to store a string when size+offset > 72 " entered with string to be stored in aq, bit_size+offset-72 in x6, " bit offset in x7, and ptr to destination in bp " store_string: stq sp|temp save right part of string lrl 0,7 shift to proper position era bp|0 insert in first two words stq bp|1 of destination ana mask_bit_one,7 mask has no trailing zeros ersa bp|0 lda sp|temp get right part of string ldq 0,dl clear q register lrl 0,7 shift into position erq bp|2 insert into third word anq bit_mask_one,6 mask has no leading zeros ersq bp|2 tra sp|tbp,*0 return to pl1 program " " operator to store a string with an adjustable bit offset. " entered with bit size in x6. " string_store: eax1 0,7 bit offset to x1 tra ss_0 " string_store_co: eax1 0,7 char offset to x1 cmpx1 4,du is offset >= 36 bits tmi 3,ic no eppbp bp|1 yes, adjust destination pointer eax1 -4,1 and offset ldx1 co_to_bo,1 convert to bit offset tra ss_0 " string_store_ho: eax1 0,7 half word offset to x1 cmpx1 2,du is offset >= 36 bits tmi 3,ic no eppbp bp|1 yes, adjust destination pointer eax1 -2,1 and offset ldx1 ho_to_bo,1 convert to bit offset " ss_0: adwpbp 0,du erase bit offset staq sp|double_temp save in aligned temp csl (ar+rl),(ar+rl+x1),bool(move) move into target descb sp|double_temp,x6 descb bp|0,x6 tra sp|tbp,*0 " " operator to return in aq the first 72 bits of the char string " specified by string_aq. if the length if less than 72 bits, string is padded " with blanks " fetch_chars: ldq sp|char_lg1 load char length eppap sp|temp_pt,* get ptr to temp tra gc_1 join common case " " operator to return in aq the first 72 bits of an adjustable char " string. if length is less than 72 bits, string is padded. " note: compiled code expects bp not to be changed " get_chars: eax1 0,7 load offset tra gc_0 " get_chars_co: ldx1 co_to_bo,7 convert offset to bits tra gc_0 " get_chars_ho: ldx1 ho_to_bo,7 convert offset to bits tra gc_0 " get_chars_aligned: eax1 0 get zero offset " gc_0: eppap bp|0 copy ptr to string adwpap 0,du erase bit offset abd ap|0,1 add new bit offset " gc_1: mlr (ar+rl),(ar),fill(blank) move to aligned temp desc9a ap|0,ql desc9a sp|temp,8 eppap sp|stack_frame.operator_ptr,* ldaq sp|temp tra sp|tbp,*0 " " operator to return in aq the first 72 bits of the char string " specified by string aq. if the length is less than 72 bits, string " is padded with binary zeroes. " fetch_chars_eis: ldq sp|char_lg1 load char length eppap sp|temp_pt,* get ptr to temp mlr (ar+rl),(ar),fill(0) move to aligned temp desc9a ap|0,ql desc9a sp|temp,8 eppap sp|stack_frame.operator_ptr,* ldaq sp|temp tra sp|tbp,*0 " " operator to return in aq the first 72 bits of the bit string " specified by string_aq. if length is less than 72 bits, " string is padded. " fetch_bits: "eis comes here, too eppap sp|temp_pt,* get ptr to temp ldq sp|bit_lg1 get bit length eax1 0 use 0 bit offset tra gb_1 " " operator to return in aq the first 72 bits of an adjustable bit " string. if length is less than 72 bits, string is padded. " note: compiled code expects bp not to be changed " get_bits: eax1 0,7 load offset tra gb_0 " get_bits_co: ldx1 co_to_bo,7 convert offset to bits tra gb_0 " get_bits_ho: ldx1 ho_to_bo,7 convert offset to bits tra gb_0 " get_bits_aligned: eax1 0 get zero offset " gb_0: eppap bp|0 copy ptr to string adwpap 0,du erase bit offset " gb_1: csl (ar+rl+x1),(ar),bool(move) move to aligned temp descb ap|0,ql descb sp|temp,72 eppap sp|stack_frame.operator_ptr,* ldaq sp|temp tra sp|tbp,*0 " " operator to pad the char string temporary to 8 chars. " pad_chars: ldq 8,dl compute number of chars left sbq sp|char_lg1 tmoz sp|tbp,*0 lda sp|char_lg1 get offset eppap sp|temp_pt,* get ptr to temp mlr (0),(ar+rl+a),fill(blank) put fill(blank)s at end vfd 36/0 desc9a ap|0,ql eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operator to pad the bit string temporary to 72 bits. " pad_bits: ldq sp|bit_lg1 get bit length of temp cmpq 73,dl is it already long enough trc sp|tbp,*0 yes, return adq sp|bit_lg1 no, form 2*bit_length eax1 1,ql and place in index reg ldaq sp|temp_pt,* mask string anaq bit_mask,1 staq sp|temp_pt,* replace padded string tra sp|tbp,*0 and return to pl/1 program " " operators to AND a string into the string " temporary pointed at by sp|temp_pt. the string being ANDED " is guaranteed to be no bigger than the space in the stack. " and_bits: eax1 0,7 load offset tra and_1 " and_bits_co: ldx1 co_to_bo,7 convert to bit offset tra and_1 " and_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra and_1 " and_bits_aligned: eax1 0 " and_1: lda ana_op pickup logical function to do tra logical join common section " " operators to OR a string into the string " temporary pointed at by sp|temp_pt. the string being ORED " is guaranteed to be no bigger and the space in the stack. " or_bits: eax1 0,7 load offset tra or_1 " or_bits_co: ldx1 co_to_bo,7 convert to bit offset tra or_1 " or_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra or_1 " or_bits_aligned: eax1 0 zero offset " or_1: lda ora_op pickup logical function to do tra logical join common section " " operators to EXCLUSIVE OR a string into the string " temporary pointed at by sp|temp_pt. the string being EXORed " is guaranteed to be no bigger than the space in the stack. " exor_bits: eax1 0,7 load offset tra exor_1 " exor_bits_co: ldx1 co_to_bo,7 convert to bit offset tra exor_1 " exor_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra exor_1 " exor_bits_aligned: eax1 0 zero offset " exor_1: lda era_op pickup logical function to do tra logical join common section " " operators to MOVE a string into the string " temporary pointed at by sp|temp_pt. the string being MOVED " is guaranteed to be no bigger than the space in the stack. " since this operator is always followed by concatenation, no " padding is done. " cat_move_bits: eax1 0,7 load offset tra cmb_1 " cat_move_bits_co: ldx1 co_to_bo,7 convert to bit offset tra cmb_1 " cat_move_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra cmb_1 " cat_move_bits_aligned: eax1 0 zero bit offset " cmb_1: stq sp|cat_lg1 save for later cat operator cmpq 0,dl return if nothing to move (prevent IPR) tze sp|tbp,*0 adwpbp 0,du clear bit offset eppap sp|temp_pt,* get ptr to target csl (ar+rl+x1),(ar+rl),bool(move) move source into temp descb bp|0,ql descb ap|0,ql eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operators to MOVE the COMPLEMENT of astring into " the string temporary pointed at by sp|temp_pt. the string " being moved is guaranteed to be the same size as the " destination. " move_not_bits: eax1 0,7 load offset tra move_not_1 " move_not_bits_co: ldx1 co_to_bo,7 convert to bit offset tra move_not_1 " move_not_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra move_not_1 " move_not_bits_aligned: eax1 0 zero offset " move_not_1: lda not_op pickup logical function to do tra logical join common section " " operators to MOVE a string into the string " temporary pointed at by sp|temp_pt. the string being MOVED " is guaranteed to be no bigger than the size of the destination. " move_bits: eax1 0,7 load offset tra mb_1 " move_bits_co: ldx1 co_to_bo,7 convert to bit offset tra mb_1 " move_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra mb_1 " move_bits_aligned: eax1 0 zero offset " mb_1: lda nop_op pickup logical function to do " logical: sta sp|bit_op save operator to perform lda sp|bit_lg1 get length of temp tze sp|tbp,*0 exit if zero (prevent IPR) adwpbp 0,du clear bit offset eppap sp|temp_pt,* get ptr to temp xec sp|bit_op do the operation descb bp|0,ql descb ap|0,al log_exit: eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " logical functions... " nop_op: csl (ar+rl+x1),(ar+rl),bool(move) ana_op: csl (ar+rl+x1),(ar+rl),bool(and) ora_op: csl (ar+rl+x1),(ar+rl),bool(or) era_op: csl (ar+rl+x1),(ar+rl),bool(xor) not_op: csl (ar+rl+x1),(ar+rl),bool(invert) " " operators to MOVE a string into the string " temporary pointed at by sp|temp_pt. the string being MOVED " is guaranteed to be no bigger than the space in the stack. " if this is cat_move_chars, no padding will be done since " operator is always followed by concat. " move_chars: eax1 0,7 load offset tra mc_1 " move_chars_co: ldx1 co_to_bo,7 convert to bit offset tra mc_1 " move_chars_ho: ldx1 ho_to_bo,7 convert to bit offset tra mc_1 " move_chars_aligned: eax1 0 " mc_1: adwpbp 0,du clear bit offset abd bp|0,1 add new bit offset lda sp|char_lg1 get length of target tze sp|tbp,*0 exit if zero (prevent IPR) eppap sp|temp_pt,* get ptr to target mlr (ar+rl),(ar+rl),fill(blank) desc9a bp|0,ql desc9a ap|0,al eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " cat_move_chars: eax1 0,7 load offset tra cmc_1 " cat_move_chars_co: ldx1 co_to_bo,7 convert to bit offset tra cmc_1 " cat_move_chars_ho: ldx1 ho_to_bo,7 convert to bit offset tra cmc_1 " cat_move_chars_aligned: eax1 0 zero bit offset " cmc_1: adwpbp 0,du clear bit offset abd bp|0,1 add new bit oofset stq sp|cat_lg1 save for following cat cmpq 0,dl exit if nothing to move (prevent IPR) tze sp|tbp,*0 eppap sp|temp_pt,* get ptr to target mlr (ar+rl),(ar+rl) desc9a bp|0,ql desc9a ap|0,ql eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operator to AND a single length bit string into the string " temporary pointed at by sp|temp_pt. words 1,2,3,... of the " temporary are cleared. " ext_and_1: ldq 0,dl clear q and join ext_and_2 " " operator to AND a double length bit string into the string " temporary pointed at by sp|temp_pt. words 2,3,... of the " temporary are cleared. " ext_and_2: eppbp sp|temp_pt,* get ptr to string ansa bp|0 AND in the string ansq bp|1 .. eax1 2 clear starting at word 2 " " routine to zero rest of string temp " this routine returns directly to pl/1 program " at entry: " bp|0,1 points at first word to be cleared " sp|temp_size holds total size of temporary " zero_it: eaa 0,1 get current position era mask_bit_one form 2's complement of whole a-reg adla 1,dl w/o overflow adla sp|temp_size .. tmoz sp|tbp,*0 return if none eppbp bp|0,1 get ptr to starting pos arl 18-2 get number of chars mlr (0),(ar+rl) clear the area vfd 36/0 desc9a bp|0,al eppbp sp|temp_pt,* restore ptr to tem (just in case) tra sp|tbp,*0 return to pl/1 program " " " operator to complement the bit string temporary pointed " at by sp|temp_pt " comp_bits: ldq sp|bit_lg1 get bit length tze sp|tbp,*0 exit if zero length (prevent IPR) eppbp sp|temp_pt,* get ptr to temp csl (ar+rl),(ar+rl),bool(invert) negate descb bp|0,ql descb bp|0,ql tra log_exit " " operator to move string_1 into string_2 " source string_1 was previously setup " chars_move_vt: stq bp|-1 store size of string " chars_move: eax1 0,7 load offset tra cm_1 " chars_move_vt_co: stq bp|-1 store size of string " chars_move_co: ldx1 co_to_bo,7 convert to bit offset tra cm_1 " chars_move_vt_ho: stq bp|-1 store size of string " chars_move_ho: ldx1 ho_to_bo,7 convert to bit offset tra cm_1 " chars_move_vta: stq bp|-1 store size of string " chars_move_aligned: eax1 0 zero offset " cm_1: cmpq 0,dl return if target zero length tze sp|tbp,*0 adwpbp 0,du clear bit offset abd bp|0,1 eppap sp|temp_pt,* get ptr to source lda sp|char_lg1 get length of source mlr (ar+rl),(ar+rl),fill(blank) desc9a ap|0,al desc9a bp|0,ql eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " bits_move_vt: stq bp|-1 store size of string " bits_move: eax1 0,7 load offset tra bm_1 " bits_move_vt_co: stq bp|-1 store size of string " bits_move_co: ldx1 co_to_bo,7 convert to bit offset tra bm_1 " bits_move_vt_ho: stq bp|-1 store size of string " bits_move_ho: ldx1 ho_to_bo,7 tra bm_1 " bits_move_vta: stq bp|-1 store siqe of string " bits_move_aligned: eax1 0 zero bit offset " bm_1: cmpq 0,dl return if zerolength target tze sp|tbp,*0 adwpbp 0,du clear target bit offset abd bp|0,1 add new bit offset eppap sp|temp_pt,* get ptr to source lda sp|bit_lg1 csl (ar+rl),(ar+rl),bool(move) descb ap|0,al descb bp|0,ql eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operators to move string_1 into string_2 " when the size prefix is enabled " chars_move_ck: eax1 0,7 get offset tra cmk_1 " chars_move_ck_co: ldx1 co_to_bo,7 convert to bit offset tra cmk_1 " chars_move_ck_ho: ldx1 ho_to_bo,7 convert to bit offset tra cmk_1 " chars_move_ck_al: eax1 0 zero offset " cmk_1: adwpbp 0,du erase bit offset abd bp|0,1 add new offset eppap sp|temp_pt,* get ptr to source lda sp|char_lg1 get length of source mlr (ar+rl),(ar+rl),fill(blank),enablefault desc9a ap|0,al desc9a bp|0,ql tra log_exit " bits_move_ck: eax1 0,7 get offset tra bmk_1 " bits_move_ck_co: ldx1 co_to_bo,7 convert to bit offset tra bmk_1 " bits_move_ck_ho: ldx1 ho_to_bo,7 convert to bit offset tra bmk_1 " bits_move_ck_al: eax1 0 zero offset " bmk_1: adwpbp 0,du erase bit offset abd bp|0,1 add new offset eppap sp|temp_pt,* get ptr to source lda sp|bit_lg1 get length of source csl (ar+rl),(ar+rl),bool(move),enablefault desc9a ap|0,al desc9a bp|0,ql tra log_exit " " operators to perform concatenation. this is done by moving " the second string into the stack just after the first string. " length of first string is given by sp|cat_lg1 which is set " by a previous cat_move_... operator or by a previous cat_realloc_... " cat_chars: eax1 0,7 save offset tra cat_chars_aligned+1 " cat_chars_co: ldx1 co_to_bo,7 convert to bit offset tra cat_chars_aligned+1 " cat_chars_ho: ldx1 ho_to_bo,7 convert to bit offset tra cat_chars_aligned+1 " cat_chars_aligned: eax1 0 zero offset cmpq 0,dl return if nothing to concat tze cat_done adwpbp 0,du clear bit offset abd bp|0,1 add new bit offset lda sp|cat_lg1 get offset for concat eppap sp|temp_pt,* get ptr to temp mlr (ar+rl),(ar+rl+a) desc9a bp|0,ql desc9a ap|0,ql eppap sp|stack_frame.operator_ptr,* cat_done: eppbp sp|temp_pt,* tra sp|tbp,*0 " cat_bits: eax1 0,7 save offset tra cat_bits_aligned+1 " cat_bits_co: ldx1 co_to_bo,7 convert to bit offset tra cat_bits_aligned+1 " cat_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra cat_bits_aligned+1 " cat_bits_aligned: eax1 0 zero offset cmpq 0,dl tze cat_done return if none to concat adwpbp 0,du erase bit offset lda sp|cat_lg1 get offset in temp eppap sp|temp_pt,* get ptr to temp csl (ar+rl+x1),(ar+rl+a),bool(move) descb bp|0,ql descb ap|0,ql tra cat_done-1 " " operator to perform repeat function (copy builtin) on char string in the string AQ. " entered with number of copies desired in q " repeat: cmpq 0,dl take max(n_copies,0) tpl 2,ic ldq 0,dl stq sp|count save number of copies desired eppap sp|temp_pt,* get ptr to string szn sp|bit_or_char which case is this tnz repeat_bs ldq sp|char_lg1 get length of string mpy sp|count compute length of result stq sp|lg2 and save for later adq 3+8,dl compute number of words (2 extra) qrs 2 tsx1 alloc allocate new temp eppbp bp|2 skip over 2 words at front spribp sp|temp_pt save ptr to result lxl1 sp|count init loop tze repeat_exit+1 skip if nothing to do ldq sp|char_lg1 get back length of input tze repeat_exit+2 skip if nothing to do repeat_cs_loop: mlr (ar+rl),(ar+rl) move string desc9a ap|0,ql desc9a bp|0,ql a9bd bp|0,ql add char length sbx1 1,du tnz repeat_cs_loop repeat until done repeat_exit: eppbp sp|temp_pt,* get ptr to result ldq sp|lg2 get length of result stq bp|-1 save stq sp|char_lg1 stq sp|bit_lg1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 and return " " operator to perform repeat function (copy builtin) on bit string in the string AQ. " entered with number of copies desired in q " repeat_bs: ldq sp|bit_lg1 get length of string mpy sp|count compute length of result stq sp|lg2 and save for later adq 35+72,dl compute number of words (2 extra) div 36,dl tsx1 alloc allocate new temp eppbp bp|2 skip over 2 extra words spribp sp|temp_pt save ptr to result lxl1 sp|count init loop tze repeat_exit+1 skip if nothing to do ldq sp|bit_lg1 get back length of input tze repeat_exit+2 exit now if nothing to do repeat_bs_loop: csl (ar+rl),(ar+rl),bool(move) descb ap|0,ql descb bp|0,ql abd bp|0,ql add bit length of string sbx1 1,du repeat until done tnz repeat_bs_loop tra repeat_exit " " operator to reverse bit string in the string AQ. " reverse_bs: eppap sp|temp_pt,* get ptr to source ldq sp|bit_lg1 get bit length adq 35+72,dl compute word length needed (2 extra) div 36,dl tsx1 alloc extend stack eppbp bp|2 skip over 2 words at front spribp sp|temp_pt save ptr to result ldq sp|bit_lg1 get back bit length stq bp|-1 save tze log_exit exit if nothing to do lda 0,dl init offset reverse_bs_loop: sbq 1,dl tmi reverse_bs_exit done, exit csl (ar+q),(ar+a),bool(move) move 1 bit descb ap|0,1 descb bp|0,1 ada 1,dl update offset tra reverse_bs_loop reverse_bs_exit: ldq sp|bit_lg1 get back length tra log_exit " " operator to reverse character string in the string AQ. " reverse_cs: eppap sp|temp_pt,* get ptr to source ldq sp|char_lg1 get char length adq 3+8,dl compute word length needed (2 extra) qrs 2 tsx1 alloc extend stack eppbp bp|2 skip over 2 words at front spribp sp|temp_pt save ptr to result ldq sp|char_lg1 get back char length stq bp|-1 save tze log_exit return if nothing to do lda 0,dl init offset reverse_cs_loop: sbq 1,dl tmi reverse_cs_exit done, exit mlr (ar+q),(ar+a) move 1 char desc9a ap|0,1 desc9a bp|0,1 ada 1,dl update offset tra reverse_cs_loop reverse_cs_exit: ldq sp|char_lg1 tra log_exit " " operator to suffix the string previously set up to a varying string. " entered with pointer to varying string in bp, max length in q " suffix_cs: sbq bp|-1 get number of chars left in string tze sp|tbp,*0 return if string is full cmpq sp|char_lg1 get min(number left,number set up) tmi 2,ic suffix_cs_1: ldq sp|char_lg1 get length of suffix tze sp|tbp,*0 exit if zero (prevent IPR) eppap sp|temp_pt,* get ptr to suffix lda bp|-1 get offset of end mlr (ar+rl),(ar+rl+a) suffix string desc9a ap|0,ql desc9a bp|0,ql asq bp|-1 update string length eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 and return " " operator to suffix to varying bit string. " suffix_bs: sbq bp|-1 get number of bits left in string tze sp|tbp,*0 return if string full cmpq sp|bit_lg1 get min(number left,number set up) tmi 2,ic suffix_bs_1: ldq sp|bit_lg1 get length of suffix tze sp|tbp,*0 exit if zero (prevent IPR) eppap sp|temp_pt,* get ptr to suffix lda bp|-1 get offset of last bit available csl (ar+rl),(ar+rl+a),bool(move) descb ap|0,ql descb bp|0,ql asq bp|-1 update string length eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 and return " " operators to suffix the string previously set up to a varying string " when the stringsize condition is enabled. entered with pointer " to string in bp, max length in q " suffix_cs_ck: sbq bp|-1 get number of chars left tze 3,ic cmpq sp|char_lg1 get min(number left,number set up) tpl suffix_cs_1 eaa suffix_cs_1 error, signal stringsize " suffix_error: sxl0 sp|stack_frame.operator_ret_ptr no, signal stringsize spribp sp|double_temp staq sp|temp eppbp stringsize_name eax6 stringsize_length ldq =702,dl get oncode value tsx1 call_signal_ lxl0 sp|stack_frame.operator_ret_ptr eppbp sp|double_temp,* ldaq sp|temp tra 1,au join standard section " suffix_bs_ck: sbq bp|-1 tze 3,ic cmpq sp|bit_lg1 tpl suffix_bs_1 eaa suffix_bs_1 tra suffix_error " " operator to compare string_2 with previously setup string_1 " cp_chars: eax1 0,7 save offset tra cp_chars_aligned+1 " cp_chars_co: ldx1 co_to_bo,7 convert to bit offset tra cp_chars_aligned+1 " cp_chars_ho: ldx1 ho_to_bo,7 convert to bit offset tra cp_chars_aligned+1 " cp_chars_aligned: eax1 0 zero offset adwpbp 0,du abd bp|0,1 add new bit offset cpcs_1: eppap sp|temp_pt,* get ptr to string_1 lda sp|char_lg1 get length(string_1) cmpc (ar+rl),(ar+rl),fill(blank) desc9a bp|0,ql string_2 desc9a ap|0,al string_1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " cp_bits: eax1 0,7 save offset tra cp_bits_aligned+1 " cp_bits_co: ldx1 co_to_bo,7 convert to bit offset tra cp_bits_aligned+1 " cp_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra cp_bits_aligned+1 " cp_bits_aligned: eax1 0 zero ofset adwpbp 0,du erase bit offset cpbs_1: eppap sp|temp_pt,* get ptr to string_1 lda sp|bit_lg1 cmpb (ar+rl+x1),(ar+rl) descb bp|0,ql string_2 descb ap|0,al string 1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operators to compare single (double) word string in a-reg (aq_reg) " with string previously setup " cpcs_ext1: ldq blanks convert to double length string " cpcs_ext2: staq sp|double_temp save string in aq ldq 8,dl get length eppbp sp|double_temp get ptr to string tra cpcs_1 " cpbs_ext1: ldq 0,dl convert to double length string " cpbs_ext2: staq sp|double_temp save string in aq ldq 72,dl eppbp sp|double_temp tra cpbs_1 " " operator to check an unaligned string for any non-zero bits. " cpbs3: eax1 0,7 load offset tra cpbs3a " cpbs3_co: ldx1 co_to_bo,7 convert to bit offset tra cpbs3a " cpbs3_ho: ldx1 ho_to_bo,7 convert to bit offset tra cpbs3a " " operator to check the aligned string temp pointed at by " temp_pt for any non_zero bits " cpbs4: ldq sp|bit_lg1 get bit length eppbp sp|temp_pt,* get ptr to string " cpbs3_aligned: eax1 0 zero offset " cpbs3a: adwpbp 0,du erase bit offset cmpb (ar+rl+x1),(0) descb bp|0,ql vfd 36/0 tra sp|tbp,*0 " " operators to blank out a character string " blank_chars: eax1 0,7 get offset tra bc_1 " blank_chars_co: ldx1 co_to_bo,7 convert to bit offset tra bc_1 " blank_chars_ho: ldx1 ho_to_bo,7 convert to bit offset tra bc_1 " blank_chars_aligned: eax1 0 zero offset " bc_1: cmpq 0,dl return if string zero length tze sp|tbp,*0 adwpbp 0,du erase bit offset abd bp|0,1 add new offset mlr (0),(ar+rl),fill(blank) vfd 36/0 desc9a bp|0,ql tra sp|tbp,*0 " " operators to zero out a bit string " zero_bits: eax1 0,7 get bit offset tra zb_1 " zero_bits_co: ldx1 co_to_bo,7 convert to bit offset tra zb_1 " zero_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra zb_1 " zero_bits_aligned: eax1 0 get zero offset " zb_1: cmpq 0,dl return if string zero length tze sp|tbp,*0 adwpbp 0,du erase bit offset csl (0),(ar+rl+x1),bool(move) descb bit_mask,0 (avoid csl bug by using real address) descb bp|0,ql tra sp|tbp,*0 " " operators to copy a constant into a temporary of the same size " entered with destination in bp, length in q, and text location of " constant in x1 " copy_const_vt: stq bp|-1 set size " copy_const: eppap sp|tbp,*1 get ptr to constant mlr (ar+rl),(ar+rl) desc9a ap|0,ql desc9a bp|0,ql eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operator to compute index(str1,str2). entered with str1 specified " by previous set operator. " " index_chars: eax1 0,7 get bit offset tra ixc " index_chars_co: ldx1 co_to_bo,7 convert to bit offset tra ixc " index_chars_ho: ldx1 ho_to_bo,7 convert to bit offset tra ixc " index_chars_aligned: eax1 0 get zero offset " ixc: adwpbp 0,du erase bit offset abd bp|0,1 add new bit offset " General entry index_chars_eis: ixc2: eppap sp|temp_pt,* get ptr to string_1 lda sp|char_lg1 Get length 1 cmpq sp|char_lg1 Too long? tpnz zix cmpq 1,dl are we looking for single char tpnz ixcs_long Big string tmi zix 0-length is failure. ixc1: scm (ar+rl),(ar) desc9a ap|0,al desc9a bp|0,0 arg sp|temp ttn zix tally runout means not found ixc_ret_ok: ldq sp|temp get index adq 1,dl convert to pl1 index value eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " index failed " zix: ldq 0,dl eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " string_2 is more than 1 character " ixcs_long: stq sp|lg2 save length of string_2 lrl 36 l(string1) =>q, 0 => a sblq sp|lg2 Don't search last l(string2) stq sp|t2 save lg(s1) - lg (s2) ixcs_loop: adlq 2,dl ok to match 2 more scd (ar+rl+a),(ar) Look for prefix desc9a ap|0,ql desc9a bp|0 arg sp|temp ttn zix Fails. " " See if string really won. " adla 1,dl add 1 both for pl1 result and new offs adla sp|temp This gonna be real offset. sta sp|temp Leave in a and temp ldq sp|lg2 Compare whole string cmpc (ar+rl+a),(ar+rl) desc9a ap|-1(3),ql ql = length desc9a bp|0,ql string 2 length tze ixc_ret_ok_1 answer in a ldq sp|t2 charlg1 - lg2 sblq sp|temp tpl ixcs_loop tra zix Nothing left to search ixc_ret_ok_1: lrl 36 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " Operator to compute index (rev(string1),rev(string2)) " Same conventions as ix_chars. ix_rev_chars: cmpq sp|char_lg1 String 2 bigger than 1? tpnz zix Quick failure. eppap sp|temp_pt,* Get searchee ptr lda sp|char_lg1 Load up searchee length cmpq 1,dl Search for 0, 1, or 2? tmi zix Immediate failure for 0. tpnz ix_rev_long 2 or more chars " Search for 1 char. Searchee guaranteed to be at least 1 long. " " ap = ptr to string1 " bp = ptr to string2 " a = length(string1) " q = length(string2) = 1 " x0 = return offset scmr (pr,rl),(pr) desc9a ap|0,al desc9a bp|0 arg sp|temp ttn zix " Was string2 found in string1? tra ixc_ret_ok " Yes: return 1-origin index " Now known to be 2 or more characters to search for " in string guaranteed 2 or more long. Note that a leading " prefix of the searchee of length (length (searchstring)-2) " need not be searched. " ix_rev_long: stq sp|lg2 length (searchstring) sbla sp|lg2 Deduct l(ss)-2 from searchable len adla 2,dl ix_rev_loop: scdr (ar+rl+q),(ar+q) q is l(searchstring) desc9a ap|-1(2),al a is searchable length of searchee desc9a bp|-1(2) Gets last 2 chars arg sp|temp Answer ttn zix Clear and present failure " " See if we really found the string. This algebra " really, really works. " sbla 2,dl sbla sp|temp " " Compare the full string. Length still in q, offset now in a. " cmpc (ar+rl+a),(ar+rl) desc9a ap|0,ql desc9a bp|0,ql tnz ix_rev_more Nope. Try some more. " " String found. Find how many chars left on other side. " adla sp|lg2 length(searchstring) sbla sp|char_lg1 this is negative neg 0 adla 1,dl for PL/I convention lrl 36 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 return. ix_rev_more: adla 1,dl This is right. cmpa 2,dl Still left to search? tmi zix Search fails if not tra ix_rev_loop New stuff in a. " " Bit index operators " index_bits_eis: cmpq 0,dl exit now if string_2 zero length tze sp|tbp,*0 tra ixb2 join common case " index_bits: eax1 0,7 get bit offset tra ixb " index_bits_co: ldx1 co_to_bo,7 convert to bit offset tra ixb " index_bits_ho: ldx1 ho_to_bo,7 convert to bit offset tra ixb " index_bits_aligned: eax1 0 get zero offset " ixb: cmpq 0,dl exit if string 2 zero length tze sp|tbp,*0 adwpbp 0,du erase bit offset abd bp|0,1 use new bit offset ixb2: eppap sp|temp_pt,* get ptr to string_1 ixb1: stq sp|lg2 save length of string_2 ldq 0,dl init loop ixbs_loop: stq sp|count lda sp|bit_lg1 compute number of remaining bits in 1 sba sp|count cmpa sp|lg2 must be >= length 2 tmi zix lda sp|lg2 get length 2 adq 1,dl convert skip count to pl1 index cmpb (ar+rl),(ar+rl+q) descb bp|0,al descb ap|-1(35),al tnz ixbs_loop failed, try next value cmpq 0,dl set indicators eppap sp|stack_frame.operator_ptr,* index in q, exit tra sp|tbp,*0 " " operator to compute index(str1,str2) when str2 is a single char. " entered with value of str2 in a register. " index_cs_1_eis: cmpq 0,dl exit now if string 1 zero length tze sp|tbp,*0 tra ixcs1_b join common cae index_cs_1: eax1 0,7 convert to bit offset tra ixcs1_a join common section " index_cs_1_co: ldx1 co_to_bo,7 get bit offset tra ixcs1_a " index_cs_1_ho: ldx1 ho_to_bo,7 convert to bit offset tra ixcs1_a " index_cs_1_aligned: eax1 0 get zero offset " ixcs1_a: cmpq 0,dl return immediately if string 1 zero length tze sp|tbp,*0 adwpbp 0,du clear bit offset abd bp|0,1 use new bit offset ixcs1_b: eppap bp|0 put ptr to string 1 in proper register sta sp|temp2 save the character eppbp sp|temp2 get ptr to it as string 2 lls 36 Needed in a tra ixc1 " " operators to search a bit string for a single bit " index_bs_1_eis: cmpq 0,dl exit now if string 1 zero length tze sp|tbp,*0 tra ixbs1_b join common case " index_bs_1: eax1 0,7 save bit offset tra ixbs1_a " index_bs_1_co: ldx1 co_to_bo,7 convert to bit offset tra ixbs1_a " index_bs_1_ho: ldx1 ho_to_bo,7 convert to bit offset tra ixbs1_a " index_bs_1_aligned: eax1 0 get zero offset " ixbs1_a: cmpq 0,dl return immediately if string 1 zero length tze sp|tbp,*0 adwpbp 0,du clear bit offset abd bp|0,1 add new bit offset ixbs1_b: eppap bp|0 put ptr to string 1 in proper register stq sp|bit_lg1 save length of string_1 sta sp|temp2 save the bit eppbp sp|temp2 get ptr to it as string 2 ldq 1,dl get length of string 2 tra ixb1 " " index operators used with before and after. entered " with str1 specified by previous set operator " index_before_cs: cmpq 0,dl exit now if str2 zero length tze sp|tbp,*0 eax1 0 set flag tra ixba " index_after_cs: cmpq 0,dl exit now if str2 zero length tze sp|tbp,*0 eax1 1 set flag ixba: eppap sp|temp_pt,* get ptr to str1 cmpq 1,dl are we looking for single char tnz ixba_long no, skip ldq sp|char_lg1 get length of str1 scm (ar+rl),(ar) desc9a ap|0,ql desc9a bp|0,1 arg sp|temp ttn ixba_fail+1 ldq sp|temp get result xec nop_adq_dl,1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " index failed " ixba_fail: ldq sp|char_lg1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " ixba_bs_fail: ldq sp|bit_lg1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " nop_adq_dl: nop 0,dl before adq 1,dl after " " str2 is more than 1 char " ixba_long: stq sp|lg2 save length(str2) ldq 0,dl init loop ixba_loop: stq sp|count lda sp|char_lg1 get number remaining in str1 sba sp|count cmpa sp|lg2 failed if < length(str2) tmi ixba_fail scd (ar+rl+q),(ar) check for first 2 chars of str2 desc9a ap|0,al desc9a bp|0,2 arg sp|temp ttn ixba_fail tally runout means failure sba sp|temp compute length of hit cmpa sp|lg2 must be >= length(str2) tmi ixba_fail adq sp|temp update adq 1,dl prepare to bump past hit lda sp|lg2 check full str2 cmpc (ar+rl+q),(ar+rl) desc9a ap|-1(3),al desc9a bp|0,al tnz ixba_loop sbq 1,dl we want offset, NOT pl1 index xec nop_adq,1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " nop_adq: nop 0,dl before adq sp|lg2 after " index_before_bs: cmpq 0,dl exit now if str2 zero length tze sp|tbp,*0 eax1 0 tra ixba_bs " index_after_bs: cmpq 0,dl exit now if str2 zero length tze sp|tbp,*0 eax1 1 ixba_bs: eppap sp|temp_pt,* get ptr to str1 ixba_bs1: stq sp|lg2 save length(str2) ldq 0,dl init loop ixba_bs_loop: stq sp|count lda sp|bit_lg1 compute remaining bits in str1 sba sp|count cmpa sp|lg2 must be >= length(str2) tmi ixba_bs_fail lda sp|lg2 get length(str2) adq 1,dl prepare to skip past the bit cmpb (ar+rl),(ar+rl+q) descb bp|0,al descb ap|-1(35),al tnz ixba_bs_loop sbq 1,dl want offset, not pl1 index xec nop_adq,1 eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " index_before_bs_1: cmpq 0,dl exit now if str1 zero len tze sp|tbp,*0 eax1 0 tra ixba_bs2 " index_after_bs_1: cmpq 0,dl exit now if str1 zero length tze sp|tbp,*0 eax1 1 ixba_bs2: eppap bp|0 put ptr to str1 in proper register stq sp|bit_lg1 save length(str1) sta sp|temp2 save the bit eppbp sp|temp2 get ptr to it as str2 ldq 1,dl get length of str2 tra ixba_bs1 " " operators to make bit table for use with verify operator. " entered with pointer to string in bp, offset in x7, size in q, and " stack offset of bit table in au. " make_bit_table: eax1 0,7 get offset tra mbt " make_bit_table_co: ldx1 co_to_bo,7 convert offset to bits tra mbt " make_bit_table_ho: ldx1 ho_to_bo,7 convert offset to bits tra mbt " make_bit_table_al: eax1 0 zero offset " mbt: epbpap sp|0 get ptr to base of stack eawpap 0,au get ptr to bit table stq sp|char_lg1 save - length of string fld 0,dl zero out the bit table staq ap|0 staq ap|2 lcq sp|char_lg1 tze log_exit return if zero length string stq sp|char_lg1 mbt_1: ldq bp|0 get current word of string lls 4,1 shift char to straddle aq, i.e. 00xx|yyyyy qrl 4+9 put 5 bit index in qu ana 3,dl get 2 bit word index in al ldq single_bit,qu get single bit at right position orsq ap|0,al insert in bit table aos sp|char_lg1 count down tze log_exit zero means we're done adx1 9,du update offset cmpx1 36,du do we need another word tmi mbt_1 no, finish this one eax1 0 yes, set offset to zero eppbp bp|1 update for next word tra mbt_1 and repeat " " operators to make bit table for use by search builtin function " entered with point to string in bp, offset in x7, size in q, and " stack offset of bit table in au. The bit table constructed by " these operators are the complement of that constructed by " the make_bit_temp operator. " form_bit_table: eax1 0,7 get offset tra fbt " form_bit_table_co: ldx1 co_to_bo,7 convert offset to bits tra fbt " form_bit_table_ho: ldx1 ho_to_bo,7 convert offset to bits tra fbt " form_bit_table_al: eax1 0 zero offset " fbt: epbpap sp|0 get ptr to base of stack eawpap 0,au get ptr to bit table stq sp|char_lg1 save - length of string ldaq mask_bit staq ap|0 init table to all 1s staq ap|2 lcq sp|char_lg1 tze log_exit return of zero length string stq sp|char_lg1 fbt_1: ldq bp|0 get current word of string lls 4,1 shift char to straddle aq, i.e. 00xx|yyyyy qrl 4+9 put 5 bit index in qu ana 3,dl get 2 bit word index in al ldq single_bit,qu get single 1 bit at right position erq ones convert to single 0 in right position ansq ap|0,al erase bit in bit table aos sp|char_lg1 cont down tze log_exit zero means done adx1 9,du update offset cmpx1 36,du do we need another word tmi fbt_1 no, ifnish this one eax1 0 yes, set offset to zero eppbp bp|1 update for next word tra fbt_1 and repeat " " operators to verify|search a string with bit table stored in stack. " entered with pointer to string in bp, offset in x7, size in q, " and tack offset of bit table in au. " verify: eax1 0,7 get offset tra ver_1 " verify_co: ldx1 co_to_bo,7 convert to bit offset tra ver_1 " verify_ho: ldx1 ho_to_bo,7 convert to bit offset tra ver_1 " verify_al: eax1 0 zero offset ver_1: epbpap sp|0 get ptr to bit table eawpap 0,au .. tra ver_3 join common section " " operators to verify|search a string with constant bit table. " entered with pointer to string in bp, offset in x7, size in q, " and text offset of bit table in au. " const_verify: eax1 0,7 get offset tra ver_2 " const_verify_co: ldx1 co_to_bo,7 convert to bit offset tra ver_2 " const_verify_ho: ldx1 ho_to_bo,7 convert to bit offset tra ver_2 " const_verify_al: eax1 0 zero offset ver_2: eppap sp|tbp,*au get ptr to bit table " ver_3: stq sp|char_lg1 save - length of string lcq sp|char_lg1 tze log_exit return zero if zero length stq sp|lg2 ver_4: ldq bp|0 get current word of string lls 4,1 shift char to straddle aq, i.e. 00xx|yyyyy qrl 4+9 put 5 bit index yyyyy in qu ana 3,dl get 2 bit word index in al lda ap|0,al get word from bit table als 0,qu shift to get bit into sign position tpl ver_fail plus means char from string not in class aos sp|lg2 char ok, update for next tze ver_done adx1 9,du update shift amount cmpx1 36,du do we need another word tmi ver_4 no, repeat eax1 0 yes, zero shift eppbp bp|1 update word pointer tra ver_4 and repeat ver_done: ldq 0,dl all chars in class, return zero tra log_exit ver_fail: eppap sp|stack_frame.operator_ptr,* restore ptr to operator table ldq sp|lg2 exit with index of char that failed adq sp|char_lg1 adq 1,dl tra sp|tbp,*0 " " operators to do search|verify(s1,s2) " entered with bp -> s1, ab -> s2, length(s1) in q, length(s2) in a " search_eis: eax1 0 set to do ttf stq sp|char_lg1 save length of s1 ldq 1,dl init loop search_loop: cmpq sp|char_lg1 are we done tpnz search_fail yes, return scm (ar+rl),(ar+q) desc9a ab|0,al desc9a bp|-1(3),0 arg sp|t4 xec ttf_ttn,1 did we hit char adq 1,dl keep looking tra search_loop search_fail: ldq 0,dl return 0 tra sp|tbp,*0 search_done: cmpq 0,dl set indicators tra sp|tbp,*0 and exit " ttf_ttn: ttf search_done ttn search_done " verify_eis: eax1 1 tra search_eis+1 " " Reverse versions of above " verify_rev_chars: eax1 1 tra *+2 search_rev_chars: eax1 0 stq sp|lg2 for later computation search_rev_loop: sblq 1,dl tmi search_fail scm (ar+rl),(ar+q) desc9a ab|0,al desc9a bp|0 arg sp|t4 xec rev_ttf_ttn,1 tra search_rev_loop rev_ttf_ttn: ttf rev_search_done ttn rev_search_done rev_search_done: stq sp|temp ldq sp|lg2 sblq sp|temp tra sp|tbp,*0 " " verify operators for trim bifs entered as above " verify_for_ltrim: "returns offset of 1st char not in str2 scanning from left stq sp|char_lg1 save length of str1 ldq 0,dl init loop (we want offset, rather than pl1 verify index) vfl_loop: cmpq sp|char_lg1 are we done? tpl search_done yes, return scm (ar+rl),(ar+q) desc9a ab|0,al desc9a bp|0,1 arg sp|t4 ttn search_done are we past chars to be trimmed? adq 1,dl no, keep looking tra vfl_loop " verify_for_rtrim: "equivalent to verify_for_ltrim(reverse(... cmpq 0,dl exit if zero tze sp|tbp,*0 stq sp|char_lg1 save length(str1) vfr_loop: scm (ar+rl),(ar+q) desc9a ab|0,al desc9a bp|-1(3),1 arg sp|t4 ttn vfr_done have we gone past chars to be trimmed? sbq 1,dl no, keep looking tpnz vfr_loop vfr_done: erq ones subtract from length(str1) adq 1,dl .. adq sp|char_lg1 .. tra sp|tbp,*0 " " operator to perform translate(s,r) with string s previously set up " entered with pr2 -> r and length(r) in q " translate_2: stq sp|temp save length of r spri3 sp|temp2 epp3 bp|0 save ptr to r ldq sp|char_lg1 get length(s) adq 3+8,dl allocate temp of proper size qrs 2 tsx1 alloc eppap sp|temp_pt,* get ptr to s eppbp bp|2 skip over temp header spribp sp|temp_pt save ptr to temp ldq sp|char_lg1 get length(s) trans2_loop: sbq 1,dl do next char (backwards) tmi trans_done exit if done mrl (ar+ql),(ar) isolate next character with leading zeros desc9a ap|0,1 desc9a sp|num,4 lda sp|num get character from s cmpa sp|temp check against length of r tpl trans2_blank use blank if out of string mlr (ar+al),(ar+ql) move replacement to target desc9a bb|0,1 desc9a bp|0,1 tra trans2_loop trans2_blank: mlr (0),(ar+ql),fill(blank) move in fill(blank) zero desc9a bp|0,1 tra trans2_loop trans_done: epp3 sp|temp2,* eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operator to perform translate(s,r,p) with string s previously set up " entered with pr1 -> p, pr2 -> r, length(p) in a, and length(r) in q " translate_3: staq sp|temp save lengths spri3 sp|temp2 epp3 bp|0 save ptr to r ldq sp|char_lg1 get length(s) adq 3+8,dl allocate temp of proper size qrs 2 tsx1 alloc eppap sp|temp_pt,* get ptr to s eppbp bp|2 skip over temp header spribp sp|temp_pt save ptr to temp ldq sp|char_lg1 get length(s) trans3_loop: sbq 1,dl do next char (backwards) tmi trans_done exit if done lda sp|temp get length(p) scm (ar+rl),(ar+ql) is this char of s in p? desc9a ab|0,al desc9a ap|0,0 arg sp|num ttn trans3_same tally on means not found, use same char lda sp|num get number of chars skipped cmpa sp|temp+1 check against length(r) tpl trans3_blank use blank if out of range mlr (ar+al),(ar+ql) replace with char from r desc9a bb|0,1 desc9a bp|0,1 tra trans3_loop trans3_blank: mlr (0),(ar+ql),fill(blank) move in fill(blank) zero desc9a bp|0,1 tra trans3_loop trans3_same: mlr (ar+ql),(ar+ql) move in char from s desc9a ap|0,1 desc9a bp|0,1 tra trans3_loop " " operator to implement return(*) for unpacked values " entered with pointer to return value in bp, number of " words to return in q, and number of begin blocks to " skip over in x0 " return_words: tsx2 return_pop pop stack back " " the sp has now been put back to old frame to which we are returning, " ap points at the destination of the data being returned. The old stack " frame has been extended to include the stack frame from which we are " returning. " rw_0: qls 2 get number of chars to move tze rw_1 skip if zero (prevent IPR) mlr (ar+rl),(ar+rl) desc9a bp|0,ql desc9a ap|0,ql rw_1: ldq sp|count get back number of words qls 18 in upper adlq 17,du make a multiple of 16 (allow for extra words) anq =o777760,du eax0 ap|-2,qu get offset of end of stack stx0 sp|stack_frame.next_sp+1 and update old frame stx0 sb|stack_header.stack_end_ptr+1 and stack end ptr eppap sp|stack_frame.operator_ptr,* reset pointer to caller's operators ldi sp|stack_frame.return_ptr+1 restore indicators rtcd sp|stack_frame.return_ptr now return to old procedure " " operator to implement return(*) for packed values and bit strings " entered with pointer to return value in bp, number of " bits to move in q, and offset in x7, and number of begin " blocks to skip over in x0 " return_bits: eax1 0,7 get bit offset tra rba " return_bits_co: ldx1 co_to_bo,7 get bit offset tra rba " return_bits_ho: ldx1 ho_to_bo,7 get bit offset tra rba " return_bits_al: eax1 0 get zero offset " rba: adwpbp 0,du erase bit offset abd bp|0,1 add new bit offset " return_bits_eis: stq sp|bit_lg1 save number of bits to move adq 35,dl compute number of words div 36,dl lda sp|bit_lg1 get number of units moved tsx2 return_pop pop stack back " " the sp now points at stack frame to which we are returning, this frame " has been extended to include the frame we are leaving. ap points at " destination of return value. " ldq ap|-1 get back bit length tze rw_1 skip if zero (prevent IPR) csl (ar+rl),(ar+rl),bool(move) descb bp|0,ql descb ap|0,ql tra rw_1 " " operator to implement return(*) for char strings " entered with pointer to return value in bp, number of chars in q, " offset in x7, and number of begin blocks to skip over in x0 " return_chars: eax1 0,7 get bit offset tra rca " return_chars_co: ldx1 co_to_bo,7 get bit offset tra rca " return_chars_ho: ldx1 ho_to_bo,7 get bit offset tra rca " return_chars_aligned: eax1 0 get zero offset " rca: adwpbp 0,du erase bit offset abd bp|0,1 add neew bit offset " return_chars_eis: stq sp|char_lg1 save number of chars to move adq 3,dl compute number of words qrs 2 lda sp|char_lg1 get number of units moved tsx2 return_pop ldq ap|-1 get back number of chars tra rw_0+1 and go move them " " subroutine to reset stack frame for return(*) operators " entered with number of words in q " and number of units (bits|chars) in a " return_pop: epplp sp|0 get ptr to frame of proc from which cmpx0 0,du we are returning tze 4,ic epplp lp|stack_frame.prev_sp,* sbx0 1,du tpnz -2,ic " eppab lp|stack_frame.arg_ptr,* get ptr to our arglist ldx3 ab|0 get head, 2*n_args " eppab ab|0,3* get ptr to return arg " epplp lp|stack_frame.prev_sp,* get ptr to frame to which we are going " stq sp|count save # words in old frame eppap lp|stack_frame.next_sp,* get ptr to destination eppap ap|2 skip 2 words to allow for varying return value spriap ab|0 set return ptr for last arg sta ap|-1 set varying length epaq sp|0 get seg no of current stack sta sp|temp save it epaq lp|0 get seg no of stack we are returning to cmpa sp|temp same stack? tze same_stack yes lda sp|count get # of words to move als 18 in upper adla 17,du make 0 mod 16 (allow for 2 extra words) ana =o777760,du .. eax0 ap|-2,au get offset of new stack frame end stx0 lp|stack_frame.next_sp+1 update next sp of the frame epbplb lp|0 get pointer to base of stack we are returning to stx0 lb|stack_header.stack_end_ptr+1 update stack end pointer tra different_stack join rest of code same_stack: ldaq sp|stack_frame.next_sp get next ptr of frame we're leaving staq lp|stack_frame.next_sp set next of old to include all of this frame different_stack: ldq sp|count get back # of words to move eppsp lp|0 pop stack epbpsb sp|0 set up stack base in case we switched stacks stq sp|count save of words in new stack frame tra 0,2 return with ap -> dest, # units in q " " operator to leave a begin block. " leave_begin_block: odd epbpsb sp|0 get ptr to base of stack even "see note at label 'alm_return' sprisp sb|stack_header.stack_end_ptr reset stack end ptr eppsp sp|stack_frame.prev_sp,* pop the stack tra sp|tbp,*0 return to pl1 program " " operator to free fortran storage and then do a procedure return " fort_return_mac: spri6 sp|double_temp save sp as owner to fortran_storage_manager_ epp2 sp|double_temp spri2 sp|arg_list+2 argument 1 - stack pointer lda 2,du nargs = 1, quick call (no enviptr) ldq 0,dl no descriptors staq sp|arg_list epp0 sp|arg_list get argument list header epp2 return_mac return to return spri2 sp|stack_frame.return_ptr save return point tsx1 get_our_lp callsp fortran_storage_manager_$free " " operator to do a procedure return from inside a begin block. " entered with number of nested begin blocks in ql. " begin_return_mac: tze return_mac skip if begin block is quick epbpsb sp|0 get ptr to base of stack inhibit on sprisp sb|stack_header.stack_end_ptr keep updating end ptr eppsp sp|stack_frame.prev_sp,* pop stack inhibit off sbq 1,dl count down number of blocks tnz -3,ic repeat until all done " " operator to do a procedure return " return_mac: epbpsb sp|0 get ptr to base of stack inhibit on sprisp sb|stack_header.stack_end_ptr reset stack end pointer eppsp sp|stack_frame.prev_sp,* pop stack inhibit off epbpsb sp|0 set sb up in case we just switched stacks eppap sp|stack_frame.operator_ptr,* set up operator pointer ldi sp|stack_frame.return_ptr+1 restore indicators for caller rtcd sp|stack_frame.return_ptr continue execution after call " " operators to call an entry variable " entered with pointer to entry in bp and number " of arguments in position in a, offset of arg list is in x1 " call_ent_var_desc: eaq 0,au there are descriptors " call_ent_var: sti sp|stack_frame.return_ptr+1 save indicators ora 8,dl insert pl1 code epbpsb sp|0 get ptr to base of stack staq sb|0,1 save at head of list stx0 sp|stack_frame.return_ptr+1 set offset of return point epplp bp|2,* get display pointer eppbp bp|0,* and ptr to entry save_display: eppap sb|0,1 get ptr to arg list sprilp ap|2,au store display ptr at end epplp sp|linkage_ptr,* restore ptr to linkage segment var_call: callsp bp|0 and transfer to entry " " operator to call an external procedure (same or diff seg). " entered with pointer to entry in bp and number of args " in position in a, offset of arg list is in x1 " call_ext_in_desc: call_ext_out_desc: eaq 0,au there are descriptors " call_ext_in: call_ext_out: sti sp|stack_frame.return_ptr+1 save indicators epbpsb sp|0 get ptr to base of stack ora 4,dl insert pl1 code (do this for now) staq sb|0,1 save at head of list stx0 sp|stack_frame.return_ptr+1 set offset of return point eppap sb|0,1 get pointer to arg list epplp sp|linkage_ptr,* reload ptr to linkage segment " " This label is 'segdef'ed but is never transfered to directly. The segdef is " merely to allow default_error_handler to see if a fault occured as a result " of this particular instruction so that it can print a more informative " error message. " forward_call: callsp bp|0 transfer to entry " " operator to call an internal procedure defined in the " same block as the call. entered with pointer to entry in " bp and number of args in position in a. " call_int_this_desc: eaq 0,au there are descriptors " call_int_this: sti sp|stack_frame.return_ptr+1 save indicators ora 8,dl insert pl1 code epbpsb sp|0 get ptr to base of stack staq sb|0,1 save at head of list stx0 sp|stack_frame.return_ptr+1 save offset of return point eppap sb|0,1 get pointer to arg list sprisp ap|2,au save display pointer tra bp|0 transfer to entry " " operator to call an interal procedure defined K blocks " above the call. entered with pointer to entry in bp, " K in x7, and number of args in position in aq. " call_int_other_desc: eaq 0,au there are descriptors " call_int_other: sti sp|stack_frame.return_ptr+1 save indicators ora 8,dl insert pl1 code epbpsb sp|0 get ptr to base of stack staq sb|0,1 save at head of list stx0 sp|stack_frame.return_ptr+1 save return point epplp sp|display_ptr,* walk back K levels eax7 -1,7 .. tze save_display then go save display epplp lp|display_ptr,* take another step tra -3,ic and check again " " operator to move the label variable pointed at by sp|temp_pt " into the label variable pointed at by bp " move_label_var: ldaq sp|temp_pt,* move first two words staq bp|0 .. eax1 2 and second two words ldaq sp|temp_pt,*1 .. staq bp|2 .. tra sp|tbp,*0 return to pl1 program " " operator to make a label variable in the stack. entered " with pointer to label in bp, number of static blocks to walk " back in q. sp|temp_pt is set to point to the label variable " make_label_var: spribp sp|label_var save pointer to label tsx1 display_chase get pointer to stack frame spribp sp|label_var+2 and save in label var eppbp sp|label_var get pointer to label var spribp sp|temp_pt set temp_pt tra sp|tbp,*0 return to pl1 program " " subroutine to walk N levels back along the display chain. " entered with N in q register, exit with pointer in bp. " NB: indicators must be set from q register at time of entry. " display_chase: eppbp sp|0 get pointer to current frame tze 0,1 return if N = 0 eppbp bp|display_ptr,* take a step back the chain sbq 1,dl and decrease count tra -3,ic and check again " " operator to form mod(fx1,fx1) " entered with first arg in q, bp pointing at second " mdfx1: szn bp|0 if divisor is zero, return with dividend tze search_done go set indicators from q and exit stq sp|temp save first arg div bp|0 get remainder tnz 3,ic skip if quotient non-zero ldq sp|temp zero quotient, set q to sign of erq bp|0 quotient tpl mdfx1a skip if quotient sign + cmpa 0,dl don't correct if remainder 0 tze mdfx1a ada bp|0 negative quotient, correct remainder mdfx1a: lrs 36 shift remainder to q tra sp|tbp,*0 and return " " operator to form mod(fx1,fx2) " entered with first arg in q, bp pointing at second " mdfx2: lls 36 convert to double precision lrs 36 and join mdfx4 " " operator to form mod(fx2,fx2) " entered with first arg in q, bp pointing at second " mdfx4: sreg sp|save_regs save registers including aq ldaq bp|0 return 1st arg if second is zero tze use_first spri1 sp|temp_pt save ab epp1 sp|save_regs+4 get ptr to first arg ldq 0,dl load scaling amount tsx7 divide2 generate remainder cmpx1 0,du check sign of quotient tze mdfx4a+1 skip if quotient + ldaq sp|remainder correct remainder if it is non-zero tze 2,ic adaq bp|0 mdfx4a: staq sp|remainder lreg sp|save_regs restore registers epp1 sp|temp_pt,* restore ab ldaq sp|remainder get result eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 and exit " " operator to form mod(fx2,fx1) " entered with first arg in q, bp pointing at second " mdfx3: sreg sp|save_regs save registers, including aq lda bp|0 get divisor tze use_first use first arg as result if divisor zero spri1 sp|temp_pt epp1 sp|save_regs+4 get ptr to dividend ldq 0,dl get scale amount tsx7 divide1 get remainder cmpx1 0,du check sign of quotient tze mdfx4a+1 ldaq sp|remainder correct remainder when quotient neg tze 2,ic and remainder non-zero adl bp|0 tra mdfx4a " " operator to form mod(fx1,fx2) with non-zero scales " entered with dividend in q, pr2 -> divisor, and " scales following tsx0 " scaled_mod_fx2: lls 36 convert to double precision lrs 36 and join scaled_mod_fx4 " " operator to form mod(fx2,fx2) with non-zero scales " entered with dividend in aq, pr2 -> divisor, and " scale(dividend) & scale(divisor) following tsx0 " scaled_mod_fx4: adx0 2,du skip over the two scale words sreg sp|save_regs save all registers ldaq bp|0 get divisor tze use_first zero means use dividend as value sprp2 sp|temp_pt+1 " sc_mod_common: sprp1 sp|temp_pt eppap sp|tbp,*0 get ptr to just after scale words ldq ap|-1 get scale of divisor sbq ap|-2 - scale of dividend tmi scmd3 skip if scale(divisor) < scale(dividend) " " scale of dividend <= scale of divisor. let the divide routine " shift the dividend left by the amount in the q register. " scmd1: epp1 sp|save_regs+4 get ptr to dividend tsx7 divide2 divide cmpx1 0,du check quotient sign tze scmd2 skip if positive ldaq sp|remainder dont't correct remainder if it is zero tze scmd2 adaq bp|0 add divisor to correct remainder staq sp|remainder scmd2: lprp1 sp|temp_pt restore pointers lprp2 sp|temp_pt+1 lreg sp|save_regs and registers ldaq sp|remainder get remainder from the division tra log_exit and exit " " scale of divisor < scale of dividend, shift divisor " left by negative of number of places in q register. " if the carry indicator is on at the end of the shift, the " division would yield a zero quotient, so the remainder " is the dividend with appropriate sign consideration. " scmd3: stq sp|count get positive shift amount lcq sp|count eax1 0,ql ldaq bp|0 get back the divisor lls 0,1 shift it trc scmd4 skip if divisor too big staq sp|bit_lg1 save value temporarily epp2 sp|bit_lg1 get ptr to shifted divisor ldq 0,dl don't shift dividend tra scmd1 go do the division " " the division (with both args treated as integers since the scales " are now lined up), would give a zero quotient. if the signs of " the two arguments are the same, the value of the function is the " value of the dividend--otherwise, we have to signal fixedoverflow " scmd4: era sp|save_regs+4 check signs of two arguments ana =o400000,du tze use_first zero means signs the same tsx7 signal_overflow tra use_first " " operator to form mod(fx1,fx1) with non-zero scales " entered with dividend in aq, pr2 -> divisor, and scales " following tsx0 " scaled_mod_fx1: lls 36 convert to double precision lrs 36 and join scaled_mod_fx3 " " operator to form mod(fx2,fx1) with non-zero scales " entered with dividend in q, pr2 -> divisior, and scales " following tsx0 " scaled_mod_fx3: adx0 2,du skip over the two scale words sreg sp|save_regs save all registers lda bp|0 get divisor tze use_first zero means use dividend as value sprp2 sp|temp_pt+1 lrs 36 form double precision divisor staq sp|bit_lg1 save new divisior epp2 sp|bit_lg1 and get ptr to it tra sc_mod_common " " operator to divide single precision by single precision " entered with dividend in q and pr2 -> divisor, and amount " to scale result following tsx0 " divide_fx1: lls 36 convert to double precision lrs 36 and join divide_fx3 " " " operator to divide double precision by single precision " entered with dividend in aq, pr2 -> divisor, and amount " to scale result (+ left, - right) following tsx0 " divide_fx3: sreg sp|save_regs spri1 sp|temp_pt save ab epp1 sp|save_regs+4 get ptr to dividend lda bp|0 load divisor ldq sp|tbp,*0 load scale amount tsx7 divide1 do the division dv_done: staq sp|save_regs+4 save quotient lreg sp|save_regs restore registers adx0 1,du update return pt epp1 sp|temp_pt,* restore ab eppap sp|stack_frame.operator_ptr,* cmpaq bit_mask set indicators tra sp|tbp,*0 and exit " " operator to divide single precision by double precision " entered with dividend in q, pr2 -> divisor, and " amount to scale result following tsx0 " divide_fx2: lls 36 convert to double precision lrs 36 and join divide_fx3 " " " operator to divide double precision by double precision " entered with dividend in aq, pr2 -> divisor, and amount " to scale result following tsx0 " divide_fx4: sreg sp|save_regs spri1 sp|temp_pt save ab epp1 sp|save_regs+4 get ptr to dividend ldq sp|tbp,*0 tsx7 divide2 tra dv_done " " operator to divide double precision by double precision " same calling sequence as divide_fx4 except scale is " in index 1. Called from fixed_ops_. " div_4_cplx_ops: sreg sp|save_regs save regs epp1 sp|save_regs+4 get ptr to dividend eaq 0,1 get scale into q qrs 18 "" tsx7 divide2 perform division staq sp|save_regs+4 save quotient lreg sp|save_regs restore regs eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " internal procedure to divide double precision integer by " single precision integer. entered with divisor in a, " pr1 -> dividend, and scale in q " returns quotient in aq and remainder in sp|remainder " divide1: tsx1 divide_extension extend stack stq ap|shift save scaling amount eax1 0 save sign of divisor lrs 36 tpl 3,ic negl 0 erx1 1,du tra div_single " " internal procedure to divide two double precision integers " entered with pr1 -> dividend, pr2 -> divisor, scale amount in q " returns quotient in aq and remainder in sp|remainder " divide2: tsx1 divide_extension extend stack stq ap|shift save scaling amount eax1 0 assume positive result ldaq bp|0 get divisor tpl 3,ic negl 0 erx1 1,du cmpaq max_single_value tmoz div_single cana =o200000,du is high bit of divisor on tnz divisor_3 yes, need 3 words " " divisor only needs 2 words " sti sp|temp_indicators save indicators ldi 0,dl clear HFP mode if it's set lde =0,du count leading zeros fad =0.0,du ldi sp|temp_indicators restore indicators qrl 1 split number into two parts stq ap|divisor+1 sta ap|divisor+2 ste ap|div_temp get number of leading zeros lda ap|div_temp ars 28 neg 0 make it positive sba 1,dl eax4 2 set length of number tra prepare_dividend " " divisor requires 3 words " divisor_3: sta ap|divisor+3 store high order word lls 34+1 shift other parts 34 bits qrl 1 and save stq ap|divisor+1 ana max_single_value+1 sta ap|divisor+2 lda 34,dl shift is 34 eax4 3 and length is 3 " prepare_dividend: sta ap|norm_shift save scaling count asa ap|shift update shift by number of leading zeros stx4 ap|divisor save length of divisor ldaq ab|0 tpl 3,ic negl 0 erx1 1,du tsx3 shift_dividend adx5 1,du stz ap|dividend,5 add zero chunk at front stx5 ap|dividend save number of chunks fld 0,dl staq ap|quotient staq ap|quotient+2 staq ap|quotient+4 eax6 0,5 quotient length = sbx6 ap|divisor dividend_length - divisor_length tze done skip if zero quotient length " get_qhat: ldx5 ap|dividend calculate quotient guess lda ap|dividend,5 cmpa ap|divisor,4 tmi div_less ldq max_single_value+1 =o377777777777 lda ap|dividend-1,5 tra l3h dec_qhat: ldq ap|qhat sbq 1,dl lda ap|rhat l3h: stq ap|qhat adla ap|divisor,4 tmi got_qhat sta ap|rhat tra got_rhat div_less: ldq ap|dividend-1,5 qls 1 dvf ap|divisor,4 sta ap|qhat stq ap|rhat got_rhat: ldq ap|qhat mpy ap|divisor-1,4 lls 1 cmpa ap|rhat tmi got_qhat tnz dec_qhat qrl 1 cmpq ap|dividend-2,5 tmi got_qhat tnz dec_qhat got_qhat: eax3 0 do multiply and subtract stz ap|carry stz ap|carrya sbx5 ap|divisor epplp ap|dividend,5 div_loop: eax3 1,3 ldq ap|divisor,3 mpy ap|qhat adl ap|carry lls 1 qrl 1 stq ap|div_temp sta ap|carry ldq lp|-1,3 sblq ap|carrya sblq ap|div_temp lda 0,dl lls 1 qrl 1 stq lp|-1,3 sta ap|carrya cmpx3 ap|divisor tnz div_loop eax3 1,3 ldq lp|-1,3 sblq ap|carrya sblq ap|carry lda 0,dl lls 1 qrl 1 stq lp|-1,3 cmpa 0,dl tze store_q lcq 1,dl asq ap|qhat eax3 0 lda 0,dl div_loop1: eax3 1,3 add back in ldq lp|-1,3 adlq zero_one,al adlq ap|divisor,3 lda 0,du lls 1 qrl 1 stq lp|-1,3 cmpx3 ap|divisor tnz div_loop1 eax3 1,3 ldq lp|-1,3 adlq zero_one,al lls 1 qrl 1 stq lp|-1,3 " store_q: lda ap|qhat sta ap|quotient,6 eax3 -1 asx3 ap|dividend eax6 -1,6 tpnz get_qhat " " done " done: ldq ap|dividend+2 assemble remainder qls 1 lda ap|dividend+3 lls 35 ldq ap|dividend+1 qls 1 lrl 1 lxl6 ap|norm_shift get amount we scaled divisor lrl 0,6 shift back remainder l2: szn ab|0 set remainder sign to sign of dividend tpl 2,ic negl 0 staq sp|remainder ldq ap|quotient+4 assemble quotient adq ap|quotient+5 tnz signal_overflow ldq ap|quotient+2 qls 1 lda ap|quotient+3 lls 35 trc signal_overflow ldq ap|quotient+1 qls 1 lrl 1 xec sign_change,1 epplp ap|divide_lp,* restore lp lcx2 sp|qmask return stack extension ldx3 sp|stack_frame.next_sp+1 sblx3 divide_extension_size,du stx3 sp|stack_frame.next_sp+1 stx3 sp|stack_header.stack_end_ptr+1,2 tra 0,7 " signal_overflow: spribp sp|double_temp eppbp overflow_name eax6 overflow_length ldq =711,dl sxl0 sp|stack_frame.operator_ret_ptr tsx1 call_signal_ eppbp sp|double_temp,* lxl0 sp|stack_frame.operator_ret_ptr stz sp|stack_frame.operator_ret_ptr ldaq mask_bit+2 tra 0,7 " overflow_name: aci "fixedoverflow" " equ overflow_length,13 " div_single: stq ap|divisor ldaq ab|0 tpl 3,ic negl 0 erx1 1,du tsx3 shift_dividend fld 0,dl staq ap|quotient+2 staq ap|quotient+4 l1: ldq ap|dividend,5 qls 1 dvf ap|divisor sta ap|quotient,5 eax5 -1,5 tze thru llr 36 tra l1 thru: lda 0,dl tra l2 " " internal procedure to extend stack for divide operators " divide_extension: eax2 sp|0 get offset of stack frame stx2 sp|qmask lcx2 sp|qmask get - offset eppap sp|stack_header.stack_end_ptr,2* get ptr to extension eax3 divide_extension_size adlx3 sp|stack_frame.next_sp+1 stx3 sp|stack_header.stack_end_ptr+1,2 stx3 sp|stack_frame.next_sp+1 sprilp ap|divide_lp save lp tra 0,1 " " This procedure shifts the dividend left (+) or right (-) the " number of places specified by variable shift. It splits the shifted " value into chunks which are stored in dividend+1, dividend+2, ... " The number of chunks stored (which can never exceed 5) is returned in x5. " The routine is entered with |dividend| in AQ " shift_dividend: lxl2 ap|shift tmi right_shift staq ap|div_temp lls 0,2 trc hard_shift carry means lost a bit on left split: lls 1 qrl 1 split into chunks stq ap|dividend+1 eax5 1 lrl 35 tze 0,3 qrl 1 stq ap|dividend+2 eax5 2 cmpa 0,dl tze 0,3 sta ap|dividend+3 eax5 3 tra 0,3 hard_shift: lls 1 qrl 1 store lower 2 chunks stq ap|dividend+1 lrl 35 qrl 1 stq ap|dividend+2 ldaq ap|div_temp get back original value sbx2 70,du shift 70 places fewer tpl sl stx2 ap|div_temp lcx2 ap|div_temp lrl 0,2 tra sl+1 sl: lls 0,2 lls 1 qrl 1 stq ap|dividend+3 will always be 3rd chunk eax5 3 lrl 35 tze 0,3 qrl 1 stq ap|dividend+4 eax5 4 cmpa 0,dl tze 0,3 sta ap|dividend+5 eax5 5 tra 0,3 right_shift: stx2 ap|div_temp lcx2 ap|div_temp lrl 0,2 tra split " zero_one: dec 0,1 " sign_change: nop 0,du negl 0 " " operator to convert floating to fixed " fl2_to_fx1: fl2_to_fx2: fad =0.,du tmi 3,ic ufa =71b25,du tra sp|tbp,*0 fneg ufa =71b25,du negl tra sp|tbp,*0 " " operator to convert float to fixed scaled. the word following " the tsx0 is the encoded scale of the target " fl2_to_fxscaled: fad =0.,du tmi 4,ic ufa sp|tbp,*0 adx0 1,du tra sp|tbp,*0 fneg ufa sp|tbp,*0 negl tra -5,ic " " stac operator. entered with word in a and pointer " to destination in bp. " stac_mac: stac bp|0 store a conditionally tze true lda 0,dl .. tra sp|tbp,*0 and return " " stacq operator. entered with old value in Q, new value in A, " and pointer to destination in pr2. " stacq_mac: stacq pr2|0 store A conditional C(storage) = Q tze true stored OK, return "1"b lda 0,dl not stored, return "0"b tra sp|tbp,*0 return " " clock operator. no arguments...returns with value of " calendar clock in AQ. " clock_mac: get_our_lp rccl sys_info$clock_,* read clock into AQ cmpaq bit_mask set indicators tra sp|tbp,*0 return " " virtual clock operator. no arguments...returns with value " of virtual cpu time in AQ. " vclock_mac: get_our_lp stx0 sp|stack_frame.return_ptr+1 setup to return directly to user prog sti sp|stack_frame.return_ptr+1 save indicators callsp virtual_cpu_time_op_$virtual_cpu_time_op_ invoke supervisor to do work " " " stop operator, terminates a run unit by calling stop_run " stop: eppap sp|46 get pointer to argument list fld 0,dl create null argument list ora 4,dl and insert PL/I code staq sp|46 get_our_lp stcd sp|stack_frame.return_ptr store pointer to caller callsp stop_run$stop_run " " return_main - terminates a run unit by calling stop_run if the procedure is a main procedure, " otherwise it performs a normal return " return_main: lda sp|stack_frame.flag_word ana stack_frame.main_proc_bit,dl tze return_mac tra stop " " return from a begin block in a main procedure " begin_return_main: tze return_main skip if begin block is quick epbpsb sp|0 get ptr to base of stack inhibit on sprisp sb|stack_header.stack_end_ptr keep updating end ptr eppsp sp|stack_frame.prev_sp,* pop stack inhibit off sbq 1,dl count down number of blocks tnz -3,ic repeat until all done lda sp|stack_frame.flag_word ana stack_frame.main_proc_bit,dl is this the first main procedure invoked in the run unit? tze return_mac no - do a normal return from a begin block tra stop yes - do a stop run " " set_main_flag - sets a bit in the stack_frame if this is the first procedure in the run unit and has options(main) " set_main_flag: epbp7 sp|0 pointer to stack_header lxl1 sb|stack_header.main_proc_invoked cmpx1 1,du first main procedure in run unit? tnz zero_main_flag no orx1 =o400000,du then this is the first main procedure sxl1 sb|stack_header.main_proc_invoked indicate main procedure has been invoked lda stack_frame.main_proc_bit,dl flag stack frame of first main procedure orsa sp|stack_frame.flag_word tra sp|tbp,*0 return zero_main_flag: lca stack_frame.main_proc_bit+1,dl generate mask to turn off main_proc bit ansa sp|stack_frame.flag_word indicate that this is not the first main procedure tra sp|tbp,*0 return " " sign operator. entered with indicators set via load sign_mac: tze sp|tbp,*0 return zero if zero tmi 3,ic skip if negative ldq 1,dl return +1 tra sp|tbp,*0 .. lcq 1,dl return -1 tra sp|tbp,*0 .. " " operator to transfer sign of number pointed to by bp to integer in q " trans_sign_fx1: lls 36 form abs value of Q in A tpl 2,ic neg 0 szn bp|0 if second number is negative tpl 2,ic neg 0 set A negative too lrs 36 shift back to Q tra sp|tbp,*0 and return " " operator to transfer sign of floating number pointed to by bp " to floating number in EAQ " trans_sign_fl: tpl 2,ic set first number positive fneg 0 fszn bp|0 if second number is positive tpl 3,ic value is OK fneg 0 otherwise, set first negative tra sp|tbp,*0 and return fcmp =0.0,du restore indicators tra sp|tbp,*0 and return " " opearator to perform Fortran type mod function " fort_mdfl1: fszn bp|0 return if B zero tze sp|tbp,*0 fstr sp|temp save A fdv bp|0 form A/B tmi 3,ic fad =71b25,du truncate towards 0 tra 4,ic fneg fad =71b25,du truncate towards 0 fneg fmp bp|0 fneg 0 fad sp|temp form A - [A/B]*B tra sp|tbp,*0 and return " " Fortran double precision mod " dmod (A,B) = A - INT(A/B) * B " A in eaq, bp|0 -> B, result in eaq " fort_dmod: fszn bp|0 this only works on normalized numbers! tze sp|tbp,*0 return A if B is zero dfstr sp|temp save A dfdv bp|0 form A/B tmi 3,ic dfad k71b25 truncate toward zero tra 4,ic fneg dfad k71b25 truncate toward zero fneg dfmp bp|0 form [A/B]*B fneg dfad sp|temp form A-[A/B]*B tra sp|tbp,*0 and return it " " operators to convert from fixed point to single float complex " rfb1_to_cflb1: lls 36 convert to double fixed first lrs 36 " rfb2_to_cflb1: lde =71b25,du convert to float fad =0.,du fst sp|temp and save lda sp|temp get real part ldq =0.,du and imag part of zero tra sp|tbp,*0 and return " " operator to perform complex multiplication, defined as " (a+ib)*(c+id) -> a*c - b*d +i(b*c + a*d) " entered with bp pointing at multiplier and multiplicand in AQ " or in complex AQ " mpcfl1_1: ldaq sp|complex get a+ib " mpcfl1_2: staq sp|temp and save fld sp|temp+1 form b*d fmp bp|1 fst sp|complex fld sp|temp form a*c fmp bp|0 fsb sp|complex form a*c - b * d fst sp|complex fld sp|temp form a*d fmp bp|1 fst sp|complex+1 fld sp|temp+1 form b*c fmp bp|0 fad sp|complex+1 form b*c + a*d fst sp|complex+1 tra sp|tbp,*0 and return " " operator to perform complex division entered with " bp pointing at divisor, dividend in AQ or complex AQ. " This code, written by R. A. Barnes, is based on " Algorithm 116 in Collected Algorithms from CACM " written by Robert L. Smith from Stanford University. " Following is the algorithm written in pseudo PL/I " to do (a+ib)/(c+id) = (e+if) " " if abs(c) >= abs(d) " then do; " r = d/c; " den = c + r*d; " e = (a + b*r)/den; " f = (b - a*r)/den; " end; " else do; " r = c/d; " den = d + r*c; " e = (a*r + b)/den; " f = (b*r - a)/den; " end; " dvcfl1_1: ldaq sp|complex get a+ib " dvcfl1_2: staq sp|temp and save fld bp|0 get c fcmg bp|1 compare with d tmi dvcfl1_else " fdi bp|1 get d/c fst sp|num save as r fmp bp|1 form r*d fad bp|0 c + r*d fst sp|temp2 save as den fld sp|temp+1 get b fmp sp|num form b*r fad sp|temp a + b*r fdv sp|temp2 (a + b*r)/den fst sp|complex store e fld sp|temp get a fmp sp|num form a*r fneg 0 - a*r fad sp|temp+1 b - a*r fdv sp|temp2 (b - a*r)/den fst sp|complex+1 store f tra sp|tbp,*0 return " dvcfl1_else: fdv bp|1 get c/d fst sp|num save as r fmp bp|0 form r*c fad bp|1 d + r*c fst sp|temp2 save as den fld sp|temp get a fmp sp|num form a*r fad sp|temp+1 a*r + b fdv sp|temp2 (a*r + b)/den fst sp|complex store e fld sp|temp+1 get b fmp sp|num form b*r fsb sp|temp (b*r - a) fdv sp|temp2 (b*r - a)/den fst sp|complex+1 store f tra sp|tbp,*0 return " " operator to perform block copy. entered " with block size in ql, ptr to destination in sp|temp_pt and ptr " to source in bp. " copy_words: qls 2 compute number of chars to move tze sp|tbp,*0 skip if zero (prevent IPR) eppap sp|temp_pt,* get ptr to destination mlr (ar+rl),(ar+rl) desc9a bp|0,ql desc9a ap|0,ql eppap sp|stack_frame.operator_ptr,* tra sp|tbp,*0 " " operator to perform block copy from even boundary to even boundary. " same conventions as copy_words. " copy_double: qls 1 get number of chars tra copy_words+1 join copy_words case " " operator to multiply single precision fixed number in q " by double precision fixed number pointed at by bp " mpfx2: eax1 0 set for positive sign llr 36 shift multiplier to a tpl 3,ic skip if positive neg 0 neg, force positive eax1 1 flip sign of result sta sp|temp save multiplier ldaq bp|0 get multiplicand tpl 3,ic skip if positive negl 0 neg, force positive erx1 1,du flip sign of answer cana =o200000,du remember high order bit tze 2,ic orx1 2,du llr 1 get high order bit of q into q qrl 1 get zero in s bit of q ana mask_bit+2 and zero in s bit of a sta sp|t5 save upper half mpy sp|temp form lower product staq sp|lv save for later ldq sp|t5 get upper half mpy sp|temp form upper product cmpa 0,dl a should be clear tnz mult_overflow lls 35 and shift to position adaq sp|lv add lower product staq sp|lv and save ldaq bit_mask multiply lower by high order bit canx1 2,du tze 2,ic ldq sp|temp lls 70 shift to position (should give only 1 bit) trc mult_overflow adaq sp|lv add back rest of number canx1 1,du check result of answer tnz 3,ic jump if - cmpaq bit_mask set indicators tra sp|tbp,*0 return negl 0 negate tra sp|tbp,*0 and return to pl/1 program " " operator to multiply double precison fixed integer in aq " by double precsion fixed number pointed at by bp. " mpfx3: eax1 0 set positive sign cmpa 0,du skip if number positive tpl 3,ic negl 0 neg, force positive eax1 1 flip sign of answer cana =o200000,du remember high order bit tze 2,ic orx1 2,du llr 1 split into 2 35 bit pos numbers qrl 1 ana mask_bit+2 sta sp|t1 save for later stq sp|t2 ldaq bp|0 get multplier tpl 3,ic force positive negl 0 erx1 1,du and set answer sign cana =o200000,du remember high order bit tze 2,ic orx1 4,du llr 1 split qrl 1 ana mask_bit+2 sta sp|t3 save for later stq sp|t4 mpy sp|t2 form lower product staq sp|lv and save ldq sp|t3 form first upper product mpy sp|t2 cmpa 0,dl a should be clear tnz mult_overflow lls 35 and add to lower adaq sp|lv staq sp|lv save partial answer ldq sp|t1 form second upper product mpy sp|t4 cmpa 0,dl tnz mult_overflow lls 35 shift to position adaq sp|lv add previous part staq sp|lv and save again ldq sp|t3 form upper upper product mpy sp|t1 which may only give one bit canx1 2,du tze 2,ic adq sp|t4 canx1 4,du tze 2,ic adq sp|t2 cmpa 0,dl a should be clear tnz mult_overflow lls 70 shift to position trc mult_overflow adaq sp|lv and add it in canx1 1,du should answer be neg tnz 3,ic yes, jump cmpaq bit_mask set indicators tra sp|tbp,*0 return negl 0 set minus sign tra sp|tbp,*0 and return " mult_overflow: sreg sp|save_regs tsx7 signal_overflow use_first: lreg sp|save_regs cmpaq bit_mask set indicators properly tra sp|tbp,*0 " " operator to perform string range check. entered with " length of string (k) in q " bp|0 pointing at i (2nd arg of substr) " bp|1 pointing at j (3rd arg of substr) " exit with new value of j in q " sr_check: sxl0 sp|stack_frame.operator_ret_ptr stq sp|bit_lg1 save k ldq bp|0 form i' = i - 1 sbq 1,dl stq bp|0 and save tmi sr_2 signal if i' < 0 cmpq sp|bit_lg1 signal if i' >= k tpl sr_2 ldq bp|1 get j tmi sr_3 signal if j < 0 cmpq sp|bit_lg1 signal if j > k tmi 2,ic tnz sr_3 adq bp|0 form i' + j cmpq sp|bit_lg1 return if i' + j <= k tze 2,ic tpl sr_3 ldq bp|1 exit with value of j z_done: lxl0 sp|stack_frame.operator_ret_ptr restore return offset stz sp|stack_frame.operator_ret_ptr and clear record tra sp|tbp,*0 " sr_3: tsx0 string_signal ldq sp|bit_lg1 get min(k-i+1,j) sbq bp|0 cmpq bp|1 tmi 2,ic ldq bp|1 cmpq 0,dl use zero if q < 0 tpl 2,ic ldq 0,dl tra z_done return " sr_2: tsx0 string_signal ldq 0,dl use j = 0 tra z_done return " signal_stringrange: sxl0 sp|stack_frame.operator_ret_ptr eax0 z_done set return ptr and fall into string_signal " string_signal: stx0 sp|temp save x0 spribp sp|lv and bp lxl6 11,dl get length of condition eppbp strg get ptr to condition name ldq =701,dl load oncode value tsx1 call_signal_ signal "stringrange" ldx0 sp|temp restore x0 eppbp sp|lv,* and bp tra 0,0 and return strg: aci "stringrange" " " non-local transfer operator. entered with bp pointing " at destination and number of stack levels to pop in x7. " tra_ext_1: eaq 0,7 move number of levels to ql qrl 18 spribp sp|lv save ptr to destination tsx1 display_chase get ptr to stack frame spribp sp|lv+2 finish the label variable eppbp sp|lv fall into unwinder_ call " " non-local transfer operator. entered with bp pointing " at a label variable. " tra_ext_2: spribp sp|arg_list+2 save ptr to label var fld 2*1024,dl there are 2 args staq sp|arg_list .. eppap sp|arg_list get ptr to arg_list tsx1 get_our_lp get ptr to our linkage tra |[unwinder_] go unwind stack " " operator to assign auto adjustable variables at end of stack " frame. entered with number of words in q, exit with pointer " to storage in bp. " alloc_auto_adj: eaq 15,ql make size a multiple of 16 anq =o777760,du .. get_stack_offset eppbp sp|4,* get ptr to storage adlq sp|5 get new end of stackframe stq sp|stack_frame.next_sp+1 update next sp ptr stq sp|stack_header.stack_end_ptr+1,au update stack end ptr also stq sp|5 and set to remember this storage tra sp|tbp,*0 return to caller " " floating point mod operators entered with x in eaq and " bp pointing at y. mod(x,y) = if y = 0 then x else x - floor(x/y)*y " mdfl1: fszn bp|0 return x if y = 0 tze mdfl1a fst sp|temp save x fdv bp|0 divide x/y tmi 3,ic get floor fad =71b25,du tra 5,ic fneg fad almost_one fad =71b25,du fneg fmp bp|0 form floor(x/y)*y fneg fad sp|temp form answer tra sp|tbp,*0 and return mdfl1a: fcmp =0.0,du set indicators properly tra sp|tbp,*0 " mdfl2: dfst sp|temp save x dfld bp|0 get y tze mdfl2a return x if y = 0 dfdi sp|temp divide x/y tmi 3,ic form floor dfad k71b25 tra 5,ic fneg dfad almost_one dfad k71b25 fneg dfmp bp|0 form floor(x/y)*y fneg mdfl2a: dfad sp|temp form answer tra sp|tbp,*0 and return " " real truncation operator " trunc_fl: tmi 3,ic fad =71b25,du tra sp|tbp,*0 fneg fad =71b25,du fneg tra sp|tbp,*0 " " single precision fixed truncate, entered with scale in x2 " trunc_fx1: cmpq 0,dl tmi 3,ic qrs 0,2 tra sp|tbp,*0 stq sp|temp lcq sp|temp qrs 0,2 stq sp|temp lcq sp|temp tra sp|tbp,*0 " " double precision fixed truncate, entered with scale in x2 " trunc_fx2: cmpaq bit_mask tmi 3,ic lrs 0,2 tra sp|tbp,*0 negl lrs 0,2 negl tra sp|tbp,*0 " " operators to do floating point floor and ceiling functions " these use the relations " floor(-x) = -ceil(|x|) " ceil(-x) = -floor(|x|) " floor_fl: tmi 3,ic fad =71b25,du tra sp|tbp,*0 fneg dfad almost_one fad =71b25,du fneg tra sp|tbp,*0 " ceil_fl: tmi 4,ic dfad almost_one fad =71b25,du tra sp|tbp,*0 fneg fad =71b25,du fneg tra sp|tbp,*0 " " operators to do single precision fixed floor and ceiling functions " entered with argument in q register and scale in index 2 floor_fx1: cmpq 0,dl tmi 3,ic qrs 0,2 tra sp|tbp,*0 stq sp|temp lcq sp|temp cmpx2 36,du tmoz 3,ic adq floor_ceil_mask+36 tra 2,ic adq floor_ceil_mask,2 qrs 0,2 stq sp|temp lcq sp|temp tra sp|tbp,*0 " ceil_fx1: cmpq 0,dl tmi 8,ic cmpx2 36,du tmoz 3,ic adq floor_ceil_mask+36 tra 2,ic adq floor_ceil_mask,2 qrs 0,2 tra sp|tbp,*0 stq sp|temp lcq sp|temp qrs 0,2 stq sp|temp lcq sp|temp tra sp|tbp,*0 " " operators do double precision fixed floor and ceiling functions " entered with argument in aq register, scale in index 2, and -2*scale " in index 3 " floor_fx2: cmpaq bit_mask tmi 3,ic lrs 0,2 tra sp|tbp,*0 negl cmpx3 -144,du tpl 3,ic adaq mask_bit tra 2,ic adaq mask_bit+144,3 lrs 0,2 negl tra sp|tbp,*0 " ceil_fx2: cmpaq bit_mask tmi 8,ic cmpx3 -144,du tpl 3,ic adaq mask_bit tra 2,ic adaq mask_bit+144,3 lrs 0,2 tra sp|tbp,*0 negl lrs 0,2 negl tra sp|tbp,*0 " " operator to round single fixed binary " entered with (scale - k) in index 7 " round_fx1: cmpq 0,dl set indicators tmi round_fx1b skip if negative eax1 0 remember was positive round_fx1a: stq sp|temp save abs(arg) ldq 1,dl form 1/2 at proper scale qls -1,7 adq sp|temp add abs(arg) qrs 0,7 drop bits to right cmpx1 0,du was arg positive tze sp|tbp,*0 yes, can return stq sp|temp arg was negative, negate result lcq sp|temp tra sp|tbp,*0 before returning round_fx1b: stq sp|temp get abs(arg) lcq sp|temp eax1 1 remember arg was negative tra round_fx1a and join positive case " " operator to round double fixed binary " entered with (scale - k) in index 7 " round_fx2: cmpaq bit_mask set indicators tmi round_fx2b skip if negative eax1 0 remember arg was positive round_fx2a: staq sp|temp save abs(arg) ldaq one form 1/2 at proper scale lls -1,7 adaq sp|temp add abs(arg) lrs 0,7 drop bits to right xec sign_change,1 put back proper sign tra sp|tbp,*0 and return round_fx2b: negl 0 take abs(arg) eax1 1 remember arg was negative tra round_fx2a join positive case " " operator to compute round(x,k) for floating point values. " entered with x in eaq and k immediately following tsx0 " round_fl: eax1 0 assume sign + eppbp sp|tbp,*0 get ptr to K in lhs fcmp =0.0,du tze bp|1 return if 0 tpl 3,ic fneg 0 get abs value eax1 1 ldx0 bp|0 load k dfst sp|temp save value lda =o200000,du get bit in proper position ldq 0,dl lrs 0,0 shift dfad sp|temp perform rounding adx0 bp|0 get 2*k anaq bit_mask+2,0 erase low order bits xec fl_sign_change,1 put back correct sign tra bp|1 and return " fl_sign_change: nop 0 fneg 0 " " Operator to round a floating point number to the nearest whole " number. Entered with value in EAQ and indicators set. Result in " EAQ. " nearest_whole_number: tmi nearest_whole_negative fad =0.5,du fad =71b25,du tra sp|tbp,*0 nearest_whole_negative: fneg fad =0.5,du fad =71b25,du fneg tra sp|tbp,*0 " " Operator to round a floating point number to the nearest integer. " Entered with value in EAQ and indicators set. Result in Q. " nearest_integer: tmi nearest_integer_negative fad =0.5,du ufa =71b25,du tra sp|tbp,*0 nearest_integer_negative: fneg fad =0.5,du ufa =71b25,du negl tra sp|tbp,*0 " Operator to convert a long bit string to double precision fixed binary. " Entered with bit string previously setup. longbs_to_fx2: epp2 sp|temp_pt,* " pr2 = ptr to string ldq sp|bit_lg1 " q = length of string in bits stz sp|temp " clear high order bit of result csr (pr,rl),(pr),bool(move),fill(0) descb pr2|0,ql descb sp|temp(1),71 trtf longbs_to_fx2_short " Was string longer than 71 bits? sbq 71,dl " Yes: Remove last 71 bits from string length cmpb (pr,rl),(),fill(0) " Make sure the leading bits are zero. descb pr2|0,ql descb 0,0 tnz signal_size_condition longbs_to_fx2_short: ldaq sp|temp " aq = result tra sp|tbp,*x0 " return " Operator to convert a long bit string to bit 18 (used for ptr built-ins). " Entered with bit string previously setup. longbs_to_bs18: epp2 sp|temp_pt,* " pr2 = ptr to string lda sp|bit_lg1 " a = length of string in bits csl (pr,rl),(pr),bool(move),fill(0) descb pr2|0,al descb sp|temp,18 lda sp|temp " au = first 18 bits of string anaq bit_mask+2*18 " al, q = 0 tra sp|tbp,*x0 " return " operator to convert a packed (single word) ptr to unpacked (its) " enter with packed pointer in q, exit with its pair in aq " pk_to_unpk: stq sp|lv save packed ptr spribp sp|temp2 lprpbp sp|lv load packed ptr (get ring no right) spribp sp|save_regs store as unpacked ptr ldaq sp|save_regs load ITS pair into aq eppbp sp|temp2,* restore original bp tra sp|tbp,*0 " " operator to convert an unpacked (its) ptr to packed (single word) " enter with its pair in aq, exit with packed pointer in q " unpk_to_pk: arl 18 lls 18 qls 3 lrl 30 qlr 30 tra sp|tbp,*0 " " operator to load the packed pointer in q register into bp register " packed_to_bp: stq sp|temp lprpbp sp|temp tra sp|tbp,*0 and return " " The following operators are used to move a block of <= 256 elements " They are entered with lp and bp pointing to source and destination " and au holding value for x0 during rpd loop. " " Single word items, lp -> source, bp -> destination " odd "to force rpd odd rpd_odd_lp_bp: sxl0 sp|stack_frame.operator_ret_ptr eax0 rpd_bits,au init rpd loop eax1 0 eax2 0 rpdx 0,1 lda lp|0,1 sta bp|0,2 tra z_done return " " Single word items, bp -> source, lp -> destination " odd "to force rpd odd rpd_odd_bp_lp: sxl0 sp|stack_frame.operator_ret_ptr eax0 rpd_bits,au eax1 0 eax2 0 rpdx 0,1 lda bp|0,1 sta lp|0,2 tra z_done return " " Double word items, lp -> source, bp -> destination " odd "to force rpd odd rpd_even_lp_bp: sxl0 sp|stack_frame.operator_ret_ptr eax0 rpd_bits,au init rpd loop eax1 0 eax2 0 rpdx 0,2 ldaq lp|0,1 staq bp|0,2 tra z_done return " " Double word items, bp -> source, lp -> destination " odd "to force rpd odd rpd_even_bp_lp: sxl0 sp|stack_frame.operator_ret_ptr eax0 rpd_bits,au init rpd loop eax1 0 eax2 0 rpdx 0,2 ldaq bp|0,1 staq lp|0,2 tra z_done return " " " The following macro is the trace macro. It contains the calling " sequence to trace. " macro trace ife &1,trace_ epaq * get segment number of pl1_operators_ lprplp sb|stack_header.lot_ptr,*au get our linkage ptr sprpbp sb|stack_header.stack_end_ptr,* save entry ptr as packed ptr eppbp sb|stack_header.stack_end_ptr,* sprpab bp|1 save lisp linkage ptr (might be lisp environment) tspbp trace_catch_$catch_pl1_ eppab sb|stack_header.stack_end_ptr,* lprpbp ab|0 restore entry ptr lprpab ab|1 restore lisp linkage ptr ifend &end " " Macro to generate the ALM entry operator with or without the calling sequence for " trace_catch_$catch_pl1_. When the ALM entry operator with the calling sequence for " trace is invoked it will allow trace to meter the ALM program and print its arguments " on entrance and exit. (P. Krupp 09/20/77) macro alm_entry_op " BEGIN MACRO alm_entry_op &1alm_entry: eppbp bp|-1 generate pointer to entry structure trace &1 epplp sb|stack_header.stack_end_ptr,* get a pointer to the next stack frame spribp lp|stack_frame.entry_ptr epaq bp|0 get seg no of object in a lprplb sb|stack_header.isot_ptr,*au get packed ptr to static from isot sprplb lp|stack_frame.static_ptr save in next stack frame lprplp sb|stack_header.lot_ptr,*au get packed ptr to linkage from lot tra bp|1 return to alm prog " END MACRO alm_entry_op &end " The following operators are used by ALM " The order of the following operators must be maintained because of " coding of default_error_handler_ " alm_operators_begin: alm_call: sprilp sp|stack_frame.return_ptr save return pointer sti sp|stack_frame.return_ptr+1 save indicators epplp sp|stack_frame.lp_ptr,* set up our lp callsp bp|0 do the call " alm_push: spribp sb|stack_header.stack_end_ptr,* save return from operator eppbp sb|stack_header.stack_end_ptr,* get pointer to new stack frame sprisp bp|stack_frame.prev_sp save previous ptr in new frame spriap bp|stack_frame.arg_ptr save argument ptr sprilp bp|stack_frame.lp_ptr save linkage ptr eppsp bp|0 move up to new frame eppbp sp|0,7 get pointer to end of this new frame spribp sb|stack_header.stack_end_ptr and update stack end pointer spribp sp|stack_frame.next_sp and set next sp of new frame eax7 1 set ALM translator ID for debugging stx7 sp|stack_frame.translator_id tra sp|0,* return to alm program " alm_entry_op " alm_return: inhibit on sprisp sb|stack_header.stack_end_ptr update stack end ptr eppsp sp|stack_frame.prev_sp,* pop stack inhibit off epbpsb sp|0 set up stack base in case we just switched stacks eppap sp|stack_frame.operator_ptr,* set op ptr of frame being returned to ldi sp|stack_frame.return_ptr+1 restore indicators for caller rtcd sp|stack_frame.return_ptr return to calling program " alm_return_no_pop: epbpsb sp|0 set up stack base in case returning to outer ring eppap sp|stack_frame.operator_ptr,* set up operator ptr of frame being returned to ldi sp|stack_frame.return_ptr+1 restore indicators for caller rtcd sp|stack_frame.return_ptr return to calling program " alm_operators_end: " " " operator to check size condition for single fixed binary " entered with number in q and -precision in x7 " Registers modified: none " " Algorithm: If a number is in range then all of the high order bits " that are in the word but aren't in the precision range should not " contain any useful information. IE they should all be zeros for " positive numbers and all ones for negative numbers. " " If we left shift out all of the higher order bits, then the carry " flag is set if any of these bits change. " size_check_fx1: staq sp|temp save AQ sti sp|temp_indicators save indicators qls 35,x7 sample upper bits (35-precision) " C set if removed bits not all 0 or 1 tnc size_ok_fx restore & return signal_size_condition: spribp sp|double_temp eppbp size_name get ptr to name of condition stx6 sp|temp2 save x6 eax6 size_length and load size ldq =703,dl load oncode value ssc: sxl0 sp|stack_frame.operator_ret_ptr save return offset tsx1 call_signal_ ldx6 sp|temp2 restore x6 eppbp sp|double_temp,* restore bp lxl0 sp|stack_frame.operator_ret_ptr stz sp|stack_frame.operator_ret_ptr size_ok_fx: ldaq sp|temp restore AQ ldi sp|temp_indicators restore indicators tra sp|tbp,*0 and return " " operator to check size condition for double fixed binary " entered with number in aq and -2*precision in x7 " Registers modified: none " size_check_fx2: staq sp|temp save AQ sti sp|temp_indicators save indicators stx7 sp|temp_indicators save -2*precision, want -precision eaa 0,x7 cannot divide an Xreg, so use A ars 1 divide -2*precision by 2 eax7 0,au x7 now contains -precision lda sp|temp restore A (original) lls 71,x7 sample upper bits (71-prec) " C set if removed bits not all 0 or 1 ldx7 sp|temp_indicators restore x7 trc signal_size_condition if C set : |num| too big ldaq sp|temp restore AQ ldi sp|temp_indicators restore indicators tra sp|tbp,*0 and return " " operator to check size condition for unsigned single fixed binary " entered with number in q and -precision in x7 " Registers modified: none " size_check_uns_fx1: staq sp|temp save AQ sti sp|temp_indicators save indicators cmpq mask_bit_one+36,x7 check against table of max values tnc size_ok_fx magnitude less than max value tnz signal_size_condition greater than max value tra size_ok_fx equal to max value " " operator to check size condition for unsigned double fixed binary " entered with number in aq and -2*precision in x7 " Registers modified: none " size_check_uns_fx2: staq sp|temp save AQ sti sp|temp_indicators save indicators cmpaq mask_bit+144,x7 check against table of max values tnc size_ok_fx magnitude less than max value tnz signal_size_condition greater than max value tra size_ok_fx equal to max value " " operator to check if result of an 'mpy' exceeds one word. " entered with result of 'mpy' in AQ. " mpy_overflow_check: staq sp|temp save AQ sti sp|temp_indicators save indicators lls 36 sets carry flag if result too big tnc size_ok_fx restore & return spribp sp|double_temp signal "fixedoverflow" eppbp overflow_name stx6 sp|temp2 eax6 overflow_length ldq =711,dl tra ssc " " operator to signal "size" condition " signal_size: staq sp|temp tra signal_size_condition " size_name: aci "size" equ size_length,4 " " operator to signal "stringsize" condition " signal_stringsize: staq sp|temp spribp sp|double_temp stx6 sp|temp2 eppbp stringsize_name eax6 stringsize_length ldq =702,dl tra ssc " stringsize_name: aci "stringsize" equ stringsize_length,10 " " operator to request fortran external storage allocation and/or " initialization. " fort_storage: spri6 sp|double_temp stack frame pointer epp2 sp|double_temp spri2 sp|arg_list+2 argument 1 - stack pointer epp2 sp|linkage_ptr linkage pointer spri2 sp|arg_list+4 argument 2 - linkage pointer epp2 sp|tbp,*0 text pointer to arg_list spri2 sp|temp_pt epp2 sp|temp_pt spri2 sp|arg_list+6 argument 3 - argument pointer lda 6,du nargs = 3, quick call (no enviptr) ldq 0,dl no descriptors staq sp|arg_list epp0 sp|arg_list get argument list header adx0 1,du stx0 sp|stack_frame.return_ptr+1 save return point sti sp|stack_frame.return_ptr+1 save indicators tsx1 get_our_lp callsp fortran_storage_$create " " operator to enable a condition. calling sequence is: " eppbp name " lxl6 name_size " tsx0 ap|enable " tra on_unit_body " arg on_unit (snap & system flags in RHS if used) " tra skip_around_body " body of on unit starts here " include on_unit enable_op: sxl0 sp|stack_frame.operator_ret_ptr epplp sp|tbp,*0 lda =o100,dl is there a valid on_unit_list cana sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp tnz 3,ic non-zero means ok stz sp|stack_frame.on_unit_rel_ptrs init ptr orsa sp|stack_frame.prev_sp and set bit " ldx1 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit tze add_on zero means chain empty on_1: cmpx1 lp|1 is this the unit we want tze have_on yes, go process ldx1 sp|on_unit.next,1 no, get ptr to next on chain tnz on_1 and repeat if end not reached add_on: ldx1 lp|1 get rel ptr to new unit ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit stx0 sp|on_unit.next,1 set next ptr of new unit stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first on chain have_on: spribp sp|on_unit.name,1 set name of new unit sprilp sp|on_unit.body,1 set ptr to body stz sp|on_unit.size,1 clear size field sxl6 sp|on_unit.size,1 set size of unit name lxl0 lp|1 get snap & system flags sxl0 sp|on_unit.flags,1 and save in on unit stz sp|stack_frame.operator_ret_ptr tra lp|2 return to pl1 program " " " operator to create and enable a cleanup handler for a fortran " program. calling sequence is: " tsx0 ap|fort_cleanup " arg on_unit_body (snap & system flags in RHS if used) " Uses pr2 (bp) and pr4 (lp) - restores pr4 (lp) from stack " fort_cleanup: sxl0 sp|stack_frame.operator_ret_ptr eppbp sp|tbp,*0 lda =o100,dl is there a valid on_unit_list cana sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp tnz 3,ic non-zero means ok stz sp|stack_frame.on_unit_rel_ptrs init ptr orsa sp|stack_frame.prev_sp and set bit " ldx1 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit tze add_fort_cleanup zero means chain empty fort_cleanup_1: cmpx1 bp|0 is this the unit we want tze have_fort_cleanup yes, go process ldx1 sp|on_unit.next,1 no, get ptr to next on chain tnz fort_cleanup_1 and repeat if end not reached add_fort_cleanup: ldx1 bp|0 get rel ptr to new unit ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit stx0 sp|on_unit.next,1 set next ptr of new unit stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first on chain have_fort_cleanup: " Point to our cleanup handler and our name and length epplp fort_cleanup_name sprilp sp|on_unit.name,1 set name of new unit get_our_lp " need our linkage section epplp |[fort_cleanup_] sprilp sp|on_unit.body,1 set ptr to body epplp sp|linkage_ptr,* restore ptr to linkage segment lxl0 fort_cleanup_length,dl stz sp|on_unit.size,1 clear size field sxl0 sp|on_unit.size,1 set size of unit name lxl0 bp|0 get snap & system flags sxl0 sp|on_unit.flags,1 and save in on unit stz sp|stack_frame.operator_ret_ptr tra bp|1 return to fortran program fort_cleanup_name: aci "cleanup" equ fort_cleanup_length,7 " " operator to signal a condition. entered with ptr to name in bp " and size of name in x6. " signal_op: sxl0 sp|stack_frame.operator_ret_ptr ldq =1000,dl load oncode value tsx1 call_signal_ call signal_ tra z_done and return " " operator to signal "subscriptrange" condition " bound_ck_signal: sxl0 sp|stack_frame.operator_ret_ptr stx6 sp|temp save x6 lxl6 14,dl get size of condition eppbp subrg get ptr to name ldq =704,dl load oncode value tsx1 call_signal_ call signal_ ldx6 sp|temp restore x6 tra z_done and return subrg: aci "subscriptrange" " " operator to enable a condition with file specified, usage is " eppbp file " eaa name (in text) " ora flags,dl snap & system flags (optional) " lxl6 name_size " tsx0 ap|enable_file " enable_file: sxl0 sp|stack_frame.operator_ret_ptr save return point spribp sp|temp save pointer to file eppbp sp|tbp,*au get pointer to name sta sp|double_temp save snap & system flags lda =o100,dl check for existence of condition list cana sp|stack_frame.condition_word tnz ef_1 if we have list, go check it stz sp|stack_frame.on_unit_rel_ptrs no list, initialize it orsa sp|stack_frame.condition_word .. " make_unit: get_stack_offset epplp sp|stack_header.stack_end_ptr,au* get ptr to next stack frame eax0 16 extend stack by 16 words adlx0 sp|stack_frame.next_sp+1 .. stx0 sp|stack_frame.next_sp+1 .. stx0 sp|stack_header.stack_end_ptr+1,au .. stx0 sp|5 make extension "permanent" eax1 lp|0,au into x1 " ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit stx0 sp|on_unit.next,1 and save as next of new unit stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first unit " spribp sp|on_unit.name,1 save ptr to name epplp sp|temp,* get back ptr to file ldaq lp|0 copy file into stack staq sp|on_unit.file_copy,1 ldaq lp|2 staq sp|on_unit.file_copy+2,1 epplp sp|on_unit.file_copy,1 get ptr to copy of file sprilp sp|on_unit.file,1 and save as ptr to file stz sp|on_unit.size,1 clear size field " init_unit: sxl6 sp|on_unit.size,1 set size of name lxl0 sp|double_temp get snap & system flags sxl0 sp|on_unit.flags,1 store them lxl0 sp|stack_frame.operator_ret_ptr restore return stz sp|stack_frame.operator_ret_ptr epplp sp|tbp,*0 get ptr to entry point of unit sprilp sp|on_unit.body,1 and save it tra lp|1 and then return " ef_1: tsx0 find_unit go search for unit tra init_unit found it eppbp sp|temp2,* restore ptr to name tra make_unit not found, must go make it " " operator to revert a condition with file specified, usage is " eppbp file " eaa name (in text) " lxl6 name_size " tsx0 ap|revert_file " revert_file: ldq =o100,dl do we have any conditions enabled canq sp|stack_frame.condition_word tze sp|tbp,*0 no, return immediately sxl0 sp|stack_frame.operator_ret_ptr yes, save return spribp sp|temp save pointer to file eppbp sp|tbp,*au get ptr to name tsx0 find_unit go search for unit stz sp|on_unit.size,1 found it, zero size tra z_done ok to return now " " subroutine to search for enabled condition, entered with " bp pointing at name in text " x6 holding size of name " sp|temp holding ptr to file " returns 0,0 if condition found " 1,0 if condition not found " " N.B. we assume that we only have to compare ptrs to check if name " is the same because of constant pooling done by compiler " find_unit: spribp sp|temp2 save ptr to name eppbp sp|temp,* get ptr to file ldx1 sp|stack_frame.on_unit_rel_ptrs get offset of first unit tra 2,ic and enter loop " fu_1: ldx1 sp|on_unit.next,1 get off of next unit tze 1,0 none means we failed ldaq sp|on_unit.name,1 get name in on unit cmpaq sp|temp2 compare with name we want tnz fu_1 if not same keep looking ldaq sp|on_unit.file_copy+2,1 get second ptr in file cmpaq bp|2 compare with file we want tnz fu_1 keep looking if different tra 0,0 found it " " operators for put data " entered with pointer to datum in bp, offset in x7, symtab offset in a " put_data_eis: eax6 2 set procedure to call tra plio_eis join common section " put_data: eax1 0,7 get offset tra pd_1 " put_data_co: ldx1 co_to_bo,7 convert offset to bits tra pd_1 " put_data_ho: ldx1 ho_to_bo,7 convert offset to bits tra pd_1 " put_data_aligned: eax1 0 zero offset " pd_1: eax6 2 set procedure to call tra plio join common section " " operators for get list " entered with pointer to datum in bp, offset in x7, descriptor in q " get_list_eis: eax6 3 set procedure to call tra plio_eis join common section " get_list: eax1 0,7 get offset tra gl_1 " get_list_co: ldx1 co_to_bo,7 convert offset to bits tra gl_1 " get_list_ho: ldx1 ho_to_bo,7 convert offset to bits tra gl_1 " get_list_aligned: eax1 0 zero offset " gl_1: eax6 3 set procedure to call tra plio join common section " " operators for get edit " entered with pointer to datum in bp, offset in x7, descriptor in q " get_edit: eax1 0,7 get offset tra ge_1 " get_edit_co: ldx1 co_to_bo,7 convert offset to bits tra ge_1 " get_edit_ho: ldx1 ho_to_bo,7 convert offset to bits tra ge_1 " get_edit_aligned: eax1 0 zero offset " ge_1: eax6 4 set procedure to call tra plio join common section " " " " operator for put list " entered with pointer to datum in bp, offset in x7, descriptor in q " put_list_eis: eax6 5 set procedure to call stq sp|temp save descriptor anq =o374000,du cmpq =o114000,du bit_str_desc tze |[put_field_str] cmpq =o120000,du var_bit_str_desc tze |[put_field_str] cmpq =o124000,du char_str_desc tze |[put_field_str] cmpq =o130000,du var_char_str_desc tze |[put_field_str] ldq sp|temp " plio_eis: eppap sp|ps_ptr,* get ptr to ps stq ap|ps.descriptor set descriptor sta ap|ps.offset store offset or picture constant loc spribp ap|ps.value_p set ptr to datum tra plio4 " put_list: eax1 0,7 get offset tra pl_1 " put_list_co: ldx1 co_to_bo,7 convert offset to bits tra pl_1 " put_list_ho: ldx1 ho_to_bo,7 convert offset to bits tra pl_1 " put_list_aligned: eax1 0 zero offset " pl_1: eax6 5 set procedure to call tra plio join common section " " operators for put edit " entered with pointer to datum in bp, offset in x7, descriptor in q " put_edit: eax1 0,7 get offset tra pe_1 " put_edit_co: ldx1 co_to_bo,7 convert offset to bits tra pe_1 " put_edit_ho: ldx1 ho_to_bo,7 convert offset to bits tra pe_1 " put_edit_aligned: eax1 0 zero offset " pe_1: eax6 6 set procedure to call " plio: eppap sp|ps_ptr,* get ptr to ps stq ap|ps.descriptor set descriptor sta ap|ps.offset store offset or picture constant loc spribp ap|ps.value_p set ptr to datum lxl1 shift_bo,1 shift bit offset to position sxl1 ap|ps.value_p+1 and set bit offset of pointer " plio4: eppbp sp|ps_ptr save pointer to ps as arg spribp sp|arg_list+2 sreg sp|8 save registers fld 2*1024,dl staq sp|arg_list eppap sp|arg_list get ptr to arg list tsx1 get_our_lp get ptr to our linkage section epp1 4,ic store return address and indicators spri1 sp|stack_frame.return_ptr sti sp|stack_frame.return_ptr+1 tra plio2,6 jump to appropriate proc lreg sp|8 restore registers put_return: eppap sp|tbp,* get ptr to object spriap sp|stack_frame.return_ptr reset return ptr eppap sp|stack_frame.operator_ptr,* restore ptr to operators tra sp|tbp,*0 and return " plio2: callsp |[get_terminate_] callsp |[put_terminate_] callsp |[put_value_data_] callsp |[get_value_list_] tra signal_error_missing callsp |[put_value_list_] callsp |[put_value_edit_] callsp |[plio2_recio_] callsp |[open_explicit_] callsp |[close_] callsp |[get_prep_] callsp |[put_prep_] callsp |[read_or_write] callsp |[file_control] callsp |[terminate] callsp |[element] callsp |[put_field_] tra signal_error_missing tra signal_error_missing tra signal_error_missing tra signal_error_missing callsp |[put_blanks_] callsp |[get_io_area_ptr] " " operator to terminate a get " get_terminate: eax6 0 set proc to call tra plio4 " " operator to terminate a put " put_terminate: eax6 1 set proc to call tra plio4 " " operator to open a file " open_file: eax6 8 set proc to call tra plio4 " " operator to close a file " close_file: eax6 9 set proc to call tra plio4 " " operators for doing FORTRAN I/O " " WARNING WARNING WARNING WARNING WARNING WARNING " " The following code was modified on 19 Dec 1977, by D. Levin to allow " fortran I/O's stack frame to remain active after control returns to the user's " program. This is accomplished by a coordinated effort on the parts of: " " 1. this operator segment " 2. fortran_io_.pl1 (in bound_fort_runtime_) " 3. return_to_user.alm (in bound_fort_runtime_) " " The first time a user program references fortran_io_ from its stack frame, " the high-order bit of stack_frame.ps_ptr is zero. This implementation takes advantage " of that fact and uses the high-order bit of stack_frame.ps_ptr as a flag to " indicate whether or not a stack frame exists for fortran_io_. " " The first time fortran_io_ is referenced from a stack frame, the high-order " bit is zero, so a standard PL/I call is made to the appropriate entry point in " fortran_io_, with the user's stack_frame.return_ptr set to return " to the word after the operator call. Once within fortran_io_, the " user's stack frame is modified as follows: " " 1. Copy fortran_io_'s stack_frame|4 to the user's frame. This field is used " by PL/I to determine the true end of the stack frame after a stack " extension. " 2. Store a packed ptr to fio_ps at stack_frame.support_ptr. See next " paragraph. " 3. Set high-order bit of stack_frame.ps_ptr to "1"b. " " The structure "fio_ps" is in fortran_io_'s stack frame and contains all the " necessary fields to allow communication between the user program and fortran_io_. " It includes: " 1. The address of a location within fortran_io_ to which control is passed " instead of performing a PL/I call. " 2. The address of fortran_io_'s stack frame. " 3. The address of a variable in fortran_io_'s stack frame into which the value " of xr7 is stored. This value identifies the entry point desired. " " When fortran_io_ returns to the user program, return_to_user$special_return " is called. This routine copies fortran_io_'s stack_frame.next_sp into the user's " stack_frame.next_sp, sets sp to the user's frame, and does a short_return. " Fortran_io_'s stack frame is now part of the user's frame and remains so until " the next I/O operation. Each fortran program frame has its own fortran_io_ frame. " This causes the user frame to "absorb" fortran_io_'s frame. " " NOTE - The procedure fortran_io_ must never perform a return_mac or " fortran_io_'s frame will go away although the flag in the user's frame claims " that it is still there. " " Setup operators entered with unit number in q, job_bits in a. Read previous page " of comments before modifying any FORTRAN I/O operators. " fortran_read: fortran_write: eax6 12 " ft_io: szn sp|ps_ptr " <0 if fortran_io_ already has a stack frame tmi ft_fast_read_or_write eppap sp|ps_ptr,* " load ptr to user's ps stq ap|ft_ps.unit sta ap|ft_ps.job_bits ft_io1: eppbp sp|ps_ptr " save pointer to ps as arg spribp sp|arg_list+2 sreg sp|8 " save registers fld 2*1024,dl staq sp|arg_list eppap sp|arg_list " get ptr to arg list tsx1 get_our_lp " get ptr to our linkage section stx0 sp|stack_frame.return_ptr+1 " save offset into user's segment sti sp|stack_frame.return_ptr+1 " save indicators tra plio2,x6 " jump to appropriate proc " ft_fast_read_or_write: lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps staq bb|fio_ps.job_bits_and_file ft_fast_call: stx0 sp|stack_frame.return_ptr+1 " save offset into user's segment sti sp|stack_frame.return_ptr+1 " save indicators sreg sp|8 eppbp bb|fio_ps.stack_frame_p,* " load ptr to fortran_io_'s static stack frame epp5 sp|stack_frame.next_sp,* " use parents next_sp spri5 bp|stack_frame.next_sp " for fortran_io_'s next_sp spri5 bp|4 " & for fortran_io_'s perm extension spribp sp|stack_frame.next_sp " store as next sp for user frame eppsp bp|0 " activate fortran_io_'s stack frame sxl6 bb|fio_ps.label_index_addr,* " store index value for fortran_io_'s transfer ldi 0,dl " force binary floating point mode tra bb|fio_ps.label_addr,* " transfer directly into fortran_io_ " " Transmission operators entered with pointer to element in pr2, descriptor in a, " and count in q. Read comments preceding the label "fortran_read" before modifying " this operator. " fortran_scalar_xmit: fortran_array_xmit: eax6 15 ft_fast_xmit: lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps spribp bb|fio_ps.element_ptr staq bb|fio_ps.ele_desc_and_count tra ft_fast_call " " File control operator entered with unit number in q, job_bits in a. Read comments " preceding the label "fortran_read" before modifying this operator. " fortran_manip: eax6 13 tra ft_io " " Termination operator, no registers. Read comments preceding the label " "fortran_read" before modifying this operator. " fortran_terminate: eax6 14 lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps tra ft_fast_call " " fortran open element " " Called with: " a-reg = bit string (boolean value) " q-reg = integer (string length, etc.) " x1 = case selector " pr2 = string pointer " pr3 = PS.buffer_p " ftn_open_element: tra *+1,1* arg ftn_open_indicators " 0 arg ftn_open_status " 1 arg ftn_open_io_switch " 2 arg ftn_open_attach_desc " 3 arg ftn_open_filename " 4 arg ftn_open_mode " 5 arg ftn_open_access " 6 arg ftn_open_form " 7 arg ftn_open_max_rec_len " 8 arg ftn_open_binary " 9 arg ftn_open_prompt " 10 arg ftn_open_carriage " 11 arg ftn_open_defer " 12 arg ftn_open_blank " 13 ftn_open_indicators: sta pr3|fortran_open_data.specified tra sp|tbp,*0 macro ftn_open_string ftn_open_&1: stq pr3|fortran_open_data.&1 lxl1 pr3|fortran_open_data.char_str stx1 pr3|fortran_open_data.&1 mlr (pr,rl),(pr,x1,rl) desc9a pr2|0,ql desc9a pr3|fortran_open_data.char_str+1,ql asq pr3|fortran_open_data.char_str tra sp|tbp,*0 &end ftn_open_string status ftn_open_string io_switch ftn_open_string attach_desc ftn_open_string filename ftn_open_string mode ftn_open_string access ftn_open_string form ftn_open_string blank ftn_open_max_rec_len: stq pr3|fortran_open_data.max_rec_len tra sp|tbp,*0 macro ftn_open_flag ftn_open_&1: sta pr3|fortran_open_data.&1 tra sp|tbp,*0 &end ftn_open_flag binary ftn_open_flag prompt ftn_open_flag carriage ftn_open_flag defer " " " ftn_inquire_element " " Called with: " a = bit mask " q = string length or unit number " pr2 = data pointer " pr3 = area pointer " x1 = case selector " ftn_inquire_element: tra *+1,x1* arg ftn_inquire_indicators " 0 arg ftn_inquire_noop " 1 arg ftn_inquire_noop " 2 arg ftn_inquire_noop " 3 arg ftn_inquire_filename " 4 arg ftn_inquire_noop " 5 arg ftn_inquire_access " 6 arg ftn_inquire_form " 7 arg ftn_inquire_recl " 8 arg ftn_inquire_noop " 9 arg ftn_inquire_noop " 10 arg ftn_inquire_noop " 11 arg ftn_inquire_noop " 12 arg ftn_inquire_blank " 13 arg ftn_inquire_unit " 14 arg ftn_inquire_noop " 15 arg ftn_inquire_noop " 16 arg ftn_inquire_exist " 17 arg ftn_inquire_opened " 18 arg ftn_inquire_number " 19 arg ftn_inquire_named " 20 arg ftn_inquire_name " 21 arg ftn_inquire_sequential " 22 arg ftn_inquire_formatted " 23 arg ftn_inquire_unformatted " 24 arg ftn_inquire_nextrec " 25 arg ftn_inquire_direct " 26 ftn_inquire_indicators: sta pr3|ftn_inquire_data.specified tra sp|tbp,*x0 ftn_inquire_noop: tra sp|tbp,*x0 ftn_inquire_filename: mlr (pr,rl),(pr),fill(040) desc9a pr2|0,ql desc9a pr3|ftn_inquire_data.filename,168 tra sp|tbp,*x0 ftn_inquire_unit: stq pr3|ftn_inquire_data.unit tra sp|tbp,*x0 macro ftn_inquire_string ftn_inquire_&1: sprp2 pr3|ftn_inquire_data.&1 stq pr3|ftn_inquire_data.&1+1 tra sp|tbp,*x0 &end ftn_inquire_string access ftn_inquire_string form ftn_inquire_string blank ftn_inquire_string name ftn_inquire_string sequential ftn_inquire_string formatted ftn_inquire_string unformatted ftn_inquire_string direct macro ftn_inquire_word ftn_inquire_&1: sprp2 pr3|ftn_inquire_data.&1 tra sp|tbp,*x0 &end ftn_inquire_word recl ftn_inquire_word exist ftn_inquire_word opened ftn_inquire_word number ftn_inquire_word named ftn_inquire_word nextrec " " " get address of I/O area operator, no registers. Read comments preceding the label " "fortran_read" before modifying this operator. " ftn_get_area_ptr: eax6 22 szn sp|ps_ptr " <0 if fortran_io_ already has a stack frame tpl ft_io1 lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps tra ft_fast_call " " operators to do pl1 pointer function, entered with pointer to area in bp " and offset in q. " pointer_easy: pointer_hard: cmpq nullo are we converting null offset tnz 4,ic no, do conversion ldaq null yes, get null ptr eppbp null,* and in bp tra sp|tbp,*0 and return spribp sp|temp adlq sp|temp+1 add in word and bit offset stq sp|temp+1 .. eppbp sp|temp,* load ptr into bp ldaq sp|temp and into aq tra sp|tbp,*0 and return " " operator to do pl1 pointer function when packed ptr should be returned " pointer_easy_pk: pointer_hard_pk: cmpq nullo return null if null input tnz 4,ic ldq null_pk eppbp null,* tra sp|tbp,*0 spribp sp|temp adlq sp|temp+1 add in word and bit offset stq sp|temp+1 .. eppbp sp|temp,* load ptr into bp ldaq sp|temp and into aq tra unpk_to_pk go return packed value " " operators for doing pl1 offset function. entered with pointer to area in bp " and pointer value in aq or q " offset_easy: offset_hard: anaq ptr_mask is input null cmpaq nullx tnz 3,ic no, do conversion oe: ldq nullo return null offset tra sp|tbp,*0 oe1: stq sp|temp2 save word and bit offset eaa bp|0 get offset of area in au era mask_bit_one form 2's complement of whole a-reg adla 1,dl w/o overflow adla sp|temp2 subtract area origin from word offset lrl 36 shift into q tra sp|tbp,*0 and return " offset_easy_pk: offset_hard_pk: cmpq null_pk is input null tze oe yes, go return null offset qlr 6 no, convert to proper form qls 12 lls 18 qrl 3 lrl 18 tra oe1 go subtract area origin " " operator to alloc block of N words in the user storage area " as defined by the stack header " entered with N in q, returns with pointer to block " in bp. " alloc_storage: epbpsb sp|0 eppbp sb|stack_header.user_free_ptr,* tra |[op_storage_] " " operator to alloc block of N words in user storage area " entered with N in q and bp pointing at where to put ptr " alloc_block: sxl0 sp|stack_frame.operator_ret_ptr save return eax0 z_done load index with return " call_alloc: sreg sp|8 save registers include size of block in Q spribp sp|arg_list+6 save address of ptr eppbp sp|8+5 get address of saved size spribp sp|arg_list+2 and use as 1st arg epbpsb sp|0 get ptr to our stack header eppbp sb|stack_header.user_free_ptr and pass user free ptr as 2nd arg spribp sp|arg_list+4 fld 3*2048,dl eppbp |[storage_] call alloc_|storage_ " call_alloc_free: staq sp|arg_list save head of arg list eppap sp|arg_list get ptr to arg list epp1 4,ic store return address and indicators spri1 sp|stack_frame.return_ptr sti sp|stack_frame.return_ptr+1 callsp bp|0 lreg sp|8 restore registers eppbp sp|tbp,* restore ptr in sp|stack_frame.return_ptr spribp sp|stack_frame.return_ptr tra 0,0 return to caller " " operator to free block pointed at by pointer pointed at by bp " free_block: ldaq bp|0 return if there is nothing to free eraq null anaq ptr_mask tze sp|tbp,*0 sxl0 sp|stack_frame.operator_ret_ptr save return eax0 z_done load index with return " call_free: sreg sp|8 save registers spribp sp|arg_list+2 save address of pointer eppbp |[freen_] get ptr to proc fld 1*2048,dl tra call_alloc_free go call proc " " operator to allocate controlled generation given size of descriptor in q " and pointer to controlled block in bp " push_ctl_desc: eax1 2 init offset tra push_ctl_data+1 " " operator to allocate controlled generation given size of data in q " and pointer to controlled block in bp " push_ctl_data: eax1 0 init offset " sxl0 sp|stack_frame.operator_ret_ptr spribp sp|temp_pt save ptr to ctl variable adq 6,dl add in size of ctl block eppbp sp|double_temp get ptr to temp tsx0 call_alloc go allocate space eppbp sp|temp_pt,* get back ptr to ctl block epplp sp|double_temp,* get ptr to allocated space ldaq bp|0 copy current generation staq lp|0 ldaq bp|2 staq lp|2 ldaq bp|4 staq lp|4 sprilp bp|4 store ptr to old generation epplp lp|6 get ptr to data|desc sprilp bp|0,1 store ptr to data|desc tra z_done and return " " operators to free a controlled generation, entered with " pointer to controlled block in bp " pop_ctl_data: pop_ctl_desc: ldaq bp|4 return if there is nothing to free eraq null anaq ptr_mask tze sp|tbp,*0 sxl0 sp|stack_frame.operator_ret_ptr epplp bp|4,* get ptr to previous generation sprilp sp|temp_pt save for freeing ldaq lp|0 copy old generation into current staq bp|0 ldaq lp|2 staq bp|2 ldaq lp|4 staq bp|4 eppbp sp|temp_pt get ptr to block to be freed tsx0 call_free free it tra z_done and then return " " operator to return number of allocated generation of contrlled " variable specified by bp " allocation: eax1 0 init count ldaq bp|4 get ptr to previous generation eraq null check for null anaq ptr_mask tze allocation_done null means done eppbp bp|4,* not null, step backwards adlx1 1,du update count tra allocation+1 allocation_done: eaq 0,1 move count to ql qrl 18 tra sp|tbp,*0 and return " " operators for unpacking|packing pictured values " entered with pr1 -> target, pr3 -> picture, pr5 -> source " unpack_picture: tsx1 get_our_lp eppbp |[unpack_picture_] tra picture_common " pack_picture: tsx1 get_our_lp eppbp |[pack_picture_] " picture_common: sxl0 sp|stack_frame.operator_ret_ptr eax0 z_done sreg sp|8 spri1 sp|arg_list+2 spri3 sp|arg_list+4 spri5 sp|arg_list+6 fld 3*2048,dl tra call_alloc_free " " internal subroutine to signal a condition. entered with " bp pointing at name and x6 holding size of name " call_signal_: sreg sp|8 save registers for call get_stack_offset eppap sp|stack_header.stack_end_ptr,au* get ptr to end of stack frame eax0 48 increase stack frame by 48 words adlx0 sp|stack_frame.next_sp+1 .. stx0 sp|stack_frame.next_sp+1 stx0 sp|stack_header.stack_end_ptr+1,au adjust stack end pointer too spri ap|0 save bases eppap ap|24 get ptr to arg list spribp ap|2 save ptr to condition name as 1st arg eppbp null get ptr to null file spribp ap|10 save as 5th arg signal_common: stq ap|14 store oncode value eppbp ap|14 use oncode value spribp ap|8 as 4th arg stz ap|15 save string length of condition name sxl6 ap|15 eppbp ap|15 pass name length spribp ap|4 as 2nd arg lxl7 sp|stack_frame.operator_ret_ptr get ptr to entry into pl1_operators_ sbx7 1,du eppbp sp|tbp,*7 and save for use spribp ap|12 as 3rd arg eppbp ap|12 spribp ap|6 fld 5*2048,dl set number of args staq ap|0 tsx1 get_our_lp get ptr to our linkage epp1 4,ic store return address and indicators spri1 sp|stack_frame.return_ptr sti sp|stack_frame.return_ptr+1 tra |[pl1_signal_from_ops_] eppap sp|stack_frame.next_sp,* point 48 words past stack extension lpri ap|-48 restore pointer regs get_stack_offset ldx0 sp|stack_frame.next_sp+1 reset the stack frame size sblx0 48,du by subtracting the 48 words we added. stx0 sp|stack_frame.next_sp+1 update next sp pointer stx0 sp|stack_header.stack_end_ptr+1,au update stack end too lreg sp|8 restore machine registers epbpap sp|tbp,*0 restore return word pair spriap sp|stack_frame.return_ptr segment number eppap sp|stack_frame.operator_ptr,* and pointer to operators tra 0,1 and return " " Subroutine to load PR4 with a pointer to linkage of " pl1_operators_. Also sets PR7 to stack|0. Calling sequence: " tsx1 get_our_lp " get_our_lp: get_our_lp tra 0,1 return with lp loaded to our linkage " " operator to signal io condition, same as signal except sp|40 holds " pointer to file name. " io_signal: eax1 z_done get return_pt for call to signal_common sreg sp|8 save register for call get_stack_offset sxl0 sp|stack_frame.operator_ret_ptr eppap sp|stack_header.stack_end_ptr,au* get pointer to end of stack frame eax0 48 increase stack frame by 48 words adlx0 sp|stack_frame.next_sp+1 .. stx0 sp|stack_frame.next_sp+1 .. stx0 sp|stack_header.stack_end_ptr+1,au don't forget stack end ptr spri ap|0 store bases eppap ap|24 get ptr to arg list ldq =1000,dl get oncode value spribp ap|2 store ptr to cond name as 1st arg eppbp sp|40 store ptr to file spribp ap|10 as 5th arg tra signal_common jump into common section to signal and return " " operator to set support bit in stack frame " set_support: lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word tra sp|tbp,*0 " get_math_entry: tsx1 get_our_lp xec fort_math_names-1,2 get entry tra sp|tbp,*0 return fort_math_names: epp2 |[exp_] 1 epp2 |[alog_] 2 epp2 |[alog10_] 3 epp2 |[atan_] 4 epp2 |[atan2_] 5 epp2 |[sin_] 6 epp2 |[cos_] 7 epp2 |[tanh_] 8 epp2 |[sqrt_] 9 epp2 |[dmod_] 10 epp2 |[dexp_] 11 epp2 |[dlog_] 12 epp2 |[dlog10_] 13 epp2 |[datan_] 14 epp2 |[datan2_] 15 epp2 |[dsin_] 16 epp2 |[dcos_] 17 epp2 |[dsqrt_] 18 epp2 |[cabs_] 19 epp2 |[cexp_] 20 epp2 |[clog_] 21 epp2 |[csin_] 22 epp2 |[ccos_] 23 epp2 |[csqrt_] 24 epp2 |[cxp2_] 25 epp2 |[tan_] 26 epp2 |[dtan_] 27 epp2 |[asin_] 28 epp2 |[dasin_] 29 epp2 |[acos_] 30 epp2 |[dacos_] 31 epp2 |[index_] 32 epp2 |[dtanh_] 33 epp2 |[sinh_] 34 epp2 |[dsinh_] 35 epp2 |[cosh_] 36 epp2 |[dcosh_] 37 epp2 |[abs_] 38 epp2 |[iabs_] 39 epp2 |[dabs_] 40 epp2 |[dim_] 41 epp2 |[idim_] 42 epp2 |[ddim_] 43 epp2 |[sign_] 44 epp2 |[isign_] 45 epp2 |[dsign_] 46 epp2 |[aint_] 47 epp2 |[aimag_] 48 epp2 |[conjg_] 49 epp2 |[len_] 50 epp2 |[dint_] 51 epp2 |[anint_] 52 epp2 |[dnint_] 53 epp2 |[nint_] 54 epp2 |[idnint_] 55 epp2 |[dprod_] 56 epp2 |[mod_] 57 epp2 |[amod_] 58 epp2 |[ilr_] 59 epp2 |[ils_] 60 epp2 |[irl_] 61 epp2 |[irs_] 62 fortran_end: ldq 4,dl stq sp|arg_list stz sp|arg_list+1 epp0 sp|arg_list tsx1 get_our_lp callsp |[fortran_end] fortran_pause: eax2 0 tra pause_stop fortran_stop: eax2 1 pause_stop: spri2 sp|arg_list+2 argument 1 orq =o524000,du stq sp|temp epp2 sp|temp spri2 sp|arg_list+4 descriptor 1 fld 1*2048,dl one argument eaq 0,au there are descriptors staq sp|arg_list epp0 sp|arg_list get argument list header stx0 sp|stack_frame.return_ptr+1 save return point sti sp|stack_frame.return_ptr+1 save indicators tsx1 get_our_lp xec pause_stop_names,2 callsp pr2|0 pause_stop_names: epp2 |[fortran_pause_] epp2 |[fortran_stop_] fortran_chain: spri2 sp|arg_list+2 argument 1 ldaq old_sys_name old system name staq pr2|43 tsx1 get_our_lp epp2 |[chain_entry] fld 1*2048,dl one argument staq sp|arg_list epp0 sp|arg_list get argument list header epp3 pr2|2,* get display pointer spri3 pr0|2,au store at the end of the argument list stx0 sp|stack_frame.return_ptr+1 save return point sti sp|stack_frame.return_ptr+1 save indicators callsp pr2|0,* make the call old_sys_name: even aci "fortran " " " Function: enter Binary Floating Point (BFP) mode " " Entry: X0 = offset in caller's text section of return point " " Exit: PR0, (sp|stack_frame.operator_ptr) -> operator_table " enter_BFP_mode: ldi 0,dl clear HFP mode if it's set epp0 operator_table change to BFP operators spri0 sp|stack_frame.operator_ptr tra sp|tbp,*x0 " " Function: enter Hexadecimal Floating Point (HFP) mode " " Entry: X0 = offset in caller's text section of return point " " Exit: PR0, (sp|stack_frame.operator_ptr) = hfp_operator_table " " Note: It is not sufficient to just request HFP mode. We must " check that our request has been honoured, since if HFP " mode has not been enabled (or if it is not supported), a " request to enter HFP mode is simply ignored. If we find " that our request to enter HFP mode has not been honoured, " we attempt to enable HFP mode. If we are unsuccessful, " we signal the condition 'cannot_enable_HFP_mode'. If we " are restarted after signalling this condition, we repeat " all the above steps. " enter_HFP_mode: ldi HFP_mask,dl request HFP mode fld P1.0H,du check if request honoured fad P0.0H,du sba =o020000,du tze enter_HFP_mode.entered lda =o600000,du try to enable HFP mode tsx1 call_set_hexfp_control ldi HFP_mask,dl check if successful fld P1.0H,du fad P0.0H,du sba =o020000,du tze enter_HFP_mode.entered ldi =0,dl clear HFP mode request eppbp =22acannot_enable_HFP_mode eax6 22 ldq =1000,dl tsx1 call_signal_ signal 'cannot_enable_HFP_mode' condition tra enter_HFP_mode try again enter_HFP_mode.entered: epp0 hfp_operator_table change to HFP operators spri0 sp|stack_frame.operator_ptr tra sp|tbp,*x0 " " Function: call 'hcs_$set_hexfp_control'. " " Entry: A = desired value for 1st argument: " 1b2 => retain current mode " 2b2 => disable HFP mode " 3b2 => enable HFP mode " X1 = offset of return address " " Exit: A = returned value of 2nd argument: " 2b2 => HFP mode was disabled before call " 3b2 => HFP mode was enabled before call " Q = returned value of 3rd argument: " a standard system status code. " " Alters: A, Q, (sp|8:sp|15). " call_set_hexfp_control: sreg sp|8 save X0:X7, AQ and E get_stack_offset eppap sp|stack_header.stack_end_ptr,au* get ptr to end of stack frame eax0 32 increase stack frame by 32 words adlx0 sp|stack_frame.next_sp+1 .. stx0 sp|stack_frame.next_sp+1 stx0 sp|stack_header.stack_end_ptr+1,au adjust stack end pointer too spri ap|0 save PR0:PR7 eppap ap|16 form argument list fld 3*2048,dl staq ap|0 there are 3 arguments epp1 sp|8+4 spri1 ap|2 1st argument is cache for A spri1 ap|4 2nd argument is cache for A epp1 sp|8+5 spri1 ap|6 3rd argument is cache for Q tsx1 get_our_lp epp1 4,ic make the call: spri1 sp|stack_frame.return_ptr sti sp|stack_frame.return_ptr+1 callsp |[set_hexfp_control] eppap sp|stack_frame.next_sp,* point 32 words past stack extension lpri ap|-32 restore pointer regs get_stack_offset ldx0 sp|5 get offset of original end of frame stx0 sp|stack_frame.next_sp+1 update next sp pointer stx0 sp|stack_header.stack_end_ptr+1,au update stack end too lreg sp|8 restore machine registers epbpap sp|tbp,*0 restore return word pair spriap sp|stack_frame.return_ptr segment number eppap sp|stack_frame.operator_ptr,* and pointer to operators tra 0,x1 return " " this code execute for unimplemented operators " unimp: spribp sp|double_temp save bp stx6 sp|temp2 eppbp error_name signal error condition eax6 error_length ldq =710,dl with oncode = 710 tra ssc error_name: aci "error" equ error_length,5 " " Single word mask arrays are used only by operators " bit_mask_one: vfd 0/-1,36/0 vfd 1/-1,35/0 vfd 2/-1,34/0 vfd 3/-1,33/0 vfd 4/-1,32/0 vfd 5/-1,31/0 vfd 6/-1,30/0 vfd 7/-1,29/0 vfd 8/-1,28/0 vfd 9/-1,27/0 vfd 10/-1,26/0 vfd 11/-1,25/0 vfd 12/-1,24/0 vfd 13/-1,23/0 vfd 14/-1,22/0 vfd 15/-1,21/0 vfd 16/-1,20/0 vfd 17/-1,19/0 vfd 18/-1,18/0 vfd 19/-1,17/0 vfd 20/-1,16/0 vfd 21/-1,15/0 vfd 22/-1,14/0 vfd 23/-1,13/0 vfd 24/-1,12/0 vfd 25/-1,11/0 vfd 26/-1,10/0 vfd 27/-1,9/0 vfd 28/-1,8/0 vfd 29/-1,7/0 vfd 30/-1,6/0 vfd 31/-1,5/0 vfd 32/-1,4/0 vfd 33/-1,3/0 vfd 34/-1,2/0 vfd 35/-1,1/0 " mask_bit_one: vfd 0/0,36/-1 vfd 1/0,35/-1 vfd 2/0,34/-1 vfd 3/0,33/-1 vfd 4/0,32/-1 vfd 5/0,31/-1 vfd 6/0,30/-1 vfd 7/0,29/-1 vfd 8/0,28/-1 vfd 9/0,27/-1 vfd 10/0,26/-1 vfd 11/0,25/-1 vfd 12/0,24/-1 vfd 13/0,23/-1 vfd 14/0,22/-1 vfd 15/0,21/-1 vfd 16/0,20/-1 vfd 17/0,19/-1 vfd 18/0,18/-1 vfd 19/0,17/-1 vfd 20/0,16/-1 vfd 21/0,15/-1 vfd 22/0,14/-1 vfd 23/0,13/-1 vfd 24/0,12/-1 vfd 25/0,11/-1 vfd 26/0,10/-1 vfd 27/0,9/-1 vfd 28/0,8/-1 vfd 29/0,7/-1 vfd 30/0,6/-1 vfd 31/0,5/-1 vfd 32/0,4/-1 vfd 33/0,3/-1 vfd 34/0,2/-1 vfd 35/0,1/-1 " single_bit: " vfd 0/0,1/1 vfd 1/0,1/1 vfd 2/0,1/1 vfd 3/0,1/1 vfd 4/0,1/1 vfd 5/0,1/1 vfd 6/0,1/1 vfd 7/0,1/1 vfd 8/0,1/1 vfd 9/0,1/1 vfd 10/0,1/1 vfd 11/0,1/1 vfd 12/0,1/1 vfd 13/0,1/1 vfd 14/0,1/1 vfd 15/0,1/1 vfd 16/0,1/1 vfd 17/0,1/1 vfd 18/0,1/1 vfd 19/0,1/1 vfd 20/0,1/1 vfd 21/0,1/1 vfd 22/0,1/1 vfd 23/0,1/1 vfd 24/0,1/1 vfd 25/0,1/1 vfd 26/0,1/1 vfd 27/0,1/1 vfd 28/0,1/1 vfd 29/0,1/1 vfd 30/0,1/1 vfd 31/0,1/1 vfd 32/0,1/1 vfd 33/0,1/1 vfd 34/0,1/1 vfd 35/0,1/1 " floor_ceil_mask: " vfd 36/0,0/-1 vfd 35/0,1/-1 vfd 34/0,2/-1 vfd 33/0,3/-1 vfd 32/0,4/-1 vfd 31/0,5/-1 vfd 30/0,6/-1 vfd 29/0,7/-1 vfd 28/0,8/-1 vfd 27/0,9/-1 vfd 26/0,10/-1 vfd 25/0,11/-1 vfd 24/0,12/-1 vfd 23/0,13/-1 vfd 22/0,14/-1 vfd 21/0,15/-1 vfd 20/0,16/-1 vfd 19/0,17/-1 vfd 18/0,18/-1 vfd 17/0,19/-1 vfd 16/0,20/-1 vfd 15/0,21/-1 vfd 14/0,22/-1 vfd 13/0,23/-1 vfd 12/0,24/-1 vfd 11/0,25/-1 vfd 10/0,26/-1 vfd 9/0,27/-1 vfd 8/0,28/-1 vfd 7/0,29/-1 vfd 6/0,30/-1 vfd 5/0,31/-1 vfd 4/0,32/-1 vfd 3/0,33/-1 vfd 2/0,34/-1 vfd 1/0,35/-1 vfd 0/0,36/-1 " " " Entry operators, entered by following sequence in text section " " eax7 stack_size " eppbp sb|stack_header.pl1_operators_ptr,* " tspbp bp|n (bp points at segdef operator_table) " vfd 18/n_args,18/unused " vfd 18/link,18/block " " " " " The following macro is the ext_entry macro. It conditionally expands the " trace code if the first argument is "trace_". It conditionally sets " the static ptr if the second argument is "ss_". " macro ext_entry &1&2ext_entry: eppbp bp|-3 get correct entry pointer value trace &1 epaq bp|0 get segment number in a lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr ife &2,ss_ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr ifend eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back ptr of new frame spriap bb|stack_frame.arg_ptr save arg pointer eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr update stack end ptr eppsp bb|0 update sp &1&2save_link: sprilp sp|linkage_ptr save ptr to linkage in stack head ife &2,ss_ sprplb sp|stack_frame.static_ptr save static ptr ifend spribp sp|stack_frame.entry_ptr save ptr to entry point &1&2init_stack_join: spbpbp sp|text_base_ptr save ptr to base of text segment spbpbp sp|stack_frame.return_ptr init procedure call return point stz sp|stack_frame.operator_ret_ptr init operator return offset " eppap &1operator_table and pointer to operators spriap sp|stack_frame.operator_ptr save pointer to operator segment spriab sp|4 save pointer to end of frame for temp extensions ldi 0,dl reset all indicators (overflow mask in particular) tra bp|5 and return to user program &end ext_entry " " The following macro is analogous to ext_entry except for entries which expect " descriptors. " macro ext_entry_desc &1&2ext_entry_desc: eppbp bp|-3 get correct entry pointer value trace &1 epaq bp|0 get segment number of text lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr ife &2,ss_ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr ifend eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back ptr of new frame spriap bb|stack_frame.arg_ptr save arg pointer eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr set new stack end ptr eppsp bb|0 update sp " &1&2eed: lda ap|0 get 2*n_args in au, code in al cana 8,dl is there an extra arg tze 2,ic no ada 2,du yes, allow for it eppbb ap|2,au get ptr to descriptors spribb sp|descriptor_ptr set ptr in stack frame tra &1&2save_link join common section &end " ext_entry_desc " " The following macro is the other_entries macro. It conditionally " sets the static ptr if the first argument is "ss_". " macro other_entries &1int_entry: epaq bp|0 get segment number of text lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr ife &1,ss_ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr ifend eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back ptr of new frame spriap bb|stack_frame.arg_ptr save arg pointer eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr set new stack end ptr eppsp bb|0 update sp " lda ap|0 get 2*n_args in au " &1set_display: eppbb ap|2,au* get display ptr spribb sp|display_ptr and save in stack frame eppbp bp|-3 set correct entry pointer value tra &1save_link join common section " &1int_entry_desc: epaq bp|0 get segment number of text lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr ife &1,ss_ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr ifend eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back ptr of new frame spriap bb|stack_frame.arg_ptr save arg pointer eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr set new stack end ptr eppsp bb|0 update sp " lda ap|0 get 2*n_args in au, code in al eppbb ap|4,au get ptr to descriptors spribb sp|descriptor_ptr set ptr in stack frame tra &1set_display go set display ptr " &1val_entry_desc: eax0 &1eed get final destination tra &1val_entry+1 join common validate code " &1val_entry: eax0 &1save_link get final destination " spribp sb|stack_header.stack_end_ptr,* save entry pointer eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back ptr of new frame spriap bb|stack_frame.arg_ptr save arg pointer eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr set up new end ptr eppsp bb|0 update sp " epaq bp|0 get segment number of text lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage ife &1,ss_ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static ifend eppap operator_table spriap sp|stack_frame.operator_ptr eppap sp|stack_frame.arg_ptr get ptr to arglist spriap sp|arg_list+2 save as arg of validate call fld 2*1024,dl staq sp|arg_list eppap sp|arg_list get ptr to arglist for validate call sprplp sp|4 save lp - we need it at save_link ife &1,ss_ sprplb sp|5 save lb ifend stx0 sp|8 save x0 for eventual exit ldx1 bp|2 get link offset of validate proc stcd sp|stack_frame.return_ptr call the validate proc tra lp|0,1* ldx0 sp|8 restore x0 lprplp sp|4 and lp ife &1,ss_ lprplb sp|5 and lb ifend eppab sb|stack_header.stack_end_ptr,* eppap sp|stack_frame.arg_ptr,* restore argument list pointer eppbp sp|0,* restore entry return pointer eppbp bp|-3 set correct entry pointer value tra 0,0 and re-enter main stream &end " other_entries " ext_entry ,ss_ " ext_entry_desc ,ss_ " other_entries ss_ " " " operator to enter a begin block " calling sequence is: " " eax7 stack_size " tspbp ap|enter_begin_block " vfd 18/link,18/block for symbol table " macro enter_begin &1enter_begin_block: epplp sp|linkage_ptr,* get linkage pointer from parent frame ife &1,ss_ lprplb sp|stack_frame.static_ptr get static pointer from parent frame ifend epbpsb sp|0 get ptr to base of stack eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back pointer of new frame eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr set stack end pointer sprisp bb|display_ptr set display pointer eppsp bb|0 update sp " ldaq null set arg list pointer to null staq sp|stack_frame.arg_ptr .. sprilp sp|linkage_ptr save linkage ptr ife &1,ss_ sprplb sp|stack_frame.static_ptr save static ptr ifend eppbp bp|-2 spribp sp|stack_frame.entry_ptr eppbp bp|-2 get correct entry pointer tra init_stack_join go init stack frame &end " enter_begin " enter_begin ss_ " " entry_operators_end: zero 0,* marks end of entry operators " " even null: its -1,1,n nullx: oct 077777000043,000001000000 null_pk: oct 007777000001 nullo: oct 777777777777 one: dec 0,1 almost_one: hfp_almost_one: oct 000777777777,777777777777 k71b25: oct 216000000000,000000000000 " shift_bo: dec 0b26,1b26,2b26,3b26,4b26,5b26,6b26,7b26,8b26,9b26 dec 10b26,11b26,12b26,13b26,14b26,15b26,16b26,17b26,18b26,19b26 dec 20b26,21b26,22b26,23b26,24b26,25b26,26b26,27b26,28b26,29b26 dec 30b26,31b26,32b26,33b26,34b26,35b26 " " The follow line must appear after everything else in text segment " end_pl1_operators: zero 0,* marks end of pl1_operators " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " END OF WIRED SECTION " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " START OF PAGED SECTION " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " The following code is used when hexadecimal floating point mode has been "selected via a call to the 'enter_HFP_mode' operator. " transfer_vector ,hfp_ " " Function: ceiling of a float hex (71) number " " Entry: EAQ = number " X0 = offset in caller's text section of return point " " Exit: EAQ = ceil(number) " hfp_ceil_fl: tmi 6,ic if number +ve then: dfad hfp_almost_one EAQ = number + almost_one fmp P2.0H,du EAQ = 2*(number + almost_one) fad =18b25,du EAQ = 2*ceil(number) fmp P0.5H,du EAQ = ceil(number) tra sp|tbp,*x0 return " else: fmp M2.0H,du EAQ = 2*abs(number) fad =18b25,du EAQ = 2*floor(abs(number)) fmp M0.5H,du EAQ = -floor(abs(number)) tra sp|tbp,*x0 return " " Function: convert a float hex (71) number to fixed bin (71) " " Entry: EAQ = number " X0 = offset in caller's text section of return point " " Exit: AQ = fixed (number, 71) " hfp_fl2_to_fx1: hfp_fl2_to_fx2: fad P0.0H,du tmi 4,ic if number +ve then: fmp P2.0H,du EAQ = 2*number ufa =18b25,du AQ = floor(number) tra sp|tbp,*x0 return " else: fmp M2.0H,du EAQ = 2*abs(number) ufa =18b25,du AQ = floor (abs (number)) negl 0 AQ = -floor(abs(number)) tra sp|tbp,*x0 return " " Function: convert a float hex (71) number to fixed bin " (71, scale) " " Entry: EAQ = number " X0 = offset in caller's text section of the word " containing the scale factor in the format " 8/71-scale,28/0 " " Exit: to word after scale factor word with: " AQ = floor(number * 2**scale) " " Note: The format of the word containing the scale factor is the " same as that used when converting float bin (71) to fixed " bin (71, scale). THIS IS NOT THE BEST FORMAT FOR " CONVERTING HEX NUMBERS. It is used because that is what " the current PL/I compiler generates. If float hex is ever " added as a proper 'pl1' data type, it would be wise to " change the format of the scale word to contain the float " hex (27) representation of 2**(scale-1). This would " shorten the conversion code to: " "hfp_fl2_to_fxscaled: " fad P0.0H,du " tmi 4,ic if number +ve then: " fmp sp|tbp,*x0 EAQ = 2*number * 2**scale " ufa =18b25,du AQ = floor(number * 2**scale) " tra 5,ic else: " fneg 0 EAQ = abs(number) " fmp sp|tbp,*x0 EAQ = 2*abs(number) * 2**scale " ufa =18b25,du AQ = floor(abs(number) * 2**scale) " negl 0 AQ = -floor(abs(number) * 2**scale) " adx0 =1,du skip scale word " tra sp|tbp,*x0 return " hfp_fl2_to_fxscaled: staq sp|temp save mantissa of number lda sp|tbp,*x0 A = 8/71-scale,28/0 ars 28 A = 71-scale neg 0 A = scale-71 ada =72,dl A = scale+1 lrs 2 A = floor((scale+1)/4) qrl 34 Q = (scale+1) - 4*floor((scale+1)/4) eax1 0,ql X1 = (scale+1) - 4*floor((scale+1)/4) ada =1,dl A = floor((scale+1)/4) + 1 ldq =1,dl Q = 2**0 qls 31,x1 Q = 2**(X1+31) lls 28 A = HFP representation of 2**(scale+1) sta sp|temp2 save scale factor ldaq sp|temp restore mantissa of number tmi 4,ic if number +ve then: fmp sp|temp2 EAQ = 2*number * 2**scale ufa =18b25,du AQ = floor(number * 2**scale) tra 5,ic else: fneg 0 EAQ = abs(number) fmp sp|temp2 EAQ = 2*abs(number) * 2**scale ufa =18b25,du AQ = floor(abs(number) * 2**scale) negl 0 AQ = -floor(abs(number) * 2**scale) adx0 =1,du skip scale word tra sp|tbp,*x0 return " " Function: floor of a float hex (71) number " " Entry: EAQ = number " X0 = offset in caller's text section of return point " " Exit: EAQ = floor(number) " hfp_floor_fl: tmi 5,ic if number +ve then: fmp P2.0H,du EAQ = 2*number fad =18b25,du EAQ = 2*floor(number) fmp P0.5H,du EAQ = floor(number) tra sp|tbp,*x0 return " else: dfsb hfp_almost_one EAQ = -(abs(number) + almost_one) fmp M2.0H,du EAQ = 2*(abs(number) + almost_one) fad =18b25,du EAQ = 2*ceil(abs(number)) fmp M0.5H,du EAQ = -ceil(abs(number)) tra sp|tbp,*x0 return " " Function: FORTRAN float hex (63) modulus: dmod(x, y) " " Entry: EAQ = x " bp|0 -> y " X0 = offset in caller's text section of return point " Exit: EAQ = if y=0 then 0 else x - trunc(x/y)*y " hfp_fort_dmod: fszn bp|0 return 0 if y is 0 tze sp|tbp,*x0 dfstr sp|temp save x dfdv bp|0 EAQ = x/y tmi 5,ic if EAQ >= 0 then: fmp P2.0H,du EAQ = 2*x/y fad =18b25,du EAQ = 2*floor(x/y) fmp M0.5H,du EAQ = -trunc(x/y) tra 4,ic else: fmp M2.0H,du EAQ = 2*abs(x/y) fad =18b25,du EAQ = 2*floor(abs(x/y)) fmp P0.5H,du EAQ = -trunc(x/y) dfmp bp|0 EAQ = -trunc(x/y)*y dfad sp|temp EAQ = x - trunc(x/y)*y tra sp|tbp,*x0 return " " Function: FORTRAN float hex (27) modulus: amod(x, y) " " Entry: EAQ = x " bp|0 -> y " X0 = offset in caller's text section of return point " " Exit: EAQ = if y=0 then 0 else x - trunc(x/y)*y " hfp_fort_mdfl1: fszn bp|0 return 0 if y is 0 tze sp|tbp,*x0 fstr sp|temp save x fdv bp|0 EAQ = x/y tmi 5,ic if EAQ >= 0 then: fmp P2.0H,du EAQ = 2*x/y fad =18b25,du EAQ = 2*floor(x/y) fmp M0.5H,du EAQ = -trunc(x/y) tra 4,ic else: fmp M2.0H,du EAQ = 2*abs(x/y) fad =18b25,du EAQ = 2*floor(abs(x/y)) fmp P0.5H,du EAQ = -trunc(x/y) fmp bp|0 EAQ = -trunc(x/y)*y fad sp|temp EAQ = x - trunc(x/y)*y tra sp|tbp,*x0 return " " Function: Get address of a specified FORTRAN intrinsic function. " " Entry: X0 = offset in caller's text section of return point. " X2 = index of the intrinsic function. " " Exit: PR2 = address of entry point of specified intrinsic. " hfp_get_math_entry: tsx1 get_our_lp xec hfp_fort_math_names-1,2 get entry tra sp|tbp,*0 return hfp_fort_math_names: epp2 |[exp_] 1 epp2 |[alog_] 2 epp2 |[alog10_] 3 epp2 |[atan_] 4 epp2 |[atan2_] 5 epp2 |[sin_] 6 epp2 |[cos_] 7 epp2 |[tanh_] 8 epp2 |[sqrt_] 9 epp2 |[dmod_] 10 epp2 |[dexp_] 11 epp2 |[dlog_] 12 epp2 |[dlog10_] 13 epp2 |[datan_] 14 epp2 |[datan2_] 15 epp2 |[dsin_] 16 epp2 |[dcos_] 17 epp2 |[dsqrt_] 18 epp2 |[cabs_] 19 epp2 |[cexp_] 20 epp2 |[clog_] 21 epp2 |[csin_] 22 epp2 |[ccos_] 23 epp2 |[csqrt_] 24 epp2 |[cxp2_] 25 epp2 |[tan_] 26 epp2 |[dtan_] 27 epp2 |[asin_] 28 epp2 |[dasin_] 29 epp2 |[acos_] 30 epp2 |[dacos_] 31 epp2 |[index_] 32 epp2 |[dtanh_] 33 epp2 |[sinh_] 34 epp2 |[dsinh_] 35 epp2 |[cosh_] 36 epp2 |[dcosh_] 37 epp2 |[abs_] 38 epp2 |[iabs_] 39 epp2 |[dabs_] 40 epp2 |[dim_] 41 epp2 |[idim_] 42 epp2 |[ddim_] 43 epp2 |[sign_] 44 epp2 |[isign_] 45 epp2 |[dsign_] 46 epp2 |[aint_] 47 epp2 |[aimag_] 48 epp2 |[conjg_] 49 epp2 |[len_] 50 epp2 |[dint_] 51 epp2 |[anint_] 52 epp2 |[dnint_] 53 epp2 |[nint_] 54 epp2 |[idnint_] 55 epp2 |[dprod_] 56 epp2 |[mod_] 57 epp2 |[amod_] 58 epp2 |[ilr_] 59 epp2 |[ils_] 60 epp2 |[irl_] 61 epp2 |[irs_] 62 " " Function: PL/I float hex (27) modulus: mod(x, y) " " Entry: EAQ = x " bp|0 -> y " X0 = offset in caller's text section of return point " " Exit: EAQ = if y=0 then x else x - floor(x/y)*y " hfp_mdfl1: fszn bp|0 return x if y = 0 tze hfp_mdfl1a fst sp|temp save x fdv bp|0 EAQ = x/y tmi 5,ic if EAQ >= 0 then: fmp P2.0H,du EAQ = 2*(x/y) fad =18b25,du EAQ = 2*floor(x/y) fmp M0.5H,du EAQ = -floor(x/y) tra 5,ic else: dfsb hfp_almost_one EAQ = -(abs(x/y) + almost_one) fmp M2.0H,du EAQ = 2*(abs(x/y) + almost_one) fad =18b25,du EAQ = 2*floor(abs(x/y) + almost_one) fmp P0.5H,du EAQ = -floor(x/y) fmp bp|0 EAQ = -floor(x/y)*y fad sp|temp EAQ = x - floor(x/y)*y tra sp|tbp,*x0 return hfp_mdfl1a: fcmp P0.0H,du set indicators properly tra sp|tbp,*x0 return " " Function: PL/I float hex (63) modulus: mod(x, y) " " Entry: EAQ = x " bp|0 -> y " X0 = offset in caller's text section of return point " " Exit: EAQ = if y=0 then x else x - floor(x/y) " hfp_mdfl2: dfst sp|temp save x dfld bp|0 load y tze hfp_mdfl2a return x if y = 0 dfdi bp|0 EAQ = x/y tmi 5,ic if EAQ >= 0 then: fmp P2.0H,du EAQ = 2*(x/y) fad =18b25,du EAQ = 2*floor(x/y) fmp M0.5H,du EAQ = -floor(x/y) tra 5,ic else: dfsb hfp_almost_one EAQ = -(abs(x/y) + almost_one) fmp M2.0H,du EAQ = 2*(abs(x/y) + almost_one) fad =18b25,du EAQ = 2*floor(abs(x/y) + almost_one) fmp P0.5H,du EAQ = -floor(x/y) dfmp bp|0 EAQ = -floor(x/y)*y hfp_mdfl2a: dfad sp|temp EAQ = if y=0 then x else x-floor(x/y)*y tra sp|tbp,*x0 return " " Function: round a float hex (71) number to fixed bin (71) " " Entry: EAQ = number " X0 = offset in caller's text section of return point " " Exit: AQ = nearest fixed bin (71) number " hfp_nearest_integer: tmi 5,ic if number +ve then: fad P0.5H,du EAQ = number + 0.5 fmp P2.0H,du EAQ = 2*(number + 0.5) ufa =18b25,du AQ = floor(number + 0.5) tra sp|tbp,*x0 return " else: fad M0.5H,du EAQ = -(abs(number) + 0.5) fmp M2.0H,du EAQ = 2*(abs(number) + 0.5) ufa =18b25,du AQ = floor(abs(number) + 0.5) negl 0 AQ = -floor(abs(number) + 0.5) tra sp|tbp,*x0 return " " Function: round off a float hex (71) number " " Entry: EAQ = number " X0 = offset in caller's text section of return point " " Exit: EAQ = nearest whole float hex (71) number " hfp_nearest_whole_number: tmi 6,ic if number +ve then: fad P0.5H,du EAQ = number + 0.5 fmp P2.0H,du EAQ = 2*(number + 0.5) fad =18b25,du EAQ = 2*floor(number + 0.5) fmp P0.5H,du EAQ = floor(number + 0.5) tra sp|tbp,*x0 return " else: fad M0.5H,du EAQ = -(abs(number) + 0.5) fmp M2.0H,du EAQ = 2*(abs(number) + 0.5) fad =18b25,du EAQ = 2*floor(abs(number) + 0.5) fmp M0.5H,du EAQ = -floor(abs(number) + 0.5) tra sp|tbp,*x0 return " " Function: convert a fixed bin (35) number to complex float hex (27) " " Entry: Q = number " X0 = offset in caller's text section of return point " " Exit: EAQ = complex float hex (27) result " hfp_rfb1_to_cflb1: lls 36 convert to fixed bin (71) first lrs 36 " " Function: convert from fixed bin (71) to complex float hex (27) " " Entry: AQ = number " X0 = offset in caller's text section of return point " " Exit: EAQ = complex float hex (27) result " hfp_rfb2_to_cflb1: lde =18b25,du EAQ = unnormalized 2*float(source) fad P0.0H,du EAQ = 2*float(source) fmp P0.5H,du EAQ = float(source) fst sp|temp lda sp|temp load real part ldq P0.0H,du load imaginary part tra sp|tbp,*x0 return " " Function: truncate a float hex (71) number " " Entry: EAQ = number " X0 = offset in caller's text section of return point " " Exit: EAQ = trunc (number) " hfp_trunc_fl: tmi 5,ic if number +ve then: fmp P2.0H,du EAQ = 2*number fad =18b25,du EAQ = 2*trunc(number) fmp P0.5H,du EAQ = trunc(number) tra sp|tbp,*x0 return " else: fmp M2.0H,du EAQ = 2*abs(number) fad =18b25,du EAQ = 2*trunc(abs(number)) fmp M0.5H,du EAQ = trunc(number) tra sp|tbp,*x0 return " " The following code is used by trace to gain control of PL/I and FORTRAN programs. " transfer_vector trace_ " " Function: enter Binary Floating Point (BFP) mode " " Entry: X0 = offset in caller's text section of return point " " Exit: PR0, (sp|stack_frame.operator_ptr) -> operator_table " trace_enter_BFP_mode: ldi 0,dl clear HFP mode if it's set epp0 trace_operator_table change to HFP trace operators spri0 sp|stack_frame.operator_ptr tra sp|tbp,*x0 " " Function: enter Hexadecimal Floating Point (HFP) mode " " Entry: X0 = offset in caller's text section of return point " " Exit: PR0, (sp|stack_frame.operator_ptr) = hfp_operator_table " " Note: It is not sufficient to just request HFP mode. We must " check that our request has been honoured, since if HFP " mode has not been enabled (or if it is not supported), a " request to enter HFP mode is simply ignored. If we find " that our request to enter HFP mode has not been honoured, " we attempt to enable HFP mode. If we are unsuccessful, " we signal the condition 'cannot_enable_HFP_mode'. If we " are restarted after signalling this condition, we repeat " all the above steps. " trace_enter_HFP_mode: ldi HFP_mask,dl request HFP mode fld P1.0H,du check if request honoured fad P0.0H,du sba =o020000,du tze trace_enter_HFP_mode.entered lda =o600000,du try to enable HFP mode tsx1 call_set_hexfp_control ldi HFP_mask,dl check if successful fld P1.0H,du fad P0.0H,du sba =o020000,du tze trace_enter_HFP_mode.entered ldi =0,dl clear HFP mode request eppbp =22acannot_enable_HFP_mode eax6 22 ldq =1000,dl tsx1 call_signal_ signal 'cannot_enable_HFP_mode' condition tra trace_enter_HFP_mode try again trace_enter_HFP_mode.entered: epp0 hfp_operator_table change to HFP trace operators spri0 sp|stack_frame.operator_ptr tra sp|tbp,*x0 " ext_entry trace_ " ext_entry_desc trace_ " ext_entry trace_,ss_ " ext_entry_desc trace_,ss_ " trace_entry_operators_end: " " The following code is used by trace to gain control of PL/I and FORTRAN " programs running in HFP mode. " transfer_vector trace_,hfp_ " " The ALM entry operator used by trace. " alm_trace_operators_begin: alm_entry_op trace_ alm_trace_operators_end: " " operator to update long_profile entry " Calling sequence: " " tsx0 ap|long_profile " zero header_relp,entry_offset " include long_profile " " NB: THIS OPERATOR IS NOT ALLOWED TO DESTROY ANY REGISTERS, " INCLUDING A, Q, index registers, pointer registers, " THE INDICATOR OR STRING REGISTERS. This is part of the " contract of long_profile not to affect the object " code. " " long_profile: sti sp|temp_indicators save indicators sreg sp|8 save registers get_stack_offset spri sp|stack_header.stack_end_ptr,au* " get_our_lp stcd sp|stack_frame.return_ptr callsp |[cpu_time_and_paging_op_] " staq sp|cpu save virtual cpu time stx0 sp|page save page faults sxl1 sp|page .. " ldx0 sp|8 restore x0 eppbp sp|tbp,*0 pt at arg word spbpbp sp|stack_frame.return_ptr restore return ptr epbpsb sp|0 sb = stack base " ldi =o004000,dl mask against overflow (vcpu faults at 19 hrs) epaq bp|0 get ptr to static section lprplb sb|stack_header.isot_ptr,*au ldx1 bp|0 get header relp epplb lb|0,1 point at long_profile_header lxl2 lb|long_profile_header.last_offset point at profile entry to be updated aos lb|long_profile_entry.count,2 update ldaq sp|cpu sblaq lb|long_profile_header.last_vcpu asq lb|long_profile_entry.vcpu,2 ldq sp|page sblq lb|long_profile_header.last_pf asq lb|long_profile_entry.pf,2 " ldaq sp|cpu set up for next time staq lb|long_profile_header.last_vcpu ldq sp|page stq lb|long_profile_header.last_pf lxl3 bp|0 sxl3 lb|long_profile_header.last_offset " lpri sb|stack_header.stack_end_ptr,* restore regs lreg sp|8 .. eax0 1,0 increment for return ldi sp|temp_indicators restore indicators tra sp|tbp,*0 return signal_error_missing: eppbp missing_error ldx6 missing_error_length,du tra signal_op missing_error: aci "missing_pl1_io_operator" equ missing_error_length,23 " " The following code performs an assembly-time cross-check of the consistency " of the operator_table region. The location referenced by operator_table itself " must be even...if it is not, the compiled code that references it will fail. " The following expression will divide-by-zero if operator_table is odd. " in PL/I: error1 = 1 / (1 - mod (operator_table - reloc_0, 2)); " equ optbl_abs,operator_table-begin_pl1_operators " kill off relocation equ error1,1/(1-(optbl_abs-2*(optbl_abs/2))) " ERROR 1: operator_table on ODD location. " end  power_.alm 11/11/89 1150.6rew 11/11/89 0804.2 34758 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Modified 24 June 1980 by C R Davis to fix bug in which |b| < 1.0 " causes overflow fault in power_integer_. " Modified 21 Dec 83 by HH to add HFP support. " evaluate a ** b in double precision " Note: the log routine uses index registers 0-4, so we must avoid using these " segdef integer_power_single_ segdef integer_power_double_ segdef single_power_single_ segdef single_power_double_ segdef double_power_single_ segdef double_power_double_ segdef hfp_integer_power_single_ segdef hfp_integer_power_double_ segdef hfp_single_power_single_ segdef hfp_single_power_double_ segdef hfp_double_power_single_ segdef hfp_double_power_double_ " equ return,-2 equ work_size,2 equ a,0 same as in power_integer_ " integer_power_single_: lda 0,dl float a lde =71b25,du fad =0.0,du " single_power_single_: double_power_single_: tsx5 common fmp 1|0 fld 1|0 fcmg 1|0 tsp3 |[double_log_base_e_] tra |[double_exponential_] " integer_power_double_: lda 0,dl float a lde =71b25,du fad =0.0,du " single_power_double_: double_power_double_: tsx5 common dfmp 1|0 dfld 1|0 dfcmg 1|0 tsp3 |[double_log_base_e_] tra |[double_exponential_] " hfp_integer_power_single_: lda 0,dl float Q lde =18b25,du fno fmp =0.5,du " hfp_single_power_single_: hfp_double_power_single_: tsx5 hfp_common fmp 1|0 fld 1|0 fcmg 1|0 tsp3 |[hfp_double_log_base_e_] tra |[hfp_double_exponential_] " hfp_integer_power_double_: lda 0,dl float Q lde =18b25,du fno fmp =0.5,du " hfp_single_power_double_: hfp_double_power_double_: tsx5 hfp_common dfmp 1|0 dfld 1|0 dfcmg 1|0 tsp3 |[hfp_double_log_base_e_] tra |[hfp_double_exponential_] " common: fcmp =0.0,du check a tze test skip if a = 0 dfst 2|a save a xec 1,5 load b tze spec skip if b = 0 fcmg 28*1024+256,du is b < 2**27 tpl begin no, skip fcmg =1.0,du is b > 1? tmi begin no, must use logs ufa =35b25,du get int(b) in a cmpq 0,dl is it an integer tnz begin no, use logs cmpa 0,dl set indicators from a tra |[power_integer_] " hfp_common: fcmp =0.0,du check a tze test skip if a = 0 dfst 2|a save a xec 1,5 load b tze spec skip if b = 0 fcmg =o016400,du is abs(b) < 2**27? tpl begin no, skip fcmg =-1.0,du is abs(b) >= 1? tmi begin no, must use logs ufa =9b25,du get int(b) in A lls 1 cmpq 0,dl is it an integer? tnz begin no, use logs cmpa 0,dl set indicators from A tra |[hfp_power_integer_] " begin: dfld 2|a not integer, restore a tmi err1 epp2 2|work_size reserve work space for ourselves spri3 2|return save our return xec 3,5 log(a) xec 0,5 b * log(a) epp3 2|return,* restore return pt xec 4,5 exp(b*log(a)) (exit through exp) " spec: fld =0.5,du fad =0.5,du tra 3|0 " test: fszn 1|0 special case when a = 0 tze err2 error if a = 0 & b = 0 tpl 3|0 0 ** positive is 0 ldq 18,dl err: tsx0 |[call_math_error_] fld =0.0,du tra 3|0 " err1: ldq 16,dl tsx0 |[call_math_error_] dfld 2|a evaluate for abs(a) fneg 0 tra begin+2 " err2: ldq 17,dl 0 ** 0 tra err end  power_integer_.alm 11/11/89 1150.6rew 11/11/89 0804.6 25299 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " evaluate a ** k for integer k " fld a (or dfld) " epp1 k " epp2 work " tsp3 entry " " Modified 770412 by PG to fix 1602 (overflow indicator not reset before rpt) " Modified 790904 by PES to fix fortran bug 231 (2**-127 takes overflow. " Modified 831221 by HH to work in both BFP and HFP modes. " segdef single_power_integer_ segdef double_power_integer_ segdef power_integer_ segdef hfp_single_power_integer_ segdef hfp_double_power_integer_ segdef hfp_power_integer_ " equ a,0 equ f,2 equ k,4 equ sign_k,5 " single_power_integer_: double_power_integer_: hfp_single_power_integer_: hfp_double_power_integer_: fcmp =0.0,du set indicators for a dfst 2|a tze test transfer if a = 0 lda 1|0 get k tze fequ1 f = 1.0 if k = 0 " " power_ comes here when exponent is found to be integral " if entered here, k is in the a register--the value of k " is NOT valid at 1|0, and the work area at 2| has been " set up. " power_integer_: hfp_power_integer_: sta 2|sign_k save k (not necessarily found at 1|0) tpl invert_a if k negative, invert a, get abs(k) fld =0.5,du fad =0.5,du dfdv 2|a if this over-/under-flows, would have anyhow dfst 2|a lca 2|sign_k this is abs(k) invert_a: cmpa 20,dl trc patha sba 1,dl tze pathd answer = a als 10 shift tally into position for rptx: C(X0)0,7 eax0 1,al set rptx to terminate on all overflows eax1 0 index 1 is a placeholder for RPT...make it zero dfld 2|a initialize C(EAQ) to a teo 1,ic clear exponent overflow indicator tov 1,ic clear overflow indicator rptx 0,0 repeat dfmp until overflow or tally runout dfmp 2|a,1 multiply C(EAQ) by a done: fad =0.0,du set indicators tra 3|0 " patha: sta 2|k fld =0.5,du fad =0.5,du dfst 2|f pathc: lda 2|k cana 1,dl is k even tze even dfld 2|a dfmp 2|f dfst 2|f even: lda 2|k arl 1 k = k / 2 tze pathb sta 2|k dfld 2|a dfmp 2|a dfst 2|a a = a * a tra pathc pathb: dfld 2|f tra done pathd: dfld 2|a tra done " fequ1: fld =0.5,du fad =0.5,du tra 3|0 " test: szn 1|0 special case if a = 0 tze err1 tpl 3|0 0 ** k = 0 ldq 4,dl 0 ** 0 err: tsx0 |[call_math_error_] fld =0.0,du tra 3|0 " err1: ldq 3,dl tra err " end  principal_angle_.alm 11/11/89 1150.6rew 11/11/89 0805.6 57564 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** name principal_angle_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985. " " Function: Scale an angle into the range -pi/4 to pi/4. " " Entry: through the appropriately named entry point with: " EAQ = input angle to be scaled. " X0 = the return address. " X2 = a two word HFP offset. This register is by all of the " floating point math routines for the same purpose. " PR2 = points to an even word aligned, 12 word long, scratch area. " " Exit: EAQ = the scaled angle. " X1 = mod ((input EAQ)/HALF_PI + 0.5), 4) " " Uses: X1 " X1 = used to return mod ((input EAQ)/HALF_PI + 0.5), 4) segdef principal_degrees_,principal_radians_ segref math_constants_,almost_one bool P2.0H,002100 " yields HFP +2.0 under 'du' modification bool P45.0H,004132 " yields HFP +45.0 under 'du' modification equ angle,0 equ temp,angle equ n1,2 equ n2,3 equ t1,4 equ t2,6 equ t3,8 equ t4,10 equ HFP,2 principal_degrees_: cmpx2 HFP,du tze hfp_principal_degrees bfp_principal_degrees: frd 0 fcmg two_pwr_54 " is the EAQ too large tpnz angle_too_big " Yup. fst pr2|angle dfdv ninety " EAQ = EAQ/90 fad =0.5,du " EAQ = EAQ/90 + 0.5 dufa almost_one dufs almost_one ufa =71b25,du " AQ = EAQ/90 + 0.5 in integer form eax1 0,ql anx1 3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/90 + 0.5) in floating point form fmp =90.0,du " EAQ = floor(EAQ/90 + 0.5)*90 fneg 0 " EAQ = -floor(EAQ/90 + 0.5)*90 fad pr2|angle " EAQ = angle-floor(EAQ/90 + 0.5)*90 tra 0,x0 " return to caller hfp_principal_degrees: frd 0 fcmg hfp_two_pwr_48 " is the EAQ too large tpl angle_too_big " Yup. fst pr2|angle dfdv hfp_ninety " EAQ = EAQ/90 fad =0.5,du " EAQ = EAQ/90 + 0.5 dufa almost_one dufs almost_one ufm P2.0H,du ufa =18b25,du " AQ = EAQ/90 + 0.5 in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/90 + 0.5)*2 fmp P45.0H,du " EAQ = floor(EAQ/90 + 0.5)*90 in floating point form fneg 0 " EAQ = -floor(EAQ/90 + 0.5)*90 fad pr2|angle " EAQ = angle-floor(EAQ/90 + 0.5)*90 tra 0,x0 " return to caller principal_radians_: cmpx2 HFP,du tze hfp_principal_radians bfp_principal_radians: frd 0 fst pr2|angle fcmg two_pwr_27 " is the EAQ too large tpnz bfp_big_angle " Yup. dfmp one_over_half_pi " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufa =71b25,du " AQ = EAQ/half_pi + 0.5 in integer form eax1 0,ql anx1 3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ tra small_angle_join hfp_principal_radians: frd 0 fst pr2|angle fcmg hfp_two_pwr_24 " is the EAQ too large tpnz hfp_big_angle " Yup. dfmp one_over_half_pi,x2 " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufm P2.0H,du ufa =18b25,du " AQ = EAQ/half_pi + 0.5 in integer form in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du fmp =0.5,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ small_angle_join: fmp half_pi1,x2 dfst pr2|t1 " t1 = n1*half_pi1 fld pr2|n1 fmp half_pi2,x2 dfst pr2|t2 " t2 = n1*half_pi2 fld pr2|n1 fmp half_pi3,x2 dfst pr2|t3 " t3 = n1*half_pi3 fld pr2|angle " answer = angle - t1 - t2 - t3 dfsb pr2|t1 dfsb pr2|t2 dfsb pr2|t3 tra 0,x0 hfp_big_angle: fcmg hfp_two_pwr_48 " is the EAQ too large? tpnz angle_too_big " Yup. dfmp one_over_half_pi,x2 " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufm P2.0H,du ufa =18b25,du " AQ = EAQ/half_pi + 0.5 in integer form in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/half_pi + 0.5)*2 fmp =0.5,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ tra big_angle_join bfp_big_angle: fcmg two_pwr_54 " is the EAQ too large? tpnz angle_too_big " Yup. dfmp one_over_half_pi " EAQ = EAQ/half_pi fad =0.5,du " EAQ = EAQ/half_pi + 0.5 dufa almost_one dufs almost_one ufa =71b25,du " AQ = EAQ/half_pi + 0.5 in integer form eax1 0,ql anx1 =3,du " X1 = mod(AQ,4) fad =0.0,du " EAQ = floor(EAQ/half_pi + 0.5) in floating point form fst pr2|n1 " n1 = EAQ big_angle_join: fsb pr2|n1 fst pr2|n2 " n2 = n - n1 fld pr2|n1 fmp half_pi1,x2 dfst pr2|t1 " t1 = n1*half_pi1 fld pr2|n1 " calculate n1*half_pi2 + n2*half_pi1 fmp half_pi2,x2 dfst pr2|t2 fld pr2|n2 fmp half_pi1,x2 dfad pr2|t2 dfst pr2|t2 " t2 = (n1*half_pi2 + n2*half_pi1) fld pr2|n1 " calculate n1*half_pi3 + n2*half_pi2 fmp half_pi3,x2 dfst pr2|t3 fld pr2|n2 fmp half_pi2,x2 dfad pr2|t3 dfst pr2|t3 " t3 = (n1*half_pi3 + n2*half_pi2) fld pr2|n1 " calculate n1*half_pi4 + n2*half_pi3 fmp half_pi4,x2 dfst pr2|t4 fld pr2|n2 fmp half_pi3,x2 dfad pr2|t4 dfst pr2|t4 " t4 = (n1*half_pi4 + n2*half_pi3) fld pr2|angle " answer = angle - t1 - t2 - t3 dfsb pr2|t1 dfsb pr2|t2 dfsb pr2|t3 dfsb pr2|t4 tra 0,x0 " return to caller angle_too_big: ldq code,x2 " pick the appropriate error message stx0 pr2|temp " save X0 tsx0 |[call_math_error_] ldx0 pr2|temp " restore X0 eax1 0 " X1 = 0 fld =0.0,du " EAQ = 0, set indicators tra 0,x0 " return to caller " Constants: even ninety: dec 90.0d0 hfp_ninety: oct 004264000000,000000000000 one_over_half_pi: dec 6.3661977236758134307553d-1 oct 000505746033,344710405225 hfp_two_pwr_24: oct 016040000000,000000000000 two_pwr_27: oct 070400000000,000000000000 hfp_two_pwr_48: oct 032040000000,000000000000 two_pwr_54: oct 156400000000,000000000000 half_pi1: oct 002622077325,000000000000 oct 002062207732,000000000000 half_pi2: oct 706420550604,000000000000 oct 766050420550,000000000000 half_pi3: oct 616646114314,000000000000 oct 752060432304,000000000000 half_pi4: oct 526505600670,000000000000 oct 736061461213,000000000000 code: dec 70,0,71 end  put_field_.alm 11/11/89 1150.6rew 11/11/89 0804.6 217872 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(88-04-06,Huen), approve(88-04-06,MCR7871), " audit(88-04-19,RWaters), install(88-04-26,MR12.2-1043): " Fix PL/1 bug 2140 and 2152. " END HISTORY COMMENTS " " Operators for QUICK STREAM I/O " " Modified: 03/01/78 by RAB to fix 1712 " Modified: 04/04/78 by RAB to fix 1721 " Modified: 02/16/84 by MBW to fix probe 13 / TR14172 " Modified: 04/06/88 by SH to fix 2140 and 2152 " " " Written during 1975 by R.Schoeman to reimplement pl1 stream output in the " operators to improve performance. " name put_field_ include stack_header include plio2_fsb include plio2_ps include stack_frame include iocbx equ tbp,38 equ ps_ptr,42 equ total_len,44 equ t6,45 equ x7_stored,46 upper half of word in storage equ source_str_offset,46 lower half of word equ t2,47 equ ctrl_ret_loc,47 equ output_request_type,48 0 - edit, 1 - list, other - control requests " that abort on endpage equ storage_taken,49 known and set as extend_size in alloc equ double_temp,52 equ orig_len,52 yes this conflicts with double_temp, but I'm short of space equ io_arg_list,54 equ temp,62 segdef restore_regs_and_frame_and_ret segdef put_control_from_format segdef any_qs_error_no_ret segdef set_no_ret_error segdef put_field segdef put_field_str segdef put_field_chk segdef put_field_from_format segdef put_control " operator to put out a string, entered via put_list_eis with the " descriptor of the output item in sp|temp as well as in the q " put_field_str: eppap sp|ps_ptr,* sta ap|ps.a_stored we can't clobber most regs stx7 sp|x7_stored lda sp|temp temp has the desc, put there by put_list_eis sta ap|ps.q_stored since the desc was in the q on entry to put_list_eis sta ap|ps.descr canq =o004000,du tze var_str var_str handles both char & bit varying strs ana =o000077777777 change descr into length, blocking out type cmpq =o114000,du tze bit_str tra char_str var_str: lda bp|-1 length word is adr(str) -1 cmpq =o120000,du bit str? tnz char_str bit_str: ada 3,dl add three to length, for leading&trailing quotes & "b" sta sp|total_len this will be the final length output ldq sp|total_len tsx6 get_newbuf we must get a buffer big enough for len(bit_str)+3 chars mlr (),(pr),fill(042) 042 is ascii quote zero 0 only interested in fill char desc9a bp|0,1 pr2 is where to shove it lda sp|total_len at this point bp->final char string and pr3->source bit str sba 3,dl this is how many bits need conversion to "1" or "0" bit_loop: sba 1,dl loop through all bits converting them to char "1" or "0" tmi bit_loop_done cmpb (pr,al),() descb pr3|0,1 zero 0 remember, pr3 is pointing to the original bit str tze bit_is_zero mlr (),(pr,al),fill(061) move in a "1" (061), since the bit is "on" zero 0 desc9a pr2|0(1),1 target is pr2 up on char since there is a quote in position 1 tra bit_loop bit_is_zero: mlr (),(pr,al),fill(060) (060) is an ascii "0" zero 0 desc9a pr2|0(1),1 tra bit_loop bit_loop_done: lda sp|total_len now to insert trailing quote sba 2,dl trailing quote will be the second to last char mlr (0),(pr,al),fill(142) 142 is ascii "b" desc9a quote_char,1 desc9a bp|0,2 pr2 is where to shove it ldq sp|total_len conversion to final form is done, put len in q & off we go tra put_field_from_str pr2->char string to put out, q has len, we're set up for put_field " " char_str: epp4 ap|ps.fsbp,* we have to ask the fsb if its a print file ldq pr4|fsb.switch cause if not, we must double quotes and enclose canq fsb.print,du the string in quotes. If it is a print file, tze not_print a vanilla put_field will do. lrs 36 length is in a, move it to q for put_field stz sp|storage_taken set sortage_taken tra put_field_from_print and off we go not_print: sta sp|orig_len we must know orig len to know when we're finished sta sp|total_len lrs 35 get 2*total_len in the q adq 2,dl output string, which would be all quotes. Each quote would tsx6 get_newbuf be doubled and a quote on each end: total_len=2*orig_len+2 epp7 pr2|0 now pr2->new buffer and pr3->source string(a side effect of get_newbuf) mlr (0),(pr),fill(042) 042 is ascii quote, put in the leading one zero 0 only interested in fill char desc9a bp|0,1 pr2 is where to shove it aos sp|total_len and update the true total len ldq sp|orig_len " copy_more: scm (pr,rl),() scan to find the first quote in source str desc9a pr3|0,ql string to scan(source) desc9a quote_char,1 what to scan for arg sp|temp place to put offset of first quote ttn 2,ic tally on if string has no more quotes aos sp|temp add one cause we want to move the original quote also lda sp|temp now temp is up to and including any quote found aos sp|total_len this one will be for the new doubled quote or trailing quote if none foundd " mlr (pr,rl),(pr,rl) move up to and including quote desc9a pr3|0,al pr3->source string desc9a bp|0(1),al pr2->target string, up 1 char for leading quote a9bd bp|0,al update pr2 to reflect new contents a9bd pr3|0,al update pr3 to point to as-yet unmoved string mlr (0),(pr),fill(042) insert quote at pr2|(1) cause pr2's always a byte behind zero 0 only interested in fill char desc9a bp|0(1),1 pr2 is where to shove it ttn move_is_over tally still set on if no quote was found " lda 1,dl a9bd bp|0,al update target to reflect new quote just doubled sbq sp|temp length of string left to scan is decreased tra copy_more " move_is_over: ldq sp|total_len put_field expects length in q, pr2 must be reset to start of string epp2 pr7|0 reset pr2 to start of string tra put_field_from_str and off " " get_newbuf: epp3 bp|0 we set pr3 to where pr2 was, and set pr2 to the new buffer tsx1 |[alloc] length of new buffer in bytes is in the a tra 0,6 and return " " operator for put_field_chk " entered with pointer to datum in bp,offset to check for minus sign " in x6, length in q " put_field_chk: cmpc (),(pr,x6) check that offset x6 is not "-" desc9a minus_sign,1 desc9a bp|0,1 tnz check_okay if its a "-",e_format too small for value eppap sp|ps_ptr,* sta ap|ps.a_stored stx7 sp|x7_stored eppap sp|ps_ptr spriap sp|io_arg_list+2 fld 1*2048,dl staq sp|io_arg_list eppap sp|tbp,*0 get ptr to inst that invoked op spriap sp|stack_frame.return_ptr reset return ptr so stack_frame_exit_ " will know where we came from eppap sp|io_arg_list tsx1 |[get_our_lp] callsp |[pve_error] check_okay: eax1 1 this reg. needed for next instructtion a9bd bp|0,1 get rid of extra "check" character " " operator for put_field and continuation fo put_field_chk operator " entered withpointer to datum in bp,length of output string in q " " " put_field: eppap sp|ps_ptr,* stq ap|ps.q_stored we can't clobber q,a,x7, which we use, so save for restoration sta ap|ps.a_stored stx7 sp|x7_stored stz sp|storage_taken BUGFIX, format and print set it put_field_from_format: eppap sp|ps_ptr,* put_field_from_print: stq sp|total_len total_len will be length of string to be put put_field_from_str: spribp ap|ps.value_p epp4 ap|ps.fsbp,* pr4 will point to fsb epp3 pr4|fsb.bptr,* stz sp|output_request_type output_request_type =0 means edit_dir_out eax6 0 sxl6 sp|source_str_offset source_str_offset is offset within string for putting to start cmpq 260,dl we'll allow max string len of 260, cause bit strs add three to 256 tmoz 3,ic at this point q must have sp|total_len in it!!! lda 8,dl tra any_qs_error_no_ret lda ap|ps.job cana ps.list,du tze reput aos sp|output_request_type output_request_type =1 means list_dir_out lda pr4|fsb.switch fsb_switch is at beginning of fsb cana fsb.print,du print_switch is bit five of fsb_switch tze check_line if not print, just check if there's space enough left on the line ldq pr4|fsb.kol if it is print, might need leading tab div 10,dl are we on a tab boundary? cmpa 0,dl tze check_line if so, no tab needed mpy 10,dl is there room enough left on line? adq 10,dl BUGFIX, next column position is 10 characters over cmpq pr4|fsb.lsize tpnz line_and_chk_print if not, needs new_line stq sp|t2 t2 is where the new column position will be after tab lda tab_char a is what char should be inserted by insert_char sub-routine tsx6 insert_char and insert the tab lda sp|t2 set the column position sta pr4|fsb.kol tsx7 set_fsb_limit since the tab messes up the old limit " check_line: lda pr4|fsb.lsize is there room enough on line for output item? sba pr4|fsb.kol cmpa sp|total_len tpl reput if there is, no more preliminaries neded, just put it out " " now check for the unique case where although the line is not big enough, we do not " insert a newline because we are already at the 1st columnposition. " ldq pr4|fsb.kol tze reput " line_and_chk_print: tsx6 insert_new_line if not insert a new_line. This subroutine takes care of kol & pagesize,too reput: ldq sp|total_len adq pr4|fsb.bnc q+bnc is buffer_next_char after this io operation adq sp|output_request_type output_request_type is one iff ldo, this gives trailing blank sbq 1,dl to get buf pos reached, not next free one cmpq pr4|fsb.limit future bnc>limit? tpnz overlimit if so, goto overlimit lda pr4|fsb.bnc get bnc for offset for mlr adq 1,dl stq pr4|fsb.bnc store future bnc into bnc sba 1,dl offset is bnc minus 1 ldq sp|total_len adq sp|output_request_type this restores q to "length to be put" lxl7 sp|total_len x7 will be length to be taken from source str asq pr4|fsb.kol set proper column lxl6 sp|source_str_offset offset of source string mlr (pr,rl,x6),(pr,rl,al),fill(040) 040=ascii blank,q might=x7+1,where we want trail blank desc9a bp|0,x7 pr2 is source string to move desc9a pr3|0,ql pr3 is target string,i.e. fsb's buffer restore_regs_and_frame_and_ret: lcq sp|storage_taken q is how much to collapse stack tze reset_regs_and_return if zero, we didn't extend it and can return epbp3 sp|0 else collapse it the amount we extended it asq sp|stack_frame.next_sp+1 asq pr3|stack_header.stack_end_ptr+1 reset_regs_and_return: eppap sp|ps_ptr,* ldq ap|ps.q_stored we changed the a,q, and x7 & were't allowed to clobber them, so restore lda ap|ps.a_stored ldx7 sp|x7_stored tra |[put_return] and were finished " getting here means the requested job would violate the limit on overlimit: ldq pr4|fsb.bnc the last permissable char position in the fsb.buffer, so sbq 1,dl either bsize or lsize was exceeded. First task is to figure out how much stq sp|t2 of the output request falls before the limit, and move those chars. lxl6 sp|source_str_offset t2 now =bnc-1 lda pr4|fsb.limit amount pre-limit will =limit-bnc-1, so subtract t2 from limit ssa sp|t2 lda sp|t2 a is now number of chars before the limit asa pr4|fsb.kol update column index, bnc, and source offset asa pr4|fsb.bnc asa sp|source_str_offset mlr (pr,rl,x6),(pr,rl,ql) move from pr2 up source offset to fsb.buffer up bnc-1 desc9a bp|0,al length to be moved is limit-bnc-1 desc9a pr3|0,al which is in a " ldq pr4|fsb.limit compare limit against bsize to see if bsize was violated cmpq pr4|fsb.bsize remember that limit represents a character position in the buffer tpl overbuffer go to overbuffer if buffer is full tsx6 insert_new_line otherwise it must be linesize we exceeded overmerge: ldq sp|total_len we get here after handling the limiting condition sbq sp|t2 so figure out how much we must still put out stq sp|total_len t2 is the amount we put out, so total_len-t2 is the amount left to put tra reput and put it out overbuffer: tsx1 call_putchars if buffer is full, we must put it out tra overmerge now the limiting condition is resolved, and we can continue " " subroutine to empty the guarenteed-full fsb.buffer into the output stream call_putchars: lda ap|ps.job check if its string-option cana ps.string,du tnz string_option_overflow if it is, this is an error lprp5 pr4|fsb.iocb_p now set up arg list for iox spri5 sp|double_temp epp3 sp|double_temp spri3 sp|io_arg_list+2 epp3 pr4|fsb.bptr spri3 sp|io_arg_list+4 epp3 pr4|fsb.bsize spri3 sp|io_arg_list+6 epp3 pr4|fsb.lnzc fsb.lnzc will be status code spri3 sp|io_arg_list+8 sreg sp|8 fld 4*2048,dl staq sp|io_arg_list eppap sp|io_arg_list stcd sp|stack_frame.return_ptr callsp pr5|iocb.put_chars,* lreg sp|8 eppap sp|ps_ptr,* restore ptrs epp4 ap|ps.fsbp,* epp3 pr4|fsb.bptr,* eppbp ap|ps.value_p,* stz pr4|fsb.bnc next_char must be 1, since we emptied buf aos pr4|fsb.bnc lda pr4|fsb.lnzc status code tnz put_char_error tsx7 set_fsb_limit tra 0,1 " string_option_overflow: lda 7,dl quick_condition_code tra any_qs_error_no_ret " set_no_ret_error: lda 13,dl " any_qs_error_no_ret: eax6 set_no_ret_error stz sp|output_request_type tra any_qs_error " put_char_error: lda 0,dl eax6 reset_regs_and_return x6 points to where to go on return from on-unit " label for raising a condition, reached with a code in reg a. " code = 0 :: error in xmitting " code = 1 :: endpage cond " code = 2 :: not a print file when must be " code = 3 :: line(n), n<= 0. " code = 4 :: control format with value <0, err437 " code = 5 :: skip(0) requested on non-print file " code = 6 :: infinite num. of new-lines to fill page, err433 " code = 7 :: "buffer" overflow on string-option put, err420 " code = 8 :: string length over 260, err 242 " code = 9 :: put_format_ (pfo) , line(0) requested, err 262 " code = 10:: pfo, no param where needed, err 148 " code = 11:: pfo, stu_ returned non-zero code, err 195 " code = 12:: pfo, nesting depth for r_formats exceeded, = 10, err 197 " code = 13:: attempt to restart after an ERROR or SIZE condition, err 266->OM 466 any_qs_error: sta sp|t6 spri2 sp|io_arg_list+6 not an argument but must be saved/restored epp5 sp|ps_ptr spri5 sp|io_arg_list+2 epp5 sp|t6 t6 is condition code spri5 sp|io_arg_list+4 sreg sp|8 tsx1 |[get_our_lp] fld 2*2048,dl staq sp|io_arg_list eppap sp|io_arg_list stcd sp|stack_frame.return_ptr callsp |[quick_condition] lreg sp|8 eppap sp|tbp,*0 spriap sp|stack_frame.return_ptr eppap sp|ps_ptr,* epp4 ap|ps.fsbp,* epp3 pr4|fsb.bptr,* epp2 sp|io_arg_list+6,* lda sp|output_request_type cmpa 2,dl tmi 0,6 if output_request_type<2, must be list/edit, not control tra ret_from_control if output_request_type=>2,must be a control so finish here " " subroutine to set the fsb.limit=min(len_left_on_line,len_left_in_buffer) set_fsb_limit: lda pr4|fsb.lsize sba pr4|fsb.kol ada pr4|fsb.bnc sba 1,dl a is now the pos in buffer of last char on present line cmpa pr4|fsb.bsize compare to pos in buffer of last char in buffer tnc 2,ic lda pr4|fsb.bsize sta pr4|fsb.limit set limit to the greater of the two tra 0,7 and return " insert_new_line: lda pr4|fsb.bnc sba 1,dl cmpa pr4|fsb.bsize check if there's room in the buffer for this char tmi 3,ic if there is, no problem tsx1 call_putchars if there isn't , put out the guaranteed-full buffer lda 0,dl reset a to the buffer offset to put the char mlr (pr),(pr,al),fill(012) move the new_line zero 0 desc9a pr3|0,1 aos pr4|fsb.bnc update the buffer index stz pr4|fsb.kol now set column to 0 lda =o777777777757 zero out bit32, "emptyline" ansa pr4|fsb.switch can't be emptyline any longer aos pr4|fsb.lineno increment lineno tsx7 set_fsb_limit since we reset kol must recalculate the limit lda pr4|fsb.psize now we must check for possible pagesize violation tze 0,6 psize=0 means non-print file, so no ENDPAGE ada 1,dl cmpa pr4|fsb.lineno is lineno = pagesize + 1? tnz 0,6 if it is not, return raise_endpage: lda 1,dl this is the code fora pagesize error tra any_qs_error and raise the error " " beginning of insert_char subroutine " insert_char: sta sp|t6 a has the char to be inserted lda pr4|fsb.bnc sba 1,dl cmpa pr4|fsb.bsize check if there's room in the buffer for this char tmi 3,ic if there is, no problem tsx1 call_putchars if there isn't , put out the guaranteed-full buffer lda 0,dl reset a to the buffer offset to put the char mlr (pr),(pr,al) move the char desc9a sp|t6,1 we squirreled it away in t6 desc9a pr3|0,1 aos pr4|fsb.bnc update the buffer index tra 0,6 " " end of insert_char subroutine " " operator for put_control " entered with type of control index in x6, " number of times to do that control (or target for the control) in q " put_control: eppap sp|ps_ptr,* epp1 reset_regs_and_return pr1 will be where to go after we're done stq ap|ps.q_stored save the regs we can't clobber sta ap|ps.a_stored stx7 sp|x7_stored put_control_from_format: sprp1 sp|ctrl_ret_loc call_putchars will clobber pr1, so save it here eppap sp|ps_ptr,* pr1 has been set by put_format epp4 ap|ps.fsbp,* epp3 pr4|fsb.bptr,* stc1 sp|output_request_type this "I am a control" flag is for endpage " processing -- endpage aborts processing of " most controls cmpx6 3,du 3=page request, which has no value in q tze check_print_file so just check if its print file and go on from there cmpq 0,dl otherwise see if count is >= 0 tpl 3,ic no control is allowed a negative count lda 4,dl this is the error code for negative control count tra any_qs_error and raise the error " cmpx6 1,du 1 is code for skip request tnz check_x_format if not, try next test " cmpq 0,dl skip is allowed a 0 count in the request tnz skip_more but only if it is a print file lda pr4|fsb.switch so test to see if print-file bit is on cana fsb.print,du tnz 3,ic if it is, were safe lda 5,dl if not, set error code tra any_qs_error and raise the error lda carr_rtn_char skip(0) means give a carriage return but no line-feed tsx6 insert_char so insert the carr-return stz pr4|fsb.kol kol is now 0 set_fsb_and_ret: tsx7 set_fsb_limit we have to set the limit since control chars usually change it ret_from_control: lprp1 sp|ctrl_ret_loc tra pr1|0 and return,pr1 having been set on or prior to entry to put_control skip_more: tsx6 insert_new_line non-zero skip count, so insert a new_line sbq 1,dl reset count, is it still > 0? tmoz ret_from_control if not, return, limit was set by insert_new_line tra skip_more count was not zero,so repeat " check_x_format: cmpx6 5,du 5 is request code for x_format,i.e. blank spaces tnz check_q_gt_zero x and skip formats are the only ones which allow a zero count " stz sp|output_request_type endpage does not abort x format put_q_blanks: adq pr4|fsb.bnc now put q blanks out sbq 1,dl to get buffer position reached after operation, not next one cmpq pr4|fsb.limit see if we can move all the blanks in one move without violating the limit tmoz easy_blanks if we can, we save time & work sbq pr4|fsb.bnc restore q to original value with this subtraction adq 1,dl compensate for earlier subtraction of 1 (fixes 1721) " now we put out the blanks one by one repeat_blank: cmpq 0,dl more to put out? tze ret_from_control if not, return. Blanks don't require resetting fsb.limit. lda pr4|fsb.kol first check if there's room for a char on this line cmpa pr4|fsb.lsize tmi 2,ic if kol=lsize, insert a new_line lda pr4|fsb.bnc sba 1,dl cmpa pr4|fsb.bsize tmi 3,ic tsx1 call_putchars lda 0,dl mlr (pr),(pr,al),fill(040) zero 0 desc9a pr3|0,1 aos pr4|fsb.bnc aos pr4|fsb.kol we know we inserted a single char sbq 1,dl decrement count by one tra repeat_blank and repeat " " this means we dont have to watch out for the limit easy_blanks: sbq pr4|fsb.bnc restore q to its original value,i.e. the number of blanks to be put adq 1,dl we subtracted one before,so add 1 now lxl6 pr4|fsb.bnc set up regs for the mlr sbx6 1,du mlr (),(pr,rl,x6),fill(040) 040 is ascii blank zero 0 desc9a pr3|0,ql asq pr4|fsb.bnc correct indexes asq pr4|fsb.kol tra ret_from_control and return " check_q_gt_zero: cmpq 0,dl the rest of the controls forbid a zero count tnz check_column if q=0 error unless col format cmpx6 2,du is it col(0)? tze column_zero make it col(1),effectively lda 9,dl the error code is 9 tra any_qs_error and raise the error " " now check for column, then page, format check_column: cmpx6 2,du request code=2 means column format tnz check_print_file page is only allowed for a print file " stz sp|output_request_type endpage does not abort column format cmpq pr4|fsb.kol is the requested column less than the present one? tmoz pre_column if it is, we must produce a new-line first cmpq pr4|fsb.lsize is the column <= than the line size? tmoz within_line if so,we're ok tsx6 insert_new_line else insert a new-line first tra ret_from_control we needn't set fsb.limit cause insert_new_line does " column_zero: tsx6 insert_new_line tra ret_from_control and were done " our task now is to put out enough blanks to reach the desired column within_line: sbq pr4|fsb.kol how many more blanks needed? tra pre_column+1 and put them out pre_column: tsx6 insert_new_line the rules say start with a new_line sbq 1,dl since if we want kol 5 we need only 4 blanks to get there tra put_q_blanks and put out the blanks " check_print_file: lda pr4|fsb.switch cana fsb.print,du tnz 3,ic lda 2,dl the page & line requests require a print file, if not, it is error code 2 tra any_qs_error and raise the error cmpx6 3,du page request? tnz must_be_line as the man says, if not it must be line " new_page: lda pr4|fsb.lineno in most cases pagemark must be preceeded by a newline cmpa pr4|fsb.psize unless lineno>psize & kol=0 & ^emptyline tmoz new_page_and_line lda pr4|fsb.kol tnz new_page_and_line lda fsb.emptyline,dl cana pr4|fsb.switch tze just_page " new_page_and_line: tsx6 insert_new_line just_page: lda pagemark_char tsx6 insert_char stz pr4|fsb.kol a pagemark resets the kol to 0 ldq 1,dl and sets lineno to one stq pr4|fsb.lineno aos pr4|fsb.pageno tra set_fsb_and_ret since kol was reset, fsb.limit must be " must_be_line: cmpq pr4|fsb.psize is the requested lineno>pagesize? tmoz not_overp iif not, go to not_overp " page_time: lda pr4|fsb.lineno if lineno is already>pagesize, just insert a new pagemark and return cmpa pr4|fsb.psize tpnz new_page fill_pg_and_raise_ep: tsx1 |[get_our_lp] else we must fill the page with new_lines. which we don't ldq |[max_page_size] want to do if pagesize=max_page_size,i.e. is virtually infinite epp4 ap|ps.fsbp,* but would rather print a message in that case cmpq pr4|fsb.psize tnz 3,ic is pagesize=max_page_size? lda 6,dl if so, error code=6 tra any_qs_error and raise the error ldq pr4|fsb.lineno otherwise, proceed to fill the page with new_lines fill_more: tsx6 insert_new_line adq 1,dl cmpq pr4|fsb.psize tpnz raise_endpage tra fill_more " not_overp: cmpq pr4|fsb.lineno if the requested lineno is present lineno, just skip the right number of lines tra skip_more q_equ_lineno: lda pr4|fsb.kol if kol is zero, we're where we want to be tze ret_from_control tra page_time else we need to go to the next page b_char: oct 142000000000 quote_char: oct 042000000000 blank_char: oct 040000000000 pagemark_char: oct 014000000000 minus_sign: oct 055000000000 new_line: oct 012000000000 tab_char: oct 011000000000 carr_rtn_char: oct 015000000000 end  put_format_.alm 11/11/89 1150.6r w 11/11/89 0805.6 486693 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Operator for doing format-driven conversions " " Written by R.Schoeman 1975-6 to implement operators to do put-edit " requests in the operators, for improved performance. " " Modified Oct 1976 by R.H.Schoeman to put in radix factor constants " Modified Mar 29, 1978 by R.A.Barnes to fix bug 1719 " Modified August 14, 1978 by PCK to fix bug 1745 " Modified September 1, 1978 by RAB to fix bug 1781 " include stack_frame include stack_header include eis_bits " " The following include file describes a region of storage which is used " exclusively by put_format_, for internal manipulation. It's primary " purpose is to hold the evaluated fields of the format constants " produced by the compiler(evaluated by stu_), but is also used " for most other storage needed by the format list processing " and format conversions. The program plio2_fl_ uses the same storage region, " there called sb, similiarly but not identically. plio_sb is 136 words long, " and was provided by the compiled code, and the ptr to it was placed in the ps, at " ps.format_area_p. " include plio_sb " " The following include file describes the format constants produced " by the compiler. A format con contain from zero (as in a put edit(foo)(a) statement) " to three values (as in put edit(foo)(e(11,5,2))), hence 3 value fields " are provided along with nval, to show how many are used. offset is the " relative offset to the next format constant. " include plio_fb include pic_image include plio2_ps include plio_format_codes include desc_types equ new_stack_size,48 equ max_dec_precision,59 this is system defined constant equ w_temp,47 this temp is field width for e_format maniputlation equ radix_fac_bits,47 this temp used in bn_format to hold bits to be index in hex_table equ nval_temp,44 equ radix_factor,44 equ d_temp,54 num of decimal places for e_formats equ k_temp,48 equ extra_bits,48 equ sd_temp,48 equ storage_taken,49 equ double_temp,52 equ temp,62 equ ps_ptr,42 equ source_val_type,44 equ source_val_scaleprec,45 equ b_temp,45 equ x7_stored,46 upper half of word only equ int_val_type,54 equ int_val_scaleprec,47 " qs_arg_list will clobber many variables if ever used from " pr6|, and it NEVER should be. It is to be used within the " region allocated as temporary workspace. equ qs_arg_list,48 equ tbp,38 segdef put_edit_eis segdef get_edit_eis segdef put_terminate segdef stream_prep formats_mask: oct 000000000017 " " operator to prepare for an I/O operator (stream) " " stream_prep is executed once per put request, and as such should not " be confused with "get_prep" " stream_prep sets several fields in the ps, which " is the storage block associated with an io request, including "ps.prep", " which when non-zero tells get_or put_ prep to do other preparatory functions. " stream_prep: eppap sp|ps_ptr,* get ptr to ps spribp ap|ps.abret save label sprisp ap|ps.abret+2 sta ap|ps.job set job to do stc1 ap|ps.prep set prep switch non-zero eax6 10 assume this is get prep cana =o002000,du check for put bit tze |[plio4] go make call to get_prep_ if bit off eax6 11 this means its a put_prep call tra |[plio4] and away we go " " operator for get edit entered with ptr to datum in bp, " offset in x7, descriptor in q " get_edit_eis: " epp4 sp|ps_ptr,* pr4 will point to ps throughout " sxl7 sp|ps.offset " tra put_and_get_merge " " Operator to do put edits, entered with descriptor in q and pointer to value " in the bp, and the offset, for pictures, in the a. " " The first section of code, up to the transfer vector called " "action", walks the format list, evaluates any variables " found, and creates a secondary, pre-processed format list, " which is then used by the code which does the " format-driven conversions. The original format list is " pointed to by ps.special_list_p, and the structure of " the format items on it is described by plio_fb. The fully " processed format list is pointed to by pr5, and its structure " is plio_sb. fb is mnemonic for format block, and sb is for " storage block. This format list processing is used by both " output, in which case the format conversions are done by the " latter part of put_format_, and by input, in which case the " conversion part is done by plio2_qge_ (which stands for " quick_get_edit_). put_edit_eis: epp4 sp|ps_ptr,* pr4 will point to the ps throughout this code sta pr4|ps.offset since the a has the offset for the picture put_and_get_merge: stq pr4|ps.descr since the q has the descriptor stq pr4|ps.q_stored we also must save it here, for final restoration after put_field_ sta pr4|ps.a_stored same here. stx7 sp|x7_stored we cannot clobber any regs but a,q,bases,x0, and x1 spri2 pr4|ps.value_p we were entered with ptr->value in bp epp5 pr4|ps.format_area_p,* pr5 points to the original format thruout sxl0 sp|stack_frame.operator_ret_ptr this needed to return from any_to_any ldq 240,dl tsx1 |[alloc] spribp pr5|plio_sb.space_ptr this is temporary work space lda pr4|ps.new_format this flag,if not 0,means we are handling a new format list tze test_currep not the first so dont initialize,else " set up the sb format "model" from scratch, and initialize some stuff init_format: stz pr5|plio_sb.stk_index init to zero,though plio2_fl_.pl1 inits to 1 stz pr5|plio_sb.cur_rep init to zero stz pr4|ps.new_format no longer a new format since were initializing it epp3 null_loc,* spri3 pr5|plio_sb.sf1p spri3 pr5|plio_sb.fe1p spri6 pr5|plio_sb.sf2p epp3 pr4|ps.special_list_p,* this is set to the beginning of the formats spri3 pr5|plio_sb.cur_fep so it is the first format_ptr epp3 pr3|1 the 1st word is zeros to identify this as the start of a format list spri3 pr5|plio_sb.fe2p so for real use set the ptr one ahead " if the current rep factor>0,use the current format in the sb test_currep: epp7 pr5|plio_sb.cur_fep,* else follow the ptr in the last format to the next one & load the sb lda pr5|plio_sb.cur_rep However,if this is the 1st,we get the initial values from xx2p's, set tze test_offset in init_format. " " this is the format to do since the currep is > 0 " sba 1,dl 1st decrement currep, since we're finally using fep's fields sta pr5|plio_sb.cur_rep lda pr5|plio_sb.type cmpa c_format,dl if c_format we must set the real & imag formats in plio_sb.val(2) and plio_sb.val(3), tze exec_c_format else we only eval current fep's arguments and set plio_sb.val(1)'s values to them cmpa picture_format,dl and we're done. p_format's, however,get evaluated differently. tnz format_decoded ldq 0,dl eax0 got_format after decode_format,we want to go staight to got_format " decode_pic_format: lda pr7|plio_fb.val the picture image is at format's addr up the 1st value epp3 pr7|0,al so now pr3 points to it mpy 5,dl each set-of-values frame in the plio_fb structure is 5 wds long lda 2,dl so skip to the frame index which was in q on entry sta pr5|plio_sb.nval,ql set fframe's nval to 3 lda pr3|1 pic_image.varlength is up one,leftmost f.bin.(8) arl 27 get pure pic_image.varlength sta pr5|plio_sb.val_1,ql which is to be the 1st value sprp3 pr5|plio_sb.val_2,ql store as val_2 a ptr to the picture_image tra 0,0 and return through x0, since we were tsx0'd here " " Try to get the next format from the ptr in the last one. If its 0,we are test_offset: lxl1 pr7|plio_fb.offset at the end of a format list and must be in 1 of 3 cases--a)About to do tze test_stk_index the 1st format,initialized in init_format b)in a non-mainstream format list epp7 pr7|0,1 reached thru a r_format c)at the end of the list & should start over from top. spri7 pr5|plio_sb.cur_fep we just set the format-ptr to plio_fb.offset " since we have a new format,eval rep factor & set currep to it eval_rep: ldq pr7|plio_fb.rep tpl 2,ic if it is >0, it is a constant and needn't be evaluated tsx6 decode_q else we must call stu_ stq pr5|plio_sb.cur_rep lda pr7|0 get the num of values in the format arl plio_fb.nval_shift ana plio_fb.nval_mask,dl sta pr5|plio_sb.nval sb hold our present values. It stands for storage_block. lda pr7|0 now get the type code of the format arl plio_fb.code_shift since we're shifting 27 we needn't mask the remaining 9 bits sta pr5|plio_sb.type cmpa c_format,dl if >c_format, is a simple type.. if <, us r_format or l_paren,etc. tpnz test_currep if a_,b_,e_,f_,p_format, off we go cmpq 1,dl q still has currep, if 0 we want next format tmi test_offset cmpa c_format,dl if c_format there two sets of values to fill tze c_format_to_sb aos pr5|plio_sb.stk_index must be a case which requires another stack frame in the sb ldq pr5|plio_sb.stk_index i.e. either r_format or l_paren cmpq 9,dl check that max nesting depth is not exceeded tmoz 3,ic lda 12,dl tra |[any_qs_error_no_ret] mpy 10,dl each stack frame takes up 9 words, so this gets the offset epp1 pr5|plio_sb.cur_sfp,* now set the new frame's values to the current format spri1 pr5|plio_sb.sf1p,ql spri7 pr5|plio_sb.fe1p,ql pr7,now as always,points to the format item lda pr5|plio_sb.cur_rep we clobbered the q during multiplication,so it isn't currep like usual sta pr5|plio_sb.rep,ql set the frame's rep factor lda pr5|plio_sb.type and it's type cmpa r_format,dl r_format's values need stu_ to get them, while l_paren's are easier tze r_format_to_sb spri1 pr5|plio_sb.sf2p,ql this is l_paren,set sf2p to the current sfp--stack_frame_ptr lda pr7|plio_fb.val and set the fe2p to current format_ptr up its own val(1) epp3 pr7|0,al spri3 pr5|plio_sb.fe2p,ql we used pr3 cause we didn't want to clobber pr7, which always is the fep " test stack index, if=1 we're at the bottom of the stack & should continue test_stk_index: ldq pr5|plio_sb.stk_index with the xx2p ptrs, else if the frame's rep factor>0 use it over mpy 10,dl tze use_2s again & decrement the rep factor, else use the xx1p ptrs and decrement lda pr5|plio_sb.rep,ql the stack index tze use_1s sba 1,dl sta pr5|plio_sb.rep,ql " this means use the xx2p ptrs and reenter the mainstream use_2s: epp7 pr5|plio_sb.fe2p,ql* pr7 will be the format ptr, fep spri7 pr5|plio_sb.cur_fep and store it epp3 pr5|plio_sb.sf2p,ql* spri3 pr5|plio_sb.cur_sfp cur_sfp will be taken from plio_sb.sf2p tra eval_rep " " set the sfp, fep from the frame's xx1p's and decrement stack frame index use_1s: epp3 pr5|plio_sb.sf1p,ql* spri3 pr5|plio_sb.cur_sfp epp7 pr5|plio_sb.fe1p,ql* spri7 pr5|plio_sb.cur_fep q had the stck index times 10 to yield the offset, remember lcq 1,dl asq pr5|plio_sb.stk_index tra test_offset and rejoin the mainstream " " " this is the only way to get out of this routine " format_decoded: lda 0,du this means the format has been decoded,so start the evaluation loop eval_loop: cmpa pr5|plio_sb.nval have we eval'd as many args as there are? tze got_format if so, the format list walk is over ldq pr7|plio_fb.val,al otherwise, load the format's value tpl 2,ic if non-negative, its a constant so no stu_ call tsx6 decode_q if negative, call stu_ to decode it stq pr5|plio_sb.val,al store it in the sb storage block ada 1,dl add one to the value count tra eval_loop and loop over again " exec_c_format: stz pr5|7 zero out the real, imag value fields stz pr5|8 stz pr5|9 stz pr5|12 stz pr5|13 stz pr5|14 tsx6 check_for_param if there are no parameters it is an error stq sp|nval_temp check_for_param checks that plio_sb.nval>0 and leaves it in the q lda pr5|plio_sb.val the ptr to the real format is addrel(cur_fep,val_1) epp7 pr5|plio_sb.cur_fep,*al so figure out ptr to the real format ldq pr5|5 plio_sb.type(2),i.e. real format parts cmpq picture_format,dl if its a picture format we must decode tnz 4,ic otherwise we dont have to " eax0 real_part_ok after decoding the pis format we want to go here ldq 1,dl since it is the second value frame in the sb for the results tra decode_pic_format " lda 0,dl now eval each of the values in the format block's real part real_loop: cmpa pr5|6 plio_sb.nval(2), real part tpl real_part_ok this means they are all eval'd ldq pr7|plio_fb.val,al else get the next one tpl 2,ic if its negative we must call stu_ to decode it tsx6 decode_q stq pr5|7,al 2nd formats values start at 7 ada 1,dl and reloop evaluating the next value tra real_loop real_part_ok: ldq sp|nval_temp cmpq 2,dl if there's only 1 then only one format given for both imag & real tmi imag_like_real epp7 pr5|plio_sb.cur_fep,* else we must figure out imag format lda pr5|plio_sb.val_2 this is offset for imag format's format item epp7 pr7|0,al set up a correct ptr to it in pr7 ldq pr5|10 this is the format-type of imag format cmpq picture_format,dl tnz 4,ic if its not picture do not call decode_pic ldq 2,dl this tells decode_pic which format-frame to store results in eax0 got_format this is where to return to after decode_pic is done tra decode_pic_format and off we go lda 0,dl now evaluate format block's values one by one imag_loop: cmpa pr5|11 this is imag format's nval,if = we've eval'd them all tpl got_format if we've eval'd them all we've finished the format-list walk! ldq pr7|plio_fb.val,al otherwise eval the next one tpl 2,ic tsx6 decode_q stq pr5|12,al and store it into the sb block ada 1,dl add one to our count tra imag_loop and continue " imag_like_real: mlr (pr),(pr) we're here if only one format given within c_format,so desc9a pr5|7,12 just move all the sb's real values to the sb imag-values desc9a pr5|12,12 section and we're done tra got_format " c_format_to_sb: mlr (pr),(pr) move fields from format block to sb desc9a pr7|plio_fb.val,12 desc9a pr5|plio_sb.val,12 tsx6 check_for_param if nval<1 there is an error epp7 pr5|plio_sb.cur_fep,* get ptr to the first value in format block lxl0 pr7|plio_fb.val_1 use it as offset to the real format's block--real vs.cplx lda pr7|0,x0 arl plio_fb.code_shift get the real part of the format's type code ana plio_fb.code_mask,dl sta pr5|5 and store it in storage block's fields for the real part ldq pr7|0,x0 now go after the real part's nval qrl plio_fb.nval_shift anq plio_fb.nval_mask,dl stq pr5|6 and store it in plio_sb.real-part's nval lxl6 pr5|plio_sb.nval now see if a separate imag format was even specified cmpx6 2,du if it was nval>1, and extract & store the imag part's type &nval tpl set_imag which is done in set_imag store_imag: staq pr5|10 else just repeat the real part's values for plio_sb.imag's type, nval tra test_currep and were finished setting the cplx format's real,imag type, nval " set_imag: lxl0 pr7|plio_fb.val_2 get offset to imag part of complex format lda pr7|0,x0 load the first word, which contains the type code arl plio_fb.code_shift extract it ana plio_fb.code_mask,dl ldq pr7|0,x0 extrace the nval,too--number of values qrl plio_fb.nval_shift anq plio_fb.nval_mask,dl tra store_imag and store them in plio_sb.imag part's type,nval " r_format_to_sb: epp0 pr5|plio_sb.space_ptr,* to evaluate remote format we must 1st call stu$remote_format epp4 pr7|plio_fb.val 1st arg is plio_fb.val_1, which gets eval'd to the rmote format spri4 pr0|2 store it in arg list epp4 pr5|plio_sb.cur_sfp 2nd arg is stack_frame ptr to frame of format, not necessarily ours! spri4 pr0|4 epp4 null_loc 3rd arg is null spri4 pr0|6 epp4 pr0|20 4th arg is a label(4 wds) in which to store loc of value of remote format spri4 pr0|8 epp4 pr0|24 last arg is return value, which is error code spri4 pr0|10 sreg sp|8 and now do the call fld 5*2048,dl 5 args in all staq pr0|0 tsx1 |[get_our_lp] stcd sp|stack_frame.return_ptr callsp |[remote_format] lreg sp|8 epp4 sp|ps_ptr,* restore ptr registers epp5 pr4|ps.format_area_p,* epp7 pr5|plio_sb.cur_fep,* epp3 pr5|plio_sb.space_ptr,* ldq pr3|24 check error code tze 3,ic if zero there's no problem lda 11,dl else raise an error tra |[any_qs_error_no_ret] epp2 pr3|22,* get the format value's stack frame ptr ldq pr5|plio_sb.stk_index mpy 10,dl store each of the 2 ptrs making up the label figured out by stu_ spri2 pr5|plio_sb.sf2p,ql into the right fields in the sb epp2 pr3|20,* get fe pointer epp2 pr2|1 since the 1st word is a flag word of all zero's spri2 pr5|plio_sb.fe2p,ql tra test_stk_index and we're done " got_format: lda pr5|plio_sb.type transfer through a table to the right type-specific action ldq pr4|ps.job canq =o002000,du check the put bit tnz action-3,al the name of the table is action xec get_code-3,al sp|temp will be 0 for data's, non-zero for stls epp7 pr5|plio_sb.space_ptr,* epp4 sp|ps_ptr else set up the call to plio2_$quick_get_edit spri4 pr7|qs_arg_list+2 1st arg is ps ptr sreg sp|8 fld 1*2048,dl staq pr7|qs_arg_list eppap pr7|qs_arg_list the qge stands for quick_get_edit, naturellement tsx1 |[get_our_lp] stcd sp|stack_frame.return_ptr callsp |[quick_get_edit_] lreg sp|8 ldq sp|temp tnz ret_from_control lxl0 sp|stack_frame.operator_ret_ptr stz sp|stack_frame.operator_ret_ptr tra |[restore_regs_and_frame_and_ret] " decode_q: spri7 sp|double_temp this code calls stu_$decode_runtime_value to decode the value epp0 pr5|plio_sb.space_ptr,* which is in q on entry, and leaves the decoded value in q whin it stq pr0|20 returns to the location in the operator which is in x6 epp4 pr0|22 arg8 will be return value, which will be at pr0|22 spri4 pr0|16 so put ptr to it in arg list as arg 8 epp4 pr0|20 spri4 pr0|2 arg1 is the value to eval epp4 pr5|plio_sb.cur_sfp spri4 pr0|6 arg3 is the stack_frame_p for the stack frame in which the value is epp4 pr0|21 spri4 pr0|14 arg7 is the returned error code epp4 null_loc spri4 pr0|4 arg2 is null spri4 pr0|8 as is arg4 spri4 pr0|10 arg5 is also null spri4 pr0|12 arg6 is also null sreg sp|8 now do the call fld 8*2048,dl there were 8 args including the return value which is the decoded value staq pr0|0 tsx1 |[get_our_lp] stcd sp|stack_frame.return_ptr callsp |[decode_runtime_value] lreg sp|8 epp4 sp|ps_ptr,* restore ptr registers epp5 pr4|ps.format_area_p,* epp7 sp|double_temp,* we saved pr7 in double_temp for the duration of this call epp3 pr5|plio_sb.space_ptr,* ldq pr3|21 check returned error code, if non-zero raise error tze 3,ic lda 11,dl tra |[any_qs_error_no_ret] ldq pr3|22 return value is here, put it in q tra 0,6 and return to caller with evaluated value in q " " what follows is the transfer table to the format-specific action " dictated by the format type,See include file plio_format_codes for " numeric values of the differet format types action: tra do_c_format tra do_f_format tra do_e_format tra do_b_format tra do_a_format tra do_x_format tra do_skip_format tra do_col_format tra do_page_format tra do_line_format tra do_pic_format tra do_bn_format " get_code: stz sp|temp stz sp|temp stz sp|temp stz sp|temp stz sp|temp stcd sp|temp stcd sp|temp stcd sp|temp stcd sp|temp stcd sp|temp stz sp|temp stz sp|temp " do_x_format: tsx6 check_for_param x_format requires a parameter, else it is an error eax6 5 this is the code understood by put_field_$put_control for x format ldq pr5|plio_sb.val_1 this is the parameter, or number of spaces to skip tze test_currep if its zero, ignore the format completely tra do_control else do the control do_page_format: eax6 3 this is the code for page format which takes no parameter! tra do_control " do_col_format: tsx6 check_for_param this format requires a parameter eax6 2 ldq pr5|plio_sb.val_1 x6 has the format's code for put_control, q has the parameter itself tpnz do_control ldq 1,dl if the param was 0,make it 1 instead tra do_control " do_line_format: tsx6 check_for_param eax6 4 ldq pr5|plio_sb.val_1 tpnz do_control lda 9,dl tra |[any_qs_error_no_ret] " do_skip_format: eax6 1 ldq pr5|plio_sb.nval tze no_skip_arg " do_most_controls: ldq pr5|plio_sb.val_1 do_control: tsp1 |[put_control_from_format] ret_from_control: epp4 sp|ps_ptr,*, epp5 pr4|ps.format_area_p,* restore ptrs and continue with format-list walk tra test_currep no_skip_arg: ldq 1,dl tra do_control " " now for the data formats " do_a_format: epp1 pr5|plio_sb.space_ptr,* it is my convention that pr1 points to the newly-alloc'd space lda pr4|ps.descr descr=0 means its a picture tze a_f_pic_source ana =o374000000000 otherwise,extract the source type from the descr arl 28 cmpa char_desc,dl a is now the source type,lets filter out superquick conversons tze char_to_char character to char conversion can be superquick cmpa v_char_desc,dl as can varying_char to char tze vchar_to_char tsx0 set_source_wa any other situation is guaranteed to need an any_to_any conv. a_f_source_ok: lda pr5|plio_sb.nval set_source_wa set the source regs used by a_to_a tze no_len_given if nval=0 no length given in a format lda pr5|plio_sb.val_1 otherwise use it as the target length in a_to_a tnz not_zero_targ if a(0), must be pulled out,else assumed var str ab_null_string: ldq 0,dl epp2 0 just to be safe tra superquick_return " not_zero_targ: sta pr5|plio_sb.format_len we need it after the a_to_a call so save it eax6 char_desc this is the target descriptor for a_to_a tra source_been_set and off to any_to_any and then put_field " no_len_given: stz pr5|plio_sb.format_len if no len given,make the target a varying char lda 256,dl of max length 256 and store a 0 in format_len as a flag eax6 v_char_desc " source_been_set: epp5 pr1|66 pr5 points to work area of 156 words,starting at space|66 " code to push a stack,needed for any_to_any call epbp7 pr6|0 point to stack header epp2 pr6|stack_frame.next_sp,* point to next frame spri6 pr2|stack_frame.prev_sp link next frame epp6 pr2|0 epp2 pr2|new_stack_size spri2 pr7|stack_header.stack_end_ptr store ptr to end of frame spri2 pr6|stack_frame.next_sp lxl0 pr6|stack_frame.flag_word turn support bit on orx0 stack_frame.support_bit,du sxl0 pr6|stack_frame.flag_word epp2 * spbp2 pr6|tbp set text_base_ptr ata_call: tsx0 |[any_to_any_] separate entry point for error signalling differences " code to pop my stack after_ata_call: epbp7 pr6|0 point to stack header inhibit on spri6 pr7|stack_header.stack_end_ptr epp6 pr6|stack_frame.prev_sp,* inhibit off " epp0 sp|ps_ptr,* restore pointers epp5 pr0|ps.format_area_p,* epp2 pr5|plio_sb.space_ptr,* af_return: ldq pr5|plio_sb.format_len put_field expects the output string's length in q tnz 2,ic if it was zero, that means target was a varying string ldq pr2|-1 so get the length from the length word at addr|-1 superquick_return: lxl0 sp|stack_frame.operator_ret_ptr restore x0 to its value on entry to put_format stz sp|stack_frame.operator_ret_ptr tra |[put_field_from_format] and off we go " vchar_to_char: ldq pr5|plio_sb.nval if no length specified no move is needed tze vc_no_len use source string as output epp3 pr4|ps.value_p,* else move the string with padding/truncation lda pr3|-1 ldq pr5|plio_sb.val_1 get the target len tra superquick_af_2 and merge with the move, but pr3 already set " vc_no_len: epp2 pr4|ps.value_p,* ldq pr2|-1 length of output string will be len of orig source var string tra superquick_return and were done " char_to_char: lda pr4|ps.descr get the length from descriptor's 2nd 1/2 ana =o000077777777 char_to_char_len: ldq pr5|plio_sb.nval if no length specified,use source string's len & no conversion tze no_move if no target len given, no move needed,use orig string as output ldq pr5|plio_sb.val_1 superquick_af: epp3 pr4|ps.value_p,* superquick_af_2: epp2 pr1|0 mlr (pr,rl),(pr,rl),fill(040),enablefault desc9a pr3|0,al desc9a pr2|0,ql tra superquick_return " no_move: epp2 pr4|ps.value_p,* lrs 36 tra superquick_return " a_f_pic_source: ldx0 pr4|ps.top_half top_half is offset for the picture image epp7 sp|tbp,*x0 get a ptr to it lda pr7|1 extract its length & leave it in the a arl 27 length is top 9 bits of the word tra char_to_char_len since it must be a character picture merge with char_to_char " do_b_format: epp1 pr5|plio_sb.space_ptr,* pr1 should point to the newly alloc'd space tsx0 set_source_wa set the source registers for a_to_a lda pr5|plio_sb.nval save the param for the len of the final string,not this one tze 2,ic if no format param given,let lang rules determine final length lda pr5|plio_sb.val_1 merge_b_bn: sta pr5|plio_sb.format_len lda 256,dl b format needs 2 conversions-1st to bit string, then to character eax6 v_bit_desc for bit string, make it varying bit string with only max len given epp5 pr1|0 pr5 points to the work space epp1 pr1|222 pr1 points to where to put the result of conversion " code to push a stack,needed for any_to_any call epbp7 pr6|0 point to stack header epp2 pr6|stack_frame.next_sp,* point to next frame spri6 pr2|stack_frame.prev_sp link next frame epp6 pr2|0 epp2 pr2|new_stack_size spri2 pr7|stack_header.stack_end_ptr store ptr to end of frame spri2 pr6|stack_frame.next_sp lxl0 pr6|stack_frame.flag_word turn support bit on orx0 stack_frame.support_bit,du sxl0 pr6|stack_frame.flag_word spri4 sp|ps_ptr epp2 * spbp2 pr6|tbp set text_base_ptr tsx0 |[any_to_any_] epp4 sp|ps_ptr,* restore pointers epp5 pr4|ps.format_area_p,* epp1 pr5|plio_sb.space_ptr,* epp3 pr1|222 source for final conversion=target of preliminary one lda pr5|plio_sb.type if its bn format 2nd half of conversion is different cmpa bn_format,dl tze final_conv_for_bn this is who does the 2nd half for bn_format ldq pr3|-1 length of bit string is at addr|-1 lda pr5|plio_sb.format_len we saved length of final character string here tnz 2,ic but if no length given in b_format, use length of intermediate bit string lda pr3|-1 sta pr5|plio_sb.format_len in any case remember the length for later use eax6 char_desc and convert to a character string eax7 v_bit_desc from a varying bit string epp5 pr1|66 this is the 156 word work space for a_to_a tra ata_call do the second conversion & go straight to put_field " ata_call_and_ret: stx0 sp|temp we will return here later " code to push a stack,needed for any_to_any call epbp7 pr6|0 point to stack header epp2 pr6|stack_frame.next_sp,* point to next frame spri6 pr2|stack_frame.prev_sp link next frame epp6 pr2|0 epp2 pr2|new_stack_size spri2 pr7|stack_header.stack_end_ptr store ptr to end of frame spri2 pr6|stack_frame.next_sp lxl0 pr6|stack_frame.flag_word turn support bit on orx0 stack_frame.support_bit,du sxl0 pr6|stack_frame.flag_word epp2 * spbp2 pr6|tbp set text_base_ptr tsx0 0,1 call the a_to_a entry point in index reg 1 " code to pop my stack epbp7 pr6|0 point to stack header inhibit on spri6 pr7|stack_header.stack_end_ptr epp6 pr6|stack_frame.prev_sp,* inhibit off " epp4 sp|ps_ptr,* restore pointers epp5 pr4|ps.format_area_p,* epp1 pr5|plio_sb.space_ptr,* ldx0 sp|temp restore index reg 0 and return through it tra 0,0 " do_bn_format: epp1 pr5|plio_sb.space_ptr,* pr1 should point to the newly alloc'd space tsx0 set_source_wa set the source registers for a_to_a lda pr5|plio_sb.nval save the param for the len of the final string,not this one cmpa 2,dl tze bn_with_len if an explicit length was given we must put it in a register eaa 0 otherwise a length of 0 means no length was given tra merge_b_bn join flow of vanilla b_format bn_with_len: lda pr5|plio_sb.val_2 load the output length in a tra merge_b_bn and join b_format flow " final_conv_for_bn: ldq pr3|-1 get length of source bit string,now converted div pr5|plio_sb.val_1 now divide by the radix_factor to find out how many output-chars needed sta sp|extra_bits and save the remainder for later cmpa 0,dl if there was a remainder, the # of output chars will be 1 greater tze 2,ic to hold the left-overs,padded on the left with 0's adq 1,dl stq pr5|plio_sb.extra_temp now save this "real_len", or number of chars needed to hold value " eax7 0 x7 is the count of how many output chars we have put out so far lda pr5|plio_sb.nval now find out if an explicit length was given cmpa 1,dl if nval=1, there was only a radix-factor, no length tnz bn_len_given else goto to this label stq pr5|plio_sb.format_len final format len will be this length, not 0, which is tra use_real_len what is in plio_sb.format_len now ,for formats with no explicit length bn_len_given: lda pr5|plio_sb.val_2 get the given format length tze ab_null_string if its zero, put out a null string without raising stringsize cmpq pr5|plio_sb.val_2 is the required num of char>format len? tpnz raise_stringsize if so, we must raise stringsize tze use_real_len if they are equal, no padding is needed " mlr (),(pr,rl),fill(040) move in the blanks zero 0 desc9a pr1|0,al pr1 points to output string " use_real_len: lxl0 pr5|plio_sb.extra_temp move value to upper half of word, for later cmpxning stx0 pr5|plio_sb.extra_temp lxl1 pr5|plio_sb.val_1 x1 needs radix-factor , to know how long a string to csl stx1 sp|radix_factor we need radix-factor in upper half of a word for adxning ldq pr3|-1 lda sp|extra_bits eax0 0 csl (),(pr,rl,ql),bool(clear) zero descb pr3|0,al ldq 36,dl now handle the first digit by hand,which we must cause we must sbq pr5|plio_sb.val_1 assume leading 0's.We will load it and then shift it right 36-extra_bits bits. eax6 0,ql x6 is how much to right-shift all other digits,=36-radix_factor " bn_loop: csl (pr,rl,x0),(pr),bool(move) move x1--radix-factor--bits from pr3 up x0--offset-- descb pr3|0,x1 to sp|rad_fac_bits descb sp|radix_fac_bits,x1 " lda sp|radix_fac_bits now load those bits in a and shift them right enough to arl 0,x6 leave only one digit's worth adx0 sp|radix_factor increment offset in source bits for next csl. Offset is in x0. " first_radix_factor_bits: mlr (al),(pr,x7) now use the digit in a-reg as index into hex_table to get correct character, desc9a hex_table,1 and move that char to output string at offset x7 desc9a pr1|0,1 " adx7 1,du increment output offset cmpx7 pr5|plio_sb.extra_temp did we reach end of output string? tmi bn_loop if not, loop back and do the next digit tra after_ata_call at this point were done, so go here to pop stack, restore regs, " and go off to put field with the newly-created string. " hex_table: aci "0123456789abcdef" " raise_stringsize: mlr (pr),(pr),enablefault this is a fake move whose only purpose in life is to raise desc9a pr3|0,1 a stringsize condition if a truncation was implied by the output desc9a pr1|0,0 request. tra use_real_len return to main body after the stringsize was raised " do_c_format: stz pr5|plio_sb.cplx_flags this is 2 flags-1st half wd is real,2nd halfword is imag epp1 real_part_done pef formats return to this label variable ldq 64,dl we need more storage for complex final output string tsx1 |[alloc] dont change stor_taken cause put_term uses sp|5 to reset stack eaq 304 stq sp|storage_taken mlr (pr),(pr) desc9a pr5|5,20 desc9a pr5|0,20 " space_ptr|240 will be the loc of the final string handle_pef: spri1 pr5|plio_sb.pef_finish pef format returns through here lda pr5|plio_sb.type find out format type cmpa e_format,dl can be e,f,or p format--f_format=4,e=5,pic=13 tze e_format_from_cplx tmi f_format_from_cplx tra p_format_from_cplx " real_part_done: epp7 pr5|plio_sb.space_ptr,* we'll move the output str for the real part here epp7 pr7|240 mlr (pr,rl),(pr,rl) desc9a pr2|0,ql desc9a pr7|0,ql stq pr5|plio_sb.real_parts_len we need this to know where to put imag part &how long final string is eax1 2 imag_flag is 2 to be added to prec of dec float num to give len in bytes sxl1 pr5|plio_sb.cplx_flags epp1 imag_part_done mlr (pr),(pr) desc9a pr5|10,20 desc9a pr5|0,20 tra handle_pef this will call pef format after storing return loc & setting format ptr in sb " imag_part_done: lda pr5|plio_sb.real_parts_len so we know where to put imag part of output string epp7 pr5|plio_sb.space_ptr,* a9bd pr7|240,al mlr (pr,rl),(pr,rl) desc9a pr2|0,ql q is len of imag part, pr2 points to it desc9a pr7|0,ql pr7 points to cplx_output up real_part_len adq pr5|plio_sb.real_parts_len so q has the length of the final complex string epp2 pr5|plio_sb.space_ptr,* pr2 must point to string to be put epp2 pr2|240 tra end_of_pef " " do_e_format: stz pr5|plio_sb.cplx_flags epp1 end_of_pef spri1 pr5|plio_sb.pef_finish pr5|plio_sb.pef_finish will be where to go on completion--in this case to put_field_ e_format_from_cplx: lda pr5|plio_sb.nval if coming in this entry, pef_finish will be a location in the complx handling " stuff. Now get the number of args to e_format- 1,2,3, corresponding to " e(w[,d[,s]]).. w is field width, d is num of decimal locations, s is num sig cmpa 2,dl digits. tmi e_one_op one op is w, d=w-8, s=d+1 tze e_two_ops two ops are w,d..s=d+1 " must have 3 ops lda pr5|plio_sb.val_3 get the third one ldq pr5|plio_sb.val_2 get the 2nd one and put it in the q stq sp|d_temp since the 2nd arg is d, store it in d_temp cmpa sp|d_temp we must check that s is not < d, BUGFIX! tpl e_merge_for_w where we will extract the 1st val, or "w", and continue tra raise_size " e_two_ops: " get the 2nd arg, or "d"--num of decimal digits lda pr5|plio_sb.val_2 sta sp|d_temp and store it ada 1,dl if s is not explicit, it =d+1, so now calc it e_merge_for_w: ldq pr5|plio_sb.val_1 get the 1st val, or "w" tze ef_null_string stq sp|w_temp and store it tra e_merge e_merge assumes "s" is in a reg " e_one_op: lda pr5|plio_sb.val_1 get "w" tze ef_null_string sta sp|w_temp otherwise, w_temp never gets set, this is a BUGFIX! sba 8,dl s=w-7 sta sp|d_temp d=w-8 ada 1,dl and leave "s" in the a_reg e_merge: sta pr5|plio_sb.format_len a has "s", or prec of fl dec intermed val epp1 pr5|plio_sb.space_ptr,* pr1 always should point to our work space tsx0 set_source_wa set the source regs for a_to_a call lda pr5|plio_sb.format_len load a with the precision of the float dec target lxl6 pr5|plio_sb.cplx_flags we want to see if its the imag part of a c_format tze not_e_imag if it is,we must force intermed value to cplx eax6 D_float_cplx_desc tra not_e_imag+1 zero_value: mlr (),(pr),fill(000) AG94 says if the value is zero the exponent is printed as "000" zero 0 even though it isn't really, so move a 0 to exponent byte of value desc9a pr1|0,1 at this point pr1 points to exponent byte of float dec number lda pr5|plio_sb.format_len now set a to the number of pre-decimal digits--all zeros sba sp|d_temp d_temp is the number of post-decimal digits s9bd pr1|0,al move pr1 backwards to encompass the requisite number of ascii "0"'s tra zero_merge and merge with main flow not_e_imag: eax6 D_float_real_desc this is the type of the intermed value to convert to epp1 pr5|plio_sb.space_ptr,* set up pr's for a_to_a call epp5 pr1|66 pr5 points to a_to_a's workspace eax1 |[any_to_any_round_] lang rules say we must round,not truncate tsx0 ata_call_and_ret and do conversion to float decimal " ldq pr5|plio_sb.format_len put precision of float dec value in q epp7 pr1|66 pr7 is where we'll put result of our hand-conversion epp2 pr7|0 put_field expects pr2 to point to output string,so set it here lxl0 pr5|plio_sb.cplx_flags we must throw away real part of cplx result if imag part of c_format tze e_imag_merge otherwise skip the next 2 instructions a9bd pr1|0,ql the real part of the complex value is of len prec+2 a9bd pr1|0,x0 and cplx_flag has a value of 2 e_imag_merge: eax0 1 we will frequently need a register with a 1 in it mlr (pr),(pr),fill(000) squirrel the sign char away for later use, in x1 desc9a pr1|0,1 we'll have to use sp|temp as a conduit desc9a sp|temp,4 zeroing the rest of sp|temp ldx1 sp|temp now x1 has the sign char,as desired a9bd pr1|0,x0 x0 has a 1 in it, this is to skip sign char in source tct (pr,rl) find the 1st non-zero char in the float dec value desc9a pr1|0,ql this skips leading ascii zeros arg table arg sp|temp offset of 1st non-zero will appear in sp|temp lda sp|temp ana =o000777777777 zero out the 1st byte of it, which is the char found a9bd pr1|0,al advance the source ptr over the leading zeros ttn zero_value if they are all zero, value is zero & we must change exponent's value neg 0 ada pr5|plio_sb.format_len otherwise let a be the number of remaining digits after the 0's zero_merge: sta pr5|plio_sb.extra_temp extra_temp is the number of post-leading 0's digits ldq sp|w_temp w_temp is the total output field length mlr (),(pr,rl),fill(040) blank out entire target area zero 0 desc9a pr7|0,ql pr7 points to target area lda sp|d_temp if d=0, no decimal point printed hence an extra leading blank tnz 2,ic a9bd pr7|0,x0 this is the extra leading blank taking the place of the "." sbq pr5|plio_sb.format_len skip field-width-prec-6 leading blanks sbq 6,dl a9bd pr7|-1,ql for a while pr7 points to one word before where we are in output string cmpa pr5|plio_sb.format_len if s=d we must insert a pre-"." zero to look nice tze s_is_d_move eax6 3 x6 is offset off of pr7 to put a "-" if needed eax7 4 x7 is offset off pr7 to move the pre-"." string lda pr5|plio_sb.format_len calculate the number of pre-"." digits sba sp|d_temp which is s-d, or num of sig digits - num of decimal digits sta sp|sd_temp sd_temp saves the value s-d ldq sp|sd_temp q is the number of pre-"." digits to move into cmpa pr5|plio_sb.extra_temp a is the num of pre-"." digits to move from, or min(s-d,extra_temp) tmoz e_move lda pr5|plio_sb.extra_temp tra e_move and now perform the move " equ table,*-12 oct 000777777777 oct 777777777777 oct 777777000000 " s_is_d_move: eax6 2 set the offsets & lengths for the case where s=d lda 0,dl a = num of pre-"." digits to move from, or 0 ldq 1,dl q is the num of pre-"." digits to move to, or 1 "0" eax7 3 x7 is the offset for the pre-"." string of digits stz sp|sd_temp s-d is obviously 0 e_move: sta sp|b_temp the num of digits we're using from the float dec string will be needed later mlr (pr,rl),(pr,rl,x7),fill(060) fill is "0" desc9a pr1|0,al pr1 points to source string desc9a pr7|0,ql pr7 is our hand-converted result string cmpx1 minus_char if float dec was <0 we must move in a "-" tnz not_minus mlr (),(pr,x6),fill(055) fill is "-" zero 0 desc9a pr7|0,1 we set x6 previously to the offset for the "-" if needed not_minus: ldq sp|sd_temp advance the source & targ ptrs past the chars we just moved a9bd pr7|1,ql we can now make pr7 point to targ string, not targ string-1word a9bd pr1|0,ql which was done cause negative offsets in strings not allowed ldq sp|d_temp now move the "." tze no_dec if there are any decimal digits mlr (),(pr),fill(056) fill char is "." zero 0 desc9a pr7|0,1 so move the "." to the target string a9bd pr7|0,x0 and advance the target ptr past it, x0 having a 1 in it no_dec: lda pr5|plio_sb.extra_temp now move the post-"." digits sba sp|b_temp taking m-b digits from the source string,b being num previously moved ldq sp|d_temp and moving them into d digits, filling with "0"'s mlr (pr,rl),(pr,rl),fill(060) fill char is "0" desc9a pr1|0,al a has num of post-leading 0's digits minus num previously moved desc9a pr7|0,ql q has d, or num of decimal digits specified by e format a9bd pr7|0,ql advance target ptr past just-moved digits a9bd pr1|0,al and source ptr,too mlr (),(pr),fill(145) move in the "e" which precedes the exponent's value zero 0 desc9a pr7|0,1 a9bd pr7|0,x0 advance targ ptr 1 char past the "e" we just moved in mlr (pr),(pr) now move the value of the exponent into sp|temp desc9a pr1|0,1 pr1 now points to the exponent's value in the source string desc9a sp|temp,1 lda sp|temp load the exponent's value als 1 and make it into a normal number(it was 8 bits before) ars 28 ada pr5|plio_sb.extra_temp final exponent=exp+m-s+d,where m=num of non-leading-0 digits sba sp|sd_temp sta sp|temp store the final exponent's value since btd is storage-to-storage btd (pr),(pr) and convert it to decimal form desc9a sp|temp,4 putting it directly into the output string with a sign desc9ls pr7|0,4 and three digits ldq sp|w_temp put_field want's field's length in q tra pr5|plio_sb.pef_finish,* and were finished with this conversion " end_of_pef: lxl0 sp|stack_frame.operator_ret_ptr and we must restore x0, which we clobbered stz sp|stack_frame.operator_ret_ptr tra |[put_field_from_format] and off we go " " this routine sets up the registers describing the source to be converted " by any_to_any_. It is tsx0'd to set_source_wa: ldq pr4|ps.descr picture sources,which have descr=0, must be handled differently tze general_pic_source anq =o376000000000 extract the source type from the descriptor qrl 10 epp3 pr4|ps.value_p,* pr3 must point to the source to be converted eax7 0,qu x7 must have the source's type cmpx7 v_char_desc,du fixed or varying strings must be handled differently tze fix_len since there descriptor has a len field rather than scale-prec cmpx7 v_bit_desc,du tze fix_len cmpx7 char_desc,du tze string_desc cmpx7 bit_desc,du tze string_desc sta sp|temp we know it is an arithmetic source, so extract scale-prec from descr lda pr4|ps.descr ana =o000077777777 lrl 12 qrl 6 lrl 18 lda sp|temp now q has scale in top 1/2, prec in lower, and a has been restored tra 0,0 so were done string_desc: ldq pr4|ps.descr strings have to have only the length extracted, which is lower 2/3 of descr anq =o000077777777 tra 0,0 and return, since x7 has already been correctly set fix_len: ldq pr3|-1 for varying strings we must extract the len of the source from addr|-1 tra 0,0 and return. The a has not been clobbered,x7 has been set " ef_null_string: ldq 0,dl if e_format or f_format field width =0, AG94 says output epp2 pr5|plio_sb.space_ptr,* is just a null string, so set it up tra pr5|plio_sb.pef_finish,* and we're finished with the entire ccnversion. " do_f_format: stz pr5|plio_sb.cplx_flags we are not in the middle of a complex format, so zero this flag epp1 end_of_pef we want to go here when done with the conversion spri1 pr5|plio_sb.pef_finish f_format_from_cplx: lda pr5|plio_sb.nval get num of values to f(...) from processed format block stz sp|k_temp k=scaling factor, usually zero so set it now, can be reset later if one found ldq pr5|plio_sb.val_1 get 1st value, or w (field width).This MUST be there tze ef_null_string e,f formats are defined as null strings if w=0 stq sp|w_temp cmpa 2,dl reg. a still has num of args to f_format tmi f_one_op tze f_two_ops ldq pr5|plio_sb.val_3 stq sp|k_temp f_two_ops: " now get 2nd arg,or num of dec positions (d) ldq pr5|plio_sb.val_2 stq sp|d_temp tra f_merge to skip next instruction f_one_op: stz sp|d_temp by definition, d=0 if not given f_merge: epp1 pr5|plio_sb.space_ptr,* tsx0 set_source_wa stq sp|temp ldq sp|w_temp lda sp|d_temp tze 2,ic if d=0,prec=min(max_dec_precision,w), else prec=min(max_dec_precision,w-1). sbq 1,dl this gives room for decimal point cmpq max_dec_precision,dl tmoz 2,ic ldq max_dec_precision,dl if here, max_dec_precision|[any_to_any_round_] tsx0 ata_call_and_ret " ldq pr5|plio_sb.extra_temp 1st task is to blank out target string,for possible leading blanks eax6 1 mlr (pr),(pr),fill(000) pr1 now pts to fix dec number desc9a pr1|0,1 squirrel away sign char in x0 desc9a sp|temp,4 ldx0 sp|temp epp3 pr1|0 pr3 is source_ptr lxl7 pr5|plio_sb.cplx_flags tze 3,ic a9bd pr3|0,ql a9bd pr3|0,x6 epp7 pr1|66 pr7 will be loc of final output string epp2 pr7|0 mlr (),(pr,rl),fill(040) zero desc9a pr7|0,ql we just provided the leading, as well as more,blanks a9bd pr3|0,x6 to skip sign in source sbq sp|d_temp q still has field width in it.We want to extract pre-decimal pt. sbq 1,dl digits from the f.dec number,skipping leading zeros. tct (pr,rl) desc9a pr3|0,ql arg table arg sp|k_temp p-q-1 is max possible num of leading zeros. " ldq sp|k_temp k_temp has number of leading zeros anq =o000777777777 stq sp|k_temp a9bd pr3|0,ql skip them by advancing source_p past them a9bd pr7|0,ql advance targ_ptr to leave the leading blanks virgin " lda pr5|plio_sb.extra_temp the num of pre-"." digits is prec-num of skipped zeros-scale,so calc it sba sp|k_temp k_temp being num of skipped zeros sba sp|d_temp and d_temp being scale,s tmoz raise_size there must be at least one digit before "." BUGFIX cmpx0 minus_char look at sign_p->char1 to see if orig value was <0,if so insert "-" tze source_lt_zero since sign_p->"-",insert a "-" " sign_set: mlr (pr,rl),(pr,rl) now move the pre-"." digits desc9a pr3|0,al desc9a pr7|0,al remember pr7 is target ptr a9bd pr3|0,al advance source_p past digits we just moved a9bd pr7|0,al do the same for targ_ptr ldq sp|d_temp if scale=0,there is nothing but the pre-"." stuff so were finished tze f_done " mlr (),(pr),fill(056) zero 0 move in the "." to the target desc9a pr7|0,1 which is pr7 a9bd pr7|0,x6 and up the targ ptr mlr (pr,rl),(pr,rl) now move in the last post-"." digits desc9a pr3|0,ql q still has q, which serves as the numbber desc9a pr7|0,ql of digits after the dec point " if you didnt notice, were finished! f_done: ldq sp|w_temp q should be length of output string tra pr5|plio_sb.pef_finish,* " source_lt_zero: cmpq 0,dl if no zeros were skipped,no room for "-" tpnz dont_raise_size if any 0's were skipped we have room raise_size: epp7 pr5|plio_sb.space_ptr,* epp4 sp|ps_ptr else set up the size-condition raising call spri4 pr7|qs_arg_list+2 1st arg is ps ptr sreg sp|8 lxl0 sp|stack_frame.operator_ret_ptr fld 1*2048,dl staq pr7|qs_arg_list eppap pr7|qs_arg_list tsx1 |[get_our_lp] stcd sp|stack_frame.return_ptr callsp |[pve_error] lreg sp|8 tra |[set_no_ret_error] dont_raise_size: mlr (),(pr),fill(055) fill char is a "-", this moves it into output string zero 0 desc9a pr7|-1(3),1 pr7 points to output string tra sign_set and remerge with mainstream code, sign having been inserted " do_pic_format: stz pr5|plio_sb.cplx_flags snce were not doing imag part of cplx format epp1 end_of_pef where to go when finished spri1 pr5|plio_sb.pef_finish p_format_from_cplx: lprp1 pr5|plio_sb.val_2 get a ptr to the format's picture_image in pr1 spri1 sp|double_temp and save it in double_temp tsx1 decode_pic_desc now decode the picture pointed to by pr1 sta sp|int_val_scaleprec a has the scale-prec specified by the picture stx6 sp|int_val_type x6 has the type to convert through specified by the picture lda pr4|ps.descr find out if the source is pic,if so must unpack picture tnz not_pic_source if it isn't a picture skip call to unpack_pic eax0 ass_pic_source_to_intermed this is where to go after unpacking the picture " " This routine is dropped through to in the case of p_formats, and is tsx0'd to " from the other formats in the case in which the source value is a picture. The " routine calls unpack_pic and transfers to the location in x0. " general_pic_source: ldx1 pr4|ps.top_half epp1 sp|tbp,*x1 1st build a ptr to the picture description,*x1at base|ps.top_half tsx1 decode_pic_desc this routine assumes the ptr to the pic is in pr1 sta sp|source_val_scaleprec store the returned scale-prec sxl6 sp|source_val_type store the returned type epp7 pr5|plio_sb.space_ptr,* we need space for the result of the unpacking epp7 pr7|156 epp3 pr4|ps.value_p,* spri7 pr7|qs_arg_list+2 1st arg is buffer in which to place result spri3 pr7|qs_arg_list+6 3rd arg is ptr to source value spri1 pr7|qs_arg_list+4 2nd arg is ptr to picture description sreg sp|8 and make the call fld 3*2048,dl staq pr7|qs_arg_list eppap pr7|qs_arg_list tsx1 |[get_our_lp] stcd sp|stack_frame.return_ptr callsp |[unpack_picture_] lreg sp|8 epp4 sp|ps_ptr,* restore ptr registers epp5 pr4|ps.format_area_p,* epp1 pr5|plio_sb.space_ptr,* epp3 pr1|156 let pr3->result of unpacking,which a_to_a will use as source ptr ldq sp|source_val_scaleprec scale-prec of source in q, for a_to_a call lxl7 sp|source_val_type also for a_to_a call tra 0,0 and return to sender " decode_pic_type: dec 42 char dec 18 real fix dec dec 22 cmplx fix dec dec 20 real fl dec dec 24 cmplx fl dec not_pic_source: lrl 12 at this point a has the descr & we must extract scale-prec qrl 6 scale is in 2nd 3rd of word, prec in 3rd 3rd lrl 12 qrl 6 stq sp|source_val_scaleprec scale is now in top 1/2 of q,prec in lower 1/2 als 25 now extract the type field, adding to it the "packed" bit arl 29 sta sp|source_val_type pr3 ->source val, all nice for a_to_a epp3 pr4|ps.value_p,* ass_source_to_intermed: ldq sp|source_val_scaleprec whether or not source is original or unpacked, now we convert it lxl7 sp|source_val_type to the intermediate value specified by the picture format ass_pic_source_to_intermed: epp1 pr5|plio_sb.space_ptr,* if we come from unpack_pic, q & x7 were already set epp7 pr1|48 set up the rest of the registers for a_to_a epp1 pr1|16 lda sp|int_val_scaleprec ldx6 sp|int_val_type these are the conversion's target's scale-prec & type lxl1 pr5|plio_sb.cplx_flags tze 2,ic adx6 4,du if imag part of c_format,force interm val to cplx epp5 pr7|0 this is ptr to work area eax1 |[any_to_any_] this is proper entry to call tsx0 ata_call_and_ret and do the conversion " epp2 pr1|16 set pr2->output of conversion lda pr5|plio_sb.cplx_flags if imag part of cplx we must skip real part tze image_pic_merge eax0 1 we will skip 1 char for the exponent byte if dec float ldx6 sp|int_val_type find out type cmpx6 D_float_real_desc decimal float? tnz 2,ic if not, just skip 1 extra byte for sign char, must be fixed decimal a9bd pr2|0,x0 skip exponent byte a9bd pr2|0,x0 skip sign byte lda sp|int_val_scaleprec skip body of real value now a9bd pr2|0,al no mask needed to elim scale cause al takes only lower image_pic_merge: " now call pack_picture for the final cconversion spri1 pr1|qs_arg_list+2 arg1 is ptr to where to put resulting output string epp7 sp|double_temp,* double temp has ptr to picture description of p_format, remember spri7 pr1|qs_arg_list+4 which is arg2 spri2 pr1|qs_arg_list+6 arg3 is ptr ot source to be packed sreg sp|8 set up the 3 argument call fld 3*2048,dl staq pr1|qs_arg_list eppap pr1|qs_arg_list tsx1 |[get_our_lp] stcd sp|stack_frame.return_ptr callsp |[pack_picture_] lreg sp|8 restore registers and pointer regs epp4 sp|ps_ptr,* epp5 pr4|ps.format_area_p,* epp3 pr5|plio_sb.space_ptr,* epp2 pr3|0 pr2 should point to output string to be put out epp7 sp|double_temp,* now calculate length of output for put_field ldq pr7|1 which is found in pic_image.varlength qrl pic_image.varlength_shift tra pr5|plio_sb.pef_finish,* and we're done with this exercise in the sublime " subroutine to decode a picture's descriptor,entered with pr1->picutre's " image and exited with the scale-prec in a and type in x6 " decode_pic_desc: ldq pr1|0 get the pic_image type & decode it with use of the "decode_pic_type" table qrl pic_image.type_shift lxl6 decode_pic_type-24,ql cmpx6 char_desc,du now the decoded type is in x6, so extract the scale-prec tze char_desc_decode if its a char type there is only a length, no scale-prec lda pr1|0 else extract the scale-prec arl pic_image.scale_shift ana =o000000000777 ldq pr1|1 now scale is in lowest byte of a,get prec in q & merge them qrl pic_image.scalefactor_shift but first must handle the scalefactor, just in case there is one anq pic_image.mask,dl stq sp|temp store the scalefactor in sp|temp sba sp|temp and subtract it from the scale ldq pr1|0 now get the precision, at last anq =o000777,du and move it to the a with scale in top 1/2 of a lls 18 tra 0,1 and we're done & return to he who tsx1'd to us char_desc_decode: lda pr1|1 get the length from the pic image, leave it in the a arl 27 tra 0,1 and return " " This subroutine checks that plio_sb.nval>0, if not it raises an error, if it " is it leaves the value of it in the q. It is tsx6'd to, and clobbers only the q. " check_for_param: ldq pr5|plio_sb.nval tpnz 0,6 lda 10,dl tra |[any_qs_error_no_ret] " " operator to terminate a put " put_terminate: eax6 1 set proc to call tra |[plio4] " minus_char: oct 055000000000 " even null_loc: its -1,1,n this is where we get "null" for argument ptrs which should be null end  record_io_.alm 11/11/89 1150.6rew 11/11/89 0803.9 73782 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Operator to interface with record I/O programs. Entered with job in register a. " Bulk of code is to handle quick record i/o. name record_io_ include stack_frame include iocbx include plio2_psr include plio2_fsb equ io_arg_list,52 all equ's in this program come from pl1_operators_ equ tbp,38 loc of ptr to base of text equ ps_ptr,42 loc of ptr to PS equ t6,44 equ t7,45 equ double_temp,46 equ t3,51 " " The following declarations may be removed when a " fsbr include file is generated. " equ fsbr.recio,fsb.lsep these overlay same word bool fsbr.rec_valid,200000 " segdef record_io " " Program to filter "quick" record I/O operations from "slow" ones. " Calling sequence: " lda job_bits " tsx0 ap|record_io_op " record_io: eppap sp|ps_ptr,* spribp ap|psr.ab_return sprisp ap|psr.ab_return+2 sta ap|psr.job save the job bits cana psr.version_mask_inplace,dl check version tze slow we only handle version>0 ana =v18/-1-psr.explicit_file-psr.varying_string,18/-1-psr.key-psr.keyto-psr.keyfrom-psr.version_mask_inplace cmpa =v18/psr.read,18/psr.into tnz 3,ic eax1 0 = read stmnt tra quick cmpa =v18/psr.write,18/psr.from tnz 3,ic eax1 1 = write stmnt tra quick cmpa =v18/psr.rewrite,18/psr.from tnz 3,ic eax1 2 = rewrite stmnt tra quick cmpa psr.delete,dl tnz slow eax1 3 = delete stmnt " quick: epp4 ap|psr.source_p,* now to get fsb bits epp4 pr4|2,* fsb ptr is 2 wds up spri4 ap|psr.fsbp lda pr4|fsb.switch ana =v18/-1-fsb.zot1-fsb.zot2-fsb.not_used_1,18/-1-fsb.detach-fsb.iox_close ldq ap|psr.job we need unclobbered job bits canq psr.key+psr.keyto+psr.keyfrom,dl tnz keyed_job " good_key: eax6 0 x6=1 if stringvalue canq psr.varying_string,du tze not_var cana fsb.stringvalue,du tze slow eax6 1 stringvalue " not_var: ana =v18/-1-fsb.version_2-fsb.stringvalue,18/-1-fsb.implementation-fsb.internal-fsb.threaded cmpa fsb_masks,1 tze action,1 cmpx1 2,du still could be read/update or write/update tpl slow cmpa fsb_masks+2 is it read or write update? tze action,1 tra slow " fsb_masks: zero fsb.open+fsb.input+fsb.notkeyed+fsb.record+fsb.sequential,fsb.emptyline zero fsb.open+fsb.output+fsb.notkeyed+fsb.record+fsb.sequential,fsb.emptyline zero fsb.open+fsb.update+fsb.notkeyed+fsb.record+fsb.sequential,fsb.emptyline oct 042700000020 open/update/threaded/emptyline (NU) " action: tra quick_read tra quick_write tra quick_write " quick_delete: fld 2048*2,dl staq sp|io_arg_list epp3 sp|t3 tra dl_too " quick_write: fld 2*1024*4,dl staq sp|io_arg_list cmpx6 0,du stringvalue? tze simple_length epp3 ap|psr.variable_p,* ldq pr3|-1 length field tra make_call " quick_read: fld 2*1024*5,dl arg_list header = 2*number of args staq sp|io_arg_list epp3 sp|t7 t7 = status code of read stmnt spri3 sp|io_arg_list+10 " simple_length: ldq ap|psr.variable_bitlen div 9,dl byte_length " make_call: stq sp|t6 t6 = length (output to iox_) epp3 sp|t3 t3 = length(read stmnt),status(other) spri3 sp|io_arg_list+8 epp3 sp|t6 spri3 sp|io_arg_list+6 epp3 ap|psr.variable_p " dl_too: spri3 sp|io_arg_list+4 lprp5 pr4|fsb.iocb_p p4->fsb, offset iocb_p (packed ptr) spri5 sp|double_temp packed ptr must become unpacked epp3 sp|double_temp spri3 sp|io_arg_list+2 eaa 0,1 als 2 to multiply x1*4(4 words per entry var) eppbp pr5|iocb.read_record,au* bp -> the correct entry var. in iocb sreg sp|8 eppap sp|io_arg_list stcd sp|stack_frame.return_ptr callsp bp|0 lreg sp|8 cmpx1 0,du read? tze read_rtn lda sp|t3 check status code(not read stmnt) tze ret_to_caller epp3 sp|t3 get ptr to status for error call " error_call: spri3 sp|io_arg_list+4 2nd arg is status code sreg sp|8 be prepared for a return from error fld 2*1024*2,dl staq sp|io_arg_list eppbp sp|ps_ptr 1st arg is ptr to ps spribp sp|io_arg_list+2 eppap sp|io_arg_list tsx1 |[get_our_lp] stcd sp|stack_frame.return_ptr callsp |[error] lreg sp|8 tra ret_to_caller " read_rtn: lda sp|t7 tnz read_error if status^=0 its an error epp4 sp|ps_ptr,* ap has been clobbered & we must get ps epp4 pr4|psr.fsbp,* lda fsbr.rec_valid,du since it was a successful read, set flag orsa pr4|fsbr.recio lda sp|t3 get returned length cmpx6 1,du stringvalue? tnz check_len epp3 sp|io_arg_list+4,* get ptr to target variable epp3 pr3|0,* sta pr3|-1 put returned length in length field of target var " ret_to_caller: eppap sp|tbp,*0 spriap sp|stack_frame.return_ptr eppap |[operator_table] tra sp|tbp,*0 " check_len: cmpa sp|t6 targ.len.=returned length? tze ret_to_caller if they're equal we're through " read_error: epp3 sp|t7 get ptr to status for error call tra error_call " slow: eax6 7 tra |[plio4] " keyed_job: ana =o077625573567 zero zots,v2,seq,dir,buf'd,str_val,env,threaded,detach,iox_closeHELP!!! canq psr.keyto,dl tze seek_key_call cant be a read keyto eax1 4 table lookup for a read_keyto job string eax6 5 will be a call to read_key ldq =v18/-1-psr.keyto_keyset,18/-1 turn keyset flag OFF ansq ap|psr.pl1_ops_flags keyset is zero till keytemp is filled tra seek_key_call+1 " seek_key_call: eax6 4 will be a call to seek_key cmpa fsb_key_masks,1 tze key_call cmpx1 2,du could be read/key or write/keyfrom on update file tmi 3,ic cmpx1 4,du could be read/keyto on update file tnz slow cmpa fsb_key_masks+2 tze key_call tra slow give up " fsb_key_masks: zero fsb.open+fsb.input+fsb.record+fsb.keyed,fsb.emptyline READ KEY zero fsb.open+fsb.output+fsb.record+fsb.keyed,fsb.emptyline WRITE KEY zero fsb.open+fsb.update+fsb.record+fsb.keyed,fsb.emptyline REWRITE KEY zero fsb.open+fsb.update+fsb.record+fsb.keyed,fsb.emptyline DELETE KEY zero fsb.open+fsb.input+fsb.record+fsb.keyed,fsb.emptyline READ KEYTO " key_call: fld 2*1024*4,dl 4 arguments for seek_ or read_key staq sp|io_arg_list epp3 ap|psr.keytemp+1 the addr of a var str is not its start spri3 sp|io_arg_list+4 arg2 is the key epp3 sp|t6 spri3 sp|io_arg_list+6 arg3 is rtned length,we ignore lprp5 pr4|fsb.iocb_p p4->fsb, offset iocb_p (packed ptr) spri5 sp|double_temp packed ptr must become unpacked epp3 sp|double_temp spri3 sp|io_arg_list+2 arg1 \is iocb_ptr eaa 0,6 use x6 to get right entry var. als 2 to multiply x6*4(4 words per entry var) eppbp pr5|iocb.read_record,au* bp -> the correct entry var. in iocb epp3 sp|t3 status code spri3 sp|io_arg_list+8 arg4is of course status code sreg sp|8 eppap sp|io_arg_list stcd sp|stack_frame.return_ptr callsp bp|0 lreg sp|8 cmpx1 1,du fancy stuff only if a write tnz not_key_write handle non-writes differently tsx1 |[get_our_lp] ldq |[no_record] cmpq sp|t3 must be new key to be right tnz key_error if key was there its an error eax1 1 restore x1 to 1 for write tra key_ok " not_key_write: ldq sp|t3 returned status code tnz key_error if not zero its an error cmpx1 4,du read keyto? tze keyto_done " key_ok: eppap sp|ps_ptr,* restore the stuff we clobbered ldq ap|psr.job epp4 ap|psr.fsbp,* get fsbp again lda pr4|fsb.switch ana =o177726773767 zero zots,n_used1,dir,key,detach,iox_close HELP!!! ora fsb.notkeyed+fsb.sequential,du tra good_key now its looks like a unkeyed io op " keyto_done: eax1 0 if read-keyto restore x1 to 0 for read lda psr.keyto_keyset,du eppap sp|ps_ptr,* ap has been clobbered,need to get at ps orsa ap|psr.pl1_ops_flags set keyset bit on, assgnmt has been made tra key_ok+1 " key_error: epp3 sp|t3 get ptr to status for error call tra error_call end  sine_.alm 11/11/89 1150.6rew 11/11/89 0805.6 50661 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name sine_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7nba'. " " Function: Approximate to single precision the sine or cosine of an " angle given in degrees or radians. " " Entry: through the appropriately named entry point with: " EAQ = the angle whose sine or cosine is desired. " PR2 = the address of a 12 word, even-word aligned scratch area. " 4 words are used in this program and 12 are used by the " routine "principal_angle_". The storage for sine_ and " principal_angle_ overlap. " PR3 = the return address. " " Exit: EAQ = the desired sine or cosine. " " Uses: X0, X1, X2. " X0 = saves a return address from principal_angle_ routines " X1 = shift (returned by principal_angle_ routines) " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. " The principal_angle_ routines use registers X1 and X2. " segref math_constants_,half_pi,one_degree,pi segref principal_angle_,principal_radians_,principal_degrees_ equ BFP,0 equ HFP,2 equ x,0 equ xx,2 segdef cosine_degrees_,hfp_cosine_degrees_ segdef cosine_radians_,hfp_cosine_radians_ segdef sine_degrees_,hfp_sine_degrees_ segdef sine_radians_,hfp_sine_radians_ hfp_cosine_degrees_: eax2 HFP " 2 word offset for HFP constants tra cosine_degrees cosine_degrees_: eax2 BFP " no offset for BFP constants cosine_degrees: fad =0.0,du " normalize input fcmg one_eighty,x2 " if abs_angle <= 180: tmi case1_degrees " then no angle reduction is necessary tsx0 principal_degrees_ tra case_degrees+1,x1 " select appropriate case hfp_cosine_radians_: eax2 HFP " 2 word offset for HFP constants tra cosine_radians cosine_radians_: eax2 BFP " no offset for BFP constants cosine_radians: fad =0.0,du " normalize input and set indicators fcmg pi,x2 " if abs (angle) <= pi tmi case1_radians " then no angle reduction is necessary tsx0 principal_radians_ tra case_radians+1,x1 " select appropriate case hfp_sine_degrees_: eax2 HFP " 2 word offset for HFP constants tra sine_degrees sine_degrees_: eax2 BFP " no offset for BFP constants sine_degrees: fad =0.0,du " normalize input fcmg ninety,x2 " if abs (angle) < pi/2 tmi case0_degrees " then no angle reduction is necessary tsx0 principal_degrees_ tra case_degrees,x1 " select appropriate case hfp_sine_radians_: eax2 HFP " 2 word offset for HFP constants tra sine_radians sine_radians_: eax2 BFP " no offset for BFP constants sine_radians: fad =0.0,du " normalize input fcmg half_pi,x2 " if abs (angle) <= pi/2 tmoz case0_radians " then no angle reduction is necessary tsx0 principal_radians_ tra case_radians,x1 " Case select appropriate case_radians case_radians: tra case0_radians tra case1_radians tra case2_radians tra case3_radians tra case0_radians case1_radians: fad =0.0,du " set indicators tmi 2,ic " EAQ = - abs (EAQ) negl 0 " fneg underflows at o400400000000 dfad half_pi1,x2 dfad half_pi2,x2 tra part_sine_radians case2_radians: fneg 0 tra part_sine_radians case3_radians: fad =0.0,du " set indicators tpl 2,ic " EAQ = abs (EAQ) fneg 0 dfsb half_pi1,x2 dfsb half_pi2,x2 tra part_sine_radians case_degrees: tra case0_degrees tra case1_degrees tra case2_degrees tra case3_degrees tra case0_degrees case1_degrees: fad =0.0,du " set indicators tmi 2,ic " EAQ = - abs (EAQ) negl 0 " fneg underflows at o400400000000 fad ninety,x2 tra part_sine_degrees case2_degrees: fneg 0 tra part_sine_degrees case3_degrees: fad =0.0,du " set indicators tpl 2,ic " EAQ = abs (EAQ) fneg fsb ninety,x2 " tra part_sine_degrees case0_degrees: " case0_degrees is just part_sine_degrees part_sine_degrees: dfcmg eps2,x2 " if conversion to radians underflows tpl 2,ic fld =0.0,du " then use zero dfmp one_degree,x2 " convert to radians. " tra part_sine_radians case0_radians: " case0_radians is just part_sine_radians " Procedure part_sine_radians (x) calculates 'sin(x)' for 'x' in the range " [-pi/2, pi/2] given 'x' in the EAQ. part_sine_radians: dfcmg eps3,x2 " if abs (x) < 5e-10: tpl 3,ic frd 0 tra pr3|0 " sine is x for small x dfst pr2|x dfmp pr2|x " calculate xx = x*x dfst pr2|xx fmp p5,x2 " calculate p(xx) dfad p4,x2 fmp pr2|xx dfad p3,x2 fmp pr2|xx dfad p2,x2 fmp pr2|xx dfad p1,x2 dfmp pr2|xx dfad p0,x2 dfmp pr2|x " return x*p(xx) frd 0 tra pr3|0 " Constants: even eps1: dec 1.886591d-8 oct 764242035115,000000000000 eps2: dec 8.418858142948452884d-38 oct 402162456701,514360373670 " 2.670821537926801391d-154 eps3: dec 5.0d-10 oct 762104560276,404665512263 half_pi1: oct 002622077325,042055060432 " 1.570796326794896619d0 oct 002062207732,504205506043 " 1.570796326794896619d0 half_pi2: oct 602611431424,270033407150 " 8.333742918520878328d-20 oct 742461143142,427003340714 " 5.170182981794105568d-19 ninety: dec 90.0d0 oct 004264000000,000000000000 one_eighty: dec 180.0d0 oct 004550000000,000000000000 p0: dec 9.999999999788d-1 oct 000777777777,776426056601 p1: dec -1.6666666608826d-1 oct 001652525252,575051425416 p2: dec 8.333330720556d-3 oct 776104210413,351265306744 p3: dec -1.98408328231d-4 oct 773137720534,017765224715 p4: dec 2.7523971068d-6 oct 770134265644,770436615640 p5: dec -2.386834641d-8 oct 765462761716,000402576424 end  square_root_.alm 11/11/89 1150.6rew 11/11/89 0805.2 37044 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name square_root_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on the GCOS routine '7nbb'. " " Function: Approximate to single precision the square root of a number. " " Entry: through the appropriately named entry point with: " EAQ = the number whose square root is desired. " PR2 = the address of an 8 word, even-word aligned scratch area. " PR3 = the return address. " " Exit: EAQ = the desired square root. " " Uses: X0, X1 " X0 = temporary storage for exponent of input argument " and saves a return address from call_math_error_ " X1 = index to scale table equ BFP,0 equ HFP,2 equ root_m,0 equ x,2 equ m,4 equ e,6 bool P0.25H,000200 " yields HFP +0.25 under 'du' modification bool P4.0H,002200 " yields HFP +4.0 under 'du' modification segdef square_root_,hfp_square_root_ square_root_: fad =0.0,du " normalize input arg tze pr3|0 " if x = 0 return (0) tpl calc_square_root " if x < 0: fneg 0 " x = -x fst pr2|x ldq 13,dl tsx0 |[call_math_error_] fld pr2|x " calculate sqrt (abs(x)) calc_square_root: fst pr2|x " store EA := input arg ldx0 pr2|x " X0 := addr (x) -> expon " m = x lde =0b25,du " addr (m) -> expon = 0 canx0 =1b25,du " calculate mod (e, 2) tze 2,ic " if mod (e, 2) = 1: lde =-1b25,du " EA := m = .5*m ldq pr2|x " Q := 8/expon,28/garbage qrs 28 " Q := 28/0,8/expon adq =1,dl " calculate e+1 qrs 1 " calculate divide (e+1, 2, 7) qls 28 " position result in exponent field stq pr2|e " store Q := e = divide (e+1, 2, 7) ldq =0 " clear Q dfst pr2|m " store EAQ := m fmp p2 " calculate root_m = p(m) fad p1 fmp pr2|m fad p0 fst pr2|root_m fdi pr2|m " calculate root_m = .5 * (root_m + m/root_m) fad pr2|root_m fmp =0.5,du dfst pr2|root_m " calculate root_m + float (m, 63)/root_m dfdi pr2|m dfad pr2|root_m ade =-1b25,du " root_m = .5 * (root_m + float (m, 63)/root_m) " root_x = root_m ade pr2|e " calculate addr (root_x) -> expon = " addr (root_x) -> expon + divide (e+1, 2, 7) frd 0 tra pr3|0 " return (root_x) hfp_square_root_: fad =0.0,du " normalize input arg tze pr3|0 " if x = 0 return (0) tpl hfp_calc_square_root " if x < 0: fneg 0 " x = -x fst pr2|x ldq 13,dl tsx0 |[call_math_error_] fld pr2|x " calculate sqrt (abs(x)) hfp_calc_square_root: fst pr2|x " store EA := input arg ldx0 pr2|x " X0 := addr (x) -> expon " m = x lde =0b25,du " addr (m) -> expon = 0 eax1 0 " scale = 0.5 fcmp P0.25H,du tpl 3,ic " if m >= .25: scale = 0.5 eax1 2 " else: scale = 0.25 fmp P4.0H,du " EA := m = 4*m canx0 =1b25,du " calculate mod (e, 2) tze 2,ic " if mod (e, 2) = 1: adx1 =1,du " scale = 0.25*scale ldq pr2|x " Q := 8/expon,28/garbage qrs 28 " Q := 28/0,8/expon adq =1,dl " calculate e+1 qrs 1 " calculate divide (e+1, 2, 7) qls 28 " position result in exponent field stq pr2|e " store Q := e = divide (e+1, 2, 7) ldq =0 " clear Q dfst pr2|m " store EAQ := m fmp hfp_p2 " calculate root_m = p(m) fad hfp_p1 fmp pr2|m fad hfp_p0 fst pr2|root_m fdi pr2|m " calculate root_m = .5 * (root_m + m/root_m) fad pr2|root_m fmp =0.5,du dfst pr2|root_m " calculate root_m + float (m, 63)/root_m dfdi pr2|m dfad pr2|root_m fmp scale,x1 " root_m = scale * (root_m + float (m, 63)/root_m) " root_x = root_m ade pr2|e " calculate addr (root_x) -> expon = " addr (root_x) -> expon + divide (e+1, 2, 7) frd 0 tra pr3|0 " return (root_x) even p0: dec 2.5927688d-1 hfp_p0: oct 000204577702,000000000000 p1: dec 1.0521212d0 hfp_p1: oct 002041525750,000000000000 p2: dec -3.1632214d-1 hfp_p2: oct 001536026031,000000000000 scale: oct 000400000000 " 0.5 oct 000100000000 " 0.25*0.5 = 0.125 oct 000200000000 " 0.25 oct 000040000000 " 0.25*0.25 = 0.0625 end  tangent_.alm 11/11/89 1150.6rew 11/11/89 0805.6 61605 " ****************************************** " * * " * Copyright, (C) Honeywell Limited, 1985 * " * * " ****************************************** name tangent_ " Modification history: " Written by H. Hoover, M. Mabey, and B. Wong, April 1985, " based on GCOS routine '7nbc'. " " Function: Approximate to single precision the tangent or cotangent of an " angle given in degrees or radians. " " Entry: through the appropriately named entry point with: " EAQ = the angle whose tangent is desired. " PR2 = the address of a 12 word, even-word aligned scratch area. " 6 words are used in this program and 12 are used by the " routine "principal_angle_". The storage for tangent_ and " principal_angle_ overlap. " PR3 = the return address. " " Exit: EAQ = the desired tangent or cotangent. " " Uses: X0, X1, X2, X3. " X0 = saves a return address from principal_angle_ routines " X1 = shift (returned by principal_angle_ routines) " X2 = indicates BFP or HFP mode - all the floating point math " routines use this register for the same purpose. " X3 = indicates Tangent or Cotangent function " The principal_angle_ routines use registers X1 and X2. segref math_constants_,max_value,one_degree,quarter_pi segref principal_angle_,principal_radians_,principal_degrees_ equ BFP,0 equ HFP,2 equ Cotangent,-1 equ Tangent,1 equ sign,0 equ x,0 equ xx,2 equ q,4 segdef cotangent_degrees_,hfp_cotangent_degrees_ segdef cotangent_radians_,hfp_cotangent_radians_ segdef tangent_degrees_,hfp_tangent_degrees_ segdef tangent_radians_,hfp_tangent_radians_ hfp_cotangent_degrees_: eax2 HFP " 2 word offset for HFP constants tra cotangent_degrees cotangent_degrees_: eax2 BFP " no offset for BFP constants cotangent_degrees: fad =0.0,du " normalize input eax1 0 " initialize X1 := shift = 1 fcmg forty_five,x2 tmoz 2,ic " if abs (angle) > 45: tsx0 principal_degrees_ " call principal_degrees_ dfcmg eps1,x2 " if conversion to degrees underflows tmi infinity " return (infinity (degrees)) " else: dfmp one_degree,x2 " EAQ := degrees * one_degree canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Cotangent " X3 := Cotangent tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, degrees*one_degree)) " else if shift = 1 | shift = 3 eax3 Tangent " X3 := Cotangent fneg 0 " EAQ := -degrees*one_degree tra part_tan_or_cot " return (part_tan_or_cot (Tangent, -(degrees*one_degree))) hfp_cotangent_radians_: eax2 HFP " 2 word offset for HFP constants tra cotangent_radians cotangent_radians_: eax2 BFP " no offset for BFP constants cotangent_radians: fad =0.0,du " normalize input fcmg quarter_pi,x2 tpl 3,ic " if abs (angle) > quarter_pi: eax3 Cotangent " X3 := Cotangent tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, radians) tsx0 principal_radians_ " call principal_radians_ canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Cotangent " X3 := Cotangent tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, radians)) " else if shift = 1 | shift = 3 eax3 Tangent " X3 := Cotangent fneg 0 " EAQ := -radians tra part_tan_or_cot " return (part_tan_or_cot (Tangent, -radians)) hfp_tangent_degrees_: eax2 HFP " 2 word offset for HFP constants tra tangent_degrees tangent_degrees_: eax2 BFP " no offset for BFP constants tangent_degrees: fad =0.0,du " normalize input eax1 0 " initialize X1 := shift = 1 fcmg forty_five,x2 tmoz 2,ic " if abs (angle) > 45: tsx0 principal_degrees_ " call principal_degrees_ dfcmg eps1,x2 " if conversion to radians underflows tpl 2,ic fld =0.0,du " then use zero " else: dfmp one_degree,x2 " EAQ := degrees * one_degree canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Tangent " X3 := Tangent tra part_tan_or_cot " return (part_tan_or_cot (Tangent, degrees*one_degree)) " else if shift = 1 | shift = 3 eax3 Cotangent " X3 := Cotangent fneg 0 " EAQ := -radians tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, -(degrees*one_degree))) hfp_tangent_radians_: eax2 HFP " 2 word offset for HFP constants tra tangent_radians tangent_radians_: eax2 BFP " no offset for BFP constants tangent_radians: fad =0.0,du " normalize input fcmg quarter_pi,x2 tpl 3,ic " if abs (angle) <= quarter_pi: eax3 Tangent tra part_tan_or_cot " return (part_tan_or_cot (Tangent, radians)) tsx0 principal_radians_ " call principal_radians_ canx1 =1,du tnz 3,ic " if shift = 0 | shift = 2: eax3 Tangent " X3 := Tangent tra part_tan_or_cot " return (part_tan_or_cot (Tangent, radians)) " else if shift = 1 | shift = 3 eax3 Cotangent " X3 := Cotangent fneg 0 " EAQ := -radians " tra part_tan_or_cot " return (part_tan_or_cot (Cotangent, -radians)) " Procedure 'part_tan_or_cot' (function, x) calculates either 'tan(x)' " or 'cot(x)' to double precision accuracy, for 'x' in [-pi/4, pi/4]. " Argument 'x' is given in the EAQ and the function to be calculated is " given in X3. X3=-1 indicates 'cot' and X3=1 indicates 'tan'. part_tan_or_cot: fcmg eps2 " if abs(x) < 5e-10: tpl use_polynomial cmpx3 Tangent,du " if function = Tangent tnz 3,ic frd 0 " then return (result) tra pr3|0 dfcmg eps3,x2 " else if (1/result) overflows tmoz infinity " then return (infinity (result)) fdi one,x2 " else return (1/result) tra pr3|0 use_polynomial: dfstr pr2|x dfmp pr2|x " calculate xx = x*x dfstr pr2|xx dfad q1,x2 " calculate q = q(xx) dfmp pr2|xx dfad q0,x2 dfstr pr2|q dfld pr2|xx " calculate p(xx) dfmp p2,x2 dfad p1,x2 dfmp pr2|xx dfad p0,x2 dfmp pr2|x " calculate p = x*p(xx) cmpx3 Tangent,du tnz 4,ic " if function = Tangent dfdv pr2|q " then return (p/q) frd 0 tra pr3|0 dfdi pr2|q " else return (q/p) frd 0 tra pr3|0 infinity: fst pr2|sign fld max_value fad max_value " signal overflow fld max_value fszn pr2|sign " if sign >= 0 tpl pr3|0 " then return (max_value) fneg 0 " else return (-max_value) tra pr3|0 " Constants: even eps1: dec 8.418858142948452884d-38 oct 402162456701,514360373670 " 2.670821537926801391d-154 eps2: dec 5.0d-10 oct 762104560277,000000000000 eps3: oct 404400000000,000000000001 oct 404040000000,000000000001 forty_five: dec 45.0d0 oct 004132000000,000000000000 one: dec 1.d0 oct 002040000000,000000000000 p0: dec 6.26041119547433196d1 oct 004175152470,514027661141 p1: dec -6.97168400629442048d0 oct 003440717733,612726504236 p2: dec 6.73091025875915d-2 oct 000042354532,645307136212 q0: dec 6.260411195336057284d1 oct 004175152470,513531633022 q1: dec -2.78397212200427089d1 oct 005710244100,173305062557 end  template_area_header.cds 11/11/89 1150.6rew 11/11/89 0804.2 15390 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ template_area_header: proc; /* Automatic */ dcl 1 template_area aligned, 2 template_area_header aligned like area_header; dcl 1 cdsa aligned like cds_args; dcl code fixed bin (35); /* Builtin */ dcl (null, unspec, bit, bin, size, addr, string) builtin; /* Entries */ dcl create_data_segment_ entry (ptr, fixed bin (35)); /* */ unspec (template_area) = "0"b; template_area.version = 1; template_area.next_virgin = bit (bin (size (template_area), 18), 18); template_area.last_size = bit (bin (2, 18), 18); template_area.last_block = bit (bin (size (template_area)-2, 18), 18); /* Now call data base create program */ cdsa.sections (1).p = addr (template_area); cdsa.sections (1).len = size (template_area); cdsa.sections (1).struct_name = "template_area"; cdsa.seg_name = "template_area_header"; cdsa.num_exclude_names = 0; cdsa.exclude_array_ptr = null;; string (cdsa.switches) = "0"b; cdsa.switches.have_text = "1"b; call create_data_segment_ (addr (cdsa), code); return; /* */ %include area_structures; %include cds_args; end;  wired_utility_.alm 11/11/89 1150.6r w 11/11/89 0804.6 56799 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " include stack_header " include stack_frame " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " caller " " " " Primitive to return a pointer to the caller of the " " program which called this primitive. " " " " Usage: " " " " caller_ptr = wired_utility$caller (); " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef caller caller: eppbp sp|stack_frame.prev_sp,* get ptr to previous stack frame eppbp bp|stack_frame.return_ptr,* get caller spribp ap|2,* return the pointer short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " stacq " " " " Primitive to perform an stacq function analogous " " to the stac builtin function. " " " " Usage: " " " " bit_1 = stacq (word_ptr, old_value, new_value); " " " " word_ptr is a pointer to the word to change " " new_value is the new value to place in the word if " " old_value is the current contents of the word. " " " " If the current contents of the word pointed to by word_ptr " " is not the same as old_value the function returns "0"b, " " if they match the function returns "1"b. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef stacq stacq: ldq ap|4,* fetch the expected old value lda ap|6,* fetch the new value to store in the cell eppbp ap|2,* get pointer to input pointer stacq bp|0,* try to store the new value in the cell tze success if zero indicator set, the store went through (matched old value) stz ap|8,* return "0"b short_return success: lda =o400000,du return "1"b sta ap|8,* short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " ldac " " " " Primitive to use ldac instruction to load and clear a word " " using one memory operation. " " " " Usage: " " " " word = ldac (word_ptr); " " " " word_ptr is a pointer to the word to load and clear " " word receives contents of the word pointed to by word_ptr " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef ldac ldac: eppbp ap|2,* get pointer to input pointer ldac bp|0,* load and clear the word sta ap|4,* return the value of the word short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_sp " " " " Primitive to return the current value of sp to the caller " " " " Usage: " " " " sp = wired_utility_$get_sp; " " " " sp will receive the value of the stack pointer " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef get_sp get_sp: sprisp ap|2,* return the value of sp to the caller short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " grow_stack_frame " " shrink_stack_frame " " " " Primitives to increase and decrease the size of the " " caller's stack frame. Use these entries with care! " " " " Usage: " " " " p = wired_utility_$grow_stack_frame (size); " " call wired_utility_$shrink_stack_frame (endp); " " " " grow_stack_frame will increase the stack fame by size words " " and return a pointer to the previous end of the frame. " " shrink stack_frame will shrink the frame back to the " " supplied endp. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef grow_stack_frame segdef shrink_stack_frame grow_stack_frame: eppbp sb|stack_header.stack_end_ptr,* bp -> end of frame spribp ap|4,* return end pointer lda ap|2,* get size to grow frame eaa bp|0,al AU is new end pointer adjust_stack_frame: eaa 15,au round to 0 mod 16 ana =o777760,du .. eawpbp 0,au bp -> new end of frame spribp sb|stack_header.stack_end_ptr set new end of frame spribp sp|stack_frame.next_sp spribp sp|4 set for PL/1 short_return shrink_stack_frame: eppbp sb|stack_header.stack_end_ptr,* bp -> end of frame eppbb ap|2,* bb -> new end point eaa bb|0,* stack end offset in AU tra adjust_stack_frame use common code " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_ring_ - this entry returns the number of the current ring " " declare get_ring_ entry(fixed bin(3)); " call get_ring_(ring); " " 1. ring the number of the current ring. (Output) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef get_ring_ get_ring_: epaq * get ring number from effective pointer ana =o7,dl leave only ring number in a-reg sta ap|2,* return to caller short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_count_ - this entry returns the number of arguments with which the " calling procedure was invoked. " " declare arg_count_ entry(fixed bin); " call arg_count_(args); " " 1. args the number of arguments. (Output) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef arg_count_ arg_count_: lda sp|stack_frame.arg_ptr,* get argument list header arl 18+1 shift right and divide by two sta ap|2,* store in argument short_return """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " arg_list_ptr_ " " declare arg_list_ptr entry returns (pointer); " alp = arg_list_ptr_ (); " """""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" segdef arg_list_ptr_ arg_list_ptr_: epp1 sp|stack_frame.arg_ptr,* Pointer to arglist header spri1 ap|2,* short_return end bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved