Upload

Digital Research

CPM OPERATING SYSTEMS/CPM 68K/1.2 SOURCE/7/FFPADD.S

@@ -0,0 +1,220 @@
+       ttl     fast floating point add/subtract (ffpadd/ffpsub)
+***************************************
+* (c) copyright 1980 by motorola inc. *
+***************************************
+ 
+*************************************************************
+*                  ffpadd/ffpsub                            *
+*             fast floating point add/subtract              *
+*                                                           *
+*  ffpadd/ffpsub - fast floating point add and subtract     *
+*                                                           *
+*  input:                                                   *
+*      ffpadd                                               *
+*          d6 - floating point addend                       *
+*          d7 - floating point adder                        *
+*      ffpsub                                               *
+*          d6 - floating point subtrahend                   *
+*          d7 - floating point minuend                      *
+*                                                           *
+*  output:                                                  *
+*          d7 - floating point add result                   *
+*                                                           *
+*  condition codes:                                         *
+*          n - result is negative                           *
+*          z - result is zero                               *
+*          v - overflow has occured                         *
+*          c - undefined                                    *
+*          x - undefined                                    *
+*                                                           *
+*           registers d3 thru d5 are volatile               *
+*                                                           *
+*  code size: 228 bytes       stack work area:  0 bytes     *
+*                                                           *
+*  notes:                                                   *
+*    1) addend/subtrahend unaltered (d6).                   *
+*    2) underflow returns zero and is unflagged.            *
+*    3) overflow returns the highest value with the         *
+*       correct sign and the 'v' bit set in the ccr.        *
+*                                                           *
+*  time: (8 mhz no wait states assumed)                     *
+*                                                           *
+*           composite average  20.625 microseconds          *
+*                                                           *
+*  add:         arg1=0              7.75 microseconds       *
+*               arg2=0              5.25 microseconds       *
+*                                                           *
+*          like signs  14.50 - 26.00  microseconds          *
+*                    average   18.00  microseconds          *
+*         unlike signs 20.13 - 54.38  microceconds          *
+*                    average   22.00  microseconds          *
+*                                                           *
+*  subtract:    arg1=0              4.25 microseconds       *
+*               arg2=0              9.88 microseconds       *
+*                                                           *
+*          like signs  15.75 - 27.25  microseconds          *
+*                    average   19.25  microseconds          *
+*         unlike signs 21.38 - 55.63  microseconds          *
+*                    average   23.25  microseconds          *
+*                                                           *
+*************************************************************
+         page
+ffpadd idnt    1,1  ffp add/subtract
+ 
+       xdef    ffpadd,ffpsub   entry points
+       xref    ffpcpyrt        copyright notice
+ 
+         section  9
+ 
+************************
+* subtract entry point *
+************************
+ffpsub   move.b  d6,d4    test arg1
+         beq.s   fpart2   return arg2 if arg1 zero
+         eor.b   #$80,d4  invert copied sign of arg1
+         bmi.s   fpami1   branch arg1 minus
+* + arg1
+         move.b  d7,d5    copy and test arg2
+         bmi.s   fpams    branch arg2 minus
+         bne.s   fpals    branch positive not zero
+         bra.s   fpart1   return arg1 since arg2 is zero
+ 
+*******************
+* add entry point *
+*******************
+ffpadd   move.b  d6,d4    test argument1
+         bmi.s   fpami1   branch if arg1 minus
+         beq.s   fpart2   return arg2 if zero
+ 
+* + arg1
+         move.b  d7,d5    test argument2
+         bmi.s   fpams    branch if mixed signs
+         beq.s   fpart1   zero so return argument1
+ 
+* +arg1 +arg2
+* -arg1 -arg2
+fpals    sub.b   d4,d5    test exponent magnitudes
+         bmi.s   fpa2lt   branch arg1 greater
+         move.b  d7,d4    setup stronger s+exp in d4
+ 
+* arg1exp <= arg2exp
+         cmp.b   #24,d5   overbearing size
+         bcc.s   fpart2   branch yes, return arg2
+         move.l  d6,d3    copy arg1
+         clr.b   d3       clean off sign+exponent
+         lsr.l   d5,d3    shift to same magnitude
+         move.b  #$80,d7  force carry if lsb-1 on
+         add.l   d3,d7    add arguments
+         bcs.s   fpa2gc   branch if carry produced
+fparsr   move.b  d4,d7    restore sign/exponent
+         rts              return to caller
+ 
+* add same sign overflow normalization
+fpa2gc   roxr.l  #1,d7    shift carry back into result
+         add.b   #1,d4    add one to exponent
+         bvs.s   fpa2os   branch overflow
+         bcc.s   fparsr   branch if no exponent overflow
+fpa2os   moveq   #-1,d7   create all ones
+         sub.b   #1,d4    back to highest exponent+sign
+         move.b  d4,d7    replace in result
+*        or.b    #$02,ccr show overflow occurred
+         dc.l    $003c0002 ****assembler error****
+         rts              return to caller
+ 
+* return argument1
+fpart1   move.l  d6,d7    move in as result
+         move.b  d4,d7    move in prepared sign+exponent
+         rts              return to caller
+ 
+* return argument2
+fpart2   tst.b   d7       test for returned value
+         rts              return to caller
+ 
+* -arg1exp > -arg2exp
+* +arg1exp > +arg2exp
+fpa2lt   cmp.b   #-24,d5  ? arguments within range
+         ble.s   fpart1   nope, return larger
+         neg.b   d5       change difference to positive
+         move.l  d6,d3    setup larger value
+         clr.b   d7       clean off sign+exponent
+         lsr.l   d5,d7    shift to same magnitude
+         move.b  #$80,d3  force carry if lsb-1 on
+         add.l   d3,d7    add arguments
+         bcs.s   fpa2gc   branch if carry produced
+         move.b  d4,d7    restore sign/exponent
+         rts              return to caller
+ 
+* -arg1
+fpami1   move.b  d7,d5    test arg2's sign
+         bmi.s   fpals    branch for like signs
+         beq.s   fpart1   if zero return argument1
+ 
+* -arg1 +arg2
+* +arg1 -arg2
+fpams    moveq   #-128,d3  create a carry mask ($80)
+         eor.b   d3,d5    strip sign off arg2 s+exp copy
+         sub.b   d4,d5    compare magnitudes
+         beq.s   fpaeq    branch equal magnitudes
+         bmi.s   fpatlt   branch if arg1 larger
+* arg1 <= arg2
+         cmp.b   #24,d5   compare magnitude difference
+         bcc.s   fpart2   branch arg2 much bigger
+         move.b  d7,d4    arg2 s+exp dominates
+         move.b  d3,d7    setup carry on arg2
+         move.l  d6,d3    copy arg1
+fpamss   clr.b   d3       clear extraneous bits
+         lsr.l   d5,d3    adjust for magnitude
+         sub.l   d3,d7    subtract smaller from larger
+         bmi.s   fparsr   return final result if no overflow
+
+* mixed signs normalize
+fpanor   move.b  d4,d5    save correct sign
+fpanrm   clr.b   d7       clear subtract residue
+         sub.b   #1,d4    make up for first shift
+         cmp.l   #$00007fff,d7   ? small enough for swap
+         bhi.s   fpaxqn   branch nope
+         swap.w  d7       shift left 16 bits real fast
+         sub.b   #16,d4   make up for 16 bit shift
+fpaxqn   add.l   d7,d7    shift up one bit
+         dbmi    d4,fpaxqn decrement and branch if positive
+         eor.b   d4,d5    ? same sign
+         bmi.s   fpazro   branch underflow to zero
+         move.b  d4,d7    restore sign/exponent
+         beq.s   fpazro   return zero if exponent underflowed
+         rts              return to caller
+
+* exponent underflowed - return zero
+fpazro   moveq.l #0,d7    create a true zero
+         rts              return to caller
+
+* arg1 > arg2
+fpatlt   cmp.b   #-24,d5  ? arg1 >> arg2
+         ble.s   fpart1   return it if so
+         neg.b   d5       absolutize difference
+         move.l  d7,d3    move arg2 as lower value
+         move.l  d6,d7    set up arg1 as high
+         move.b  #$80,d7  setup rounding bit
+         bra.s   fpamss   perform the addition
+
+* equal magnitudes
+fpaeq    move.b   d7,d5    save arg1 sign
+         exg.l   d5,d4    swap arg2 with arg1 s+exp
+         move.b  d6,d7    insure same low byte
+         sub.l   d6,d7    obtain difference
+         beq.s   fpazro   return zero if identical
+         bpl.s   fpanor   branch if arg2 bigger
+         neg.l   d7       correct difference to positive
+         move.b  d5,d4    use arg2's sign + exponent
+         bra.s   fpanrm   and go normalize
+
+         end
+
+ normalize
+
+         end
+
+ normalize
+
+         end
+
+ normalize

CPM OPERATING SYSTEMS/CPM 68K/1.2 SOURCE/7/FFPEXP.S

@@ -0,0 +1,219 @@
+         ttl       fast floating point exponent (ffpexp)
+***************************************
+* (c) copyright 1981 by motorola inc. *
+***************************************
+ 
+*************************************************
+*                  ffpexp                       *
+*       fast floating point exponent            *
+*                                               *
+*  input:   d7 - input argument                 *
+*                                               *
+*  output:  d7 - exponential result             *
+*                                               *
+*     all other registers are transparent       *
+*                                               *
+*  code size: 256 bytes   stack work: 34 bytes  *
+*                                               *
+*  condition codes:                             *
+*        z - set if result in d7 is zero        *
+*        n - cleared                            *
+*        v - set if overlow occurred            *
+*        c - undefined                          *
+*        x - undefined                          *
+*                                               *
+*                                               *
+*  notes:                                       *
+*    1) an overflow returns the largest         *
+*       magnitude number.                       *
+*    2) spot checks show at least 6.8 digit     *
+*       accuracy for all abs(arg) < 30.         *
+*                                               *
+*  time: (8mhz no wait states assumed)          *
+*                                               *
+*              488 microseconds                 *
+*                                               *
+*  logic:   1) find n = int(arg/ln 2).  this is *
+*              added to the mantissa at the end.*
+*           3) reduce argument to range by      *
+*              finding arg = mod(arg, ln 2).    *
+*           4) derive exp(arg) with cordic loop.*
+*           5) add n to exponent giving result. *
+*                                               *
+*************************************************
+         page
+ffpexp   idnt  1,2 ffp exp
+ 
+         opt       pcs
+ 
+         section   9
+ 
+         xdef      ffpexp                        entry point
+ 
+         xref      ffphthet                    hypertangent table
+ 
+         xref      ffpmul2,ffpsub    arithmetic primitives
+         xref      ffptnorm          transcendental normalize routine
+         xref      ffpcpyrt            copyright stub
+ 
+ln2      equ       $b1721840           ln 2 (base e)             .693147180
+ln2inv    equ      $b8aa3b41           inverse of ln 2 (base e) 1.44269504
+cnjkhinv equ       $9a8f4441           floating conjugate of k inverse
+*                                      corrected for the extra convergence
+*                                      during shifts for 4 and 13
+kfctseed equ       $26a3d100           k cordic seed
+ 
+ 
+* overflow - return zero or highest value and "v" bit
+fpeovflw move.w    (sp)+,d6            load sign word and work off stack
+         tst.b     d6                  ? was argument negative
+         bpl.s     fpovnzro            no, continue
+         move.l    #0,d7               return a zero
+         bra.s     fpovrtn             as result is too small
+fpovnzro move.l    #-1,d7              set all zeroes
+         lsr.b     #1,d7               zero sign bit
+*        or.b      #$02,ccr            set overflow bit
+         dc.l      $003c0002           ***assembler error***
+fpovrtn  movem.l   (sp)+,d1-d6/a0      restore registers
+         rts                           return to caller
+ 
+* return one for zero argument
+ffpe1    move.l    #$80000041,d7       return a true one
+         lea       7*4+2(sp),sp        ignore stack saves
+         tst.b     d7                  set condition code properly
+         rts                           return to caller
+ 
+**************
+* exp entry  *
+**************
+ 
+* save work registers and insure positive argument
+ffpexp   movem.l   d1-d6/a0,-(sp)      save all work registers
+         move.w    d7,-(sp)            save sign in low order byte for later
+         beq.s     ffpe1               return a true one for zero exponent
+         and.b     #$7f,d7             take absolute value
+ 
+* divide by log 2 base e for partial result
+fpepos   move.l    d7,d2               save original argument
+         move.l    #ln2inv,d6          load inverse to multiply (faster)
+         jsr       ffpmul2              obtain division thru multiply
+         bvs       fpeovflw            branch if too large
+* convert quotient to both fixed and float integer
+         move.b    d7,d5               copy exponent over
+         move.b    d7,d6               copy exponent over
+         sub.b     #64+32,d5           find non-fractional precision
+         neg.b     d5                  make positive
+         cmp.b     #24,d5              ? insure not too large
+         ble.s     fpeovflw            branch too large
+         cmp.b     #32,d5              ? test upper range
+         bge.s     fpesml              branch less than one
+         lsr.l     d5,d7               shift to integer
+         move.b    d7,(sp)             place adjusted exponent with sign byte
+         lsl.l     d5,d7               back to normal without fraction
+         move.b    d6,d7               re-insert sign+exponent
+         move.l    #ln2,d6             multiply by ln2 to find residue
+         jsr       ffpmul2              multiply back out
+         move.l    d7,d6               setup to subtract multiple of ln 2
+         move.l    d2,d7               move argument in
+         jsr       ffpsub              find remainder of ln 2 divide
+         move.l    d7,d2               copy float argument
+         bra.s     fpeadj              adjust to fixed
+ 
+* multiple less than one
+fpesml   clr.b     (sp)                default initial multiply to zero
+         move.l    d2,d7               back to original argument
+ 
+* convert argument to binary(31,29) precision
+fpeadj   clr.b     d7                  clear sign and exponent
+         sub.b     #64+3,d2            obtain shift value
+         neg.b     d2                  for 2 non-fraction bits
+         cmp.b     #31,d2              insure not too small
+         bls.s     fpeshf              branch to shift if ok
+         move.l    #0,d7               force to zero
+fpeshf   lsr.l     d2,d7               convert to fixed point
+ 
+*****************************************
+* cordic calculation registers:         *
+* d1 - loop count   a0 - table pointer  *
+* d2 - shift count                      *
+* d3 - y'   d5 - y                      *
+* d4 - x'   d6 - x                      *
+* d7 - test argument                    *
+*****************************************
+ 
+* input within range, now start cordic setup
+fpecom   move.l    #0,d5               y=0
+         move.l    #kfctseed,d6        x=1 with jkhinverse factored out
+         lea       ffphthet,a0         point to hperbolic tangent table
+         move.l    #0,d2               prime shift counter
+ 
+* perform cordic loop repeating shifts 4 and 13 to guarantee convergence
+* (ref. "a unified algorithm for elementary functions" j.s.walther
+*        pg. 380 spring joint computer conference 1971)
+         move.l    #3,d1               do shifts 1 thru 4
+         bsr.s     cordic              first cordic loops
+         sub.l     #4,a0               redo table entry
+         sub.w     #1,d2               redo shift count
+         move.l    #9,d1               do four through 13
+         bsr.s     cordic              second cordic loops
+         sub.l     #4,a0               back to entry 13
+         sub.w     #1,d2               redo shift for 13
+         move.l    #10,d1              now 13 through 23
+         bsr.s     cordic              and finish up
+ 
+* now finalize the result
+         tst.b     1(sp)               test original sign
+         bpl.s     fsepos              branch positive argument
+         neg.l     d5                  change y for subtraction
+         neg.b     (sp)                negate adjusted exponent to subtract
+fsepos   add.l     d5,d6               add or subtract y to/from x
+         jsr       ffptnorm            float x
+         move.l    d6,d7               setup result
+* add ln2 factor integer to the exponent
+         add.b     (sp),d7             add to exponent
+         bmi       fpeovflw            branch if too large
+         beq       fpeovflw            branch if too small
+         add.l     #2,sp               rid work data off stack
+         movem.l   (sp)+,d1-d6/a0      restore registers
+         rts                           return to caller
+ 
+*************************
+* cordic loop subroutine*
+*************************
+cordic   add.w     #1,d2               increment shift count
+         move.l    d5,d3               copy y
+         move.l    d6,d4               copy x
+         asr.l     d2,d3               shift for y'
+         asr.l     d2,d4               shift for x'
+         tst.l     d7                  test arg value
+         bmi.s     febmi               branch minus test
+         add.l     d4,d5               y=y+x'
+         add.l     d3,d6               x=x+y'
+         sub.l     (a0)+,d7            arg=arg-table(n)
+         dbra      d1,cordic           loop until done
+         rts                           return
+ 
+febmi    sub.l     d4,d5               y=y-x'
+         sub.l     d3,d6               x=x-y'
+         add.l     (a0)+,d7            arg=arg+table(n)
+         dbra      d1,cordic           loop until done
+         rts                           return
+ 
+ 
+         end
+
+d1,cordic           loop until done
+         rts                           return
+ 
+ 
+         end
+
+d1,cordic           loop until done
+         rts                           return
+ 
+ 
+         end
+
+d1,cordic           loop until done
+         rts                           return
+ 

CPM OPERATING SYSTEMS/CPM 68K/1.2 SOURCE/7/FFPSIN.S

@@ -0,0 +1,295 @@
+         ttl       ffp sine cosine tangent (ffpsin/ffpcos/ffptan/ffpsincs)
+***************************************
+* (c) copyright 1981 by motorola inc. *
+***************************************
+ 
+*************************************************
+*        ffpsin ffpcos ffptan ffpsincs          *
+*     fast floating point sine/cosine/tangent   *
+*                                               *
+*  input:   d7 - input argument (radian)        *
+*                                               *
+*  output:  d7 - function result                *
+*           (ffpsincs also returns d6)          *
+*                                               *
+*     all other registers totally transparent   *
+*                                               *
+*  code size: 334 bytes   stack work: 38 bytes  *
+*                                               *
+*  condition codes:                             *
+*        z - set if result in d7 is zero        *
+*        n - set if result in d7 is negative    *
+*        c - undefined                          *
+*        v - set if result is meaningless       *
+*            (input magnitude too large)        *
+*        x - undefined                          *
+*                                               *
+*  functions:                                   *
+*             ffpsin   -  sine result           *
+*             ffpcos   -  cosine result         *
+*             ffptan   -  tangent result        *
+*             ffpsincs -  both sine and cosine  *
+*                         d6 - sin, d7 - cosine *
+*                                               *
+*  notes:                                       *
+*    1) input values are in radians.            *
+*    2) function ffpsincs returns both sine     *
+*       and cosine twice as fast as calculating *
+*       the two functions independently for     *
+*       the same value.  this is handy for      *
+*       graphics processing.                    *
+*    2) input arguments larger than two pi      *
+*       suffer reduced precision.  the larger   *
+*       the argument, the smaller the precision.*
+*       excessively large arguments which have  *
+*       less than 5 bits of precision are       *
+*       returned unchanged with the "v" bit set.*
+*    3) for tangent angles of infinite value    *
+*       the largest possible positive number    *
+*       is returned ($ffffff7f). this still     *
+*       gives results well within single        *
+*       precision calculation.                  *
+*    4) spot checks show errors bounded by      *
+*       4 x 10**-7 but for arguments close to   *
+*       pi/2 intervals where 10**-5 is seen.    *
+*                                               *
+*  time: (8mhz no wait states and argument      *
+*         assumed within +-pi)                  *
+*                                               *
+*           ffpsin       413 microseconds       *
+*           ffpcos       409 microseconds       *
+*           ffptan       501 microseconds       *
+*           ffpsincs     420 microseconds       *
+*************************************************
+         page
+ffpsin   idnt  1,2 ffp sine cosine tangent
+ 
+         opt       pcs
+ 
+         section   9
+ 
+         xdef      ffpsin,ffpcos,ffptan,ffpsincs entry points
+ 
+         xref      ffptheta                    inverse tangent table
+ 
+         xref      ffpmul2,ffpdiv,ffpsub    multiply, divide and subtract
+         xref      ffptnorm          transcendental normalize routine
+         xref      ffpcpyrt            copyright stub
+ 
+pi       equ       $c90fdb42          floating constant pi
+fixedpi  equ       $c90fdaa2          pi skeleton to 32 bits precision
+inv2pi   equ       $a2f9833e          inverse of two-pi
+kinv     equ       $9b74ee40          floating k inverse
+nkfact   equ       $ec916240          negative k inverse
+ 
+********************************************
+* entry for returning both sine and cosine *
+********************************************
+ffpsincs move.w    #-2,-(sp)           flag both sine and cosine wanted
+         bra.s     fpscom              enter common code
+ 
+**********************
+* tangent entry point*
+**********************
+ffptan   move.w    #-1,-(sp)           flag tangent with minus value
+         bra.s     fpschl              check very small values
+ 
+**************************
+* cosine only entry point*
+**************************
+ffpcos   move.w    #1,-(sp)            flag cosine with positive value
+         bra.s     fpscom              enter common code
+ 
+* negative sine/tangent small value check
+fpschm   cmp.b     #$80+$40-8,d7       ? less or same as -2**-9
+         bhi.s     fpscom              continue if not too small
+* return argument
+fpsrti   add.l     #2,sp               rid internal parameter
+         tst.b     d7                  set condition codes
+         rts                           return to caller
+ 
+************************
+* sine only entry point*
+************************
+ffpsin   clr.w     -(sp)               flag sine with zero
+* sine and tangent values < 2**-9 return identities
+fpschl   tst.b     d7                  test sign
+         bmi.s     fpschm              branch minus
+         cmp.b     #$40-8,d7           ? less or same than 2**-9
+         bls.s     fpsrti              return identity
+ 
+* save registers and insure input within + or - pi range
+fpscom   movem.l   d1-d6/a0,-(sp)      save all work registers
+         move.l    d7,d2               copy input over
+         add.b     d7,d7               rid sign bit
+         cmp.b     #(64+5)<<1,d7       ? abs(arg) < 2**6 (32)
+         bls.s     fpsnlr              branch yes, not too large
+* argument is too large to subtract to within range
+         cmp.b     #(64+20)<<1,d7      ? test excessive size (>2**20)
+         bls.s     fpsgpr              no, go ahead and use
+* error - argument so large result has no precision
+*        or.b      #$02,ccr            force v bit on
+         dc.l      $003c0002           *****assembler error*****
+         movem.l   (sp)+,d1-d6/a0      restore registers
+         add.l     #2,sp               clean internal argument off stack
+         rts                           return to caller
+ 
+* we must find mod(arg,twopi) since argument is too large for subtractions
+fpsgpr   move.l    #inv2pi,d6          load up 2*pi inverse constant
+         move.l    d2,d7               copy over input argument
+         jsr       ffpmul2             divide by 2pi (via multiply inverse)
+* convert quotient to float integer
+         move.b    d7,d5               copy exponent over
+         and.b     #$7f,d5             rid sign from exponent
+         sub.b     #64+24,d5           find fractional precision
+         neg.b     d5                  make positive
+         move.l    #-1,d4              setup mask of all ones
+         clr.b     d4                  start zeroes at low byte
+         lsl.l     d5,d4               shift zeroes into fractional part
+         or.b      #$ff,d4             do not remove sign and exponent
+         and.l     d4,d7               strip fractional bits entirely
+         move.l    #pi+1,d6            load up 2*pi constant
+         jsr       ffpmul2             multiply back out
+         move.l    d7,d6               setup to subtract multiple of twopi
+         move.l    d2,d7               move argument in
+         jsr       ffpsub              find remainder of twopi divide
+         move.l    d7,d2               use it as new input argument
+ 
+* convert argument to binary(31,26) precision for reduction within +-pi
+fpsnlr   move.l    #$0c90fdaa,d4      fixedpi>>4 load pi
+         move.l    d2,d7               copy float argument
+         clr.b     d7                  clear sign and exponent
+         tst.b     d2                  test sign
+         bmi.s     fpsnmi              branch negative
+         sub.b     #64+6,d2            obtain shift value
+         neg.b     d2                  for 5 bit non-fraction bits
+         cmp.b     #31,d2              ? very small number
+         bls.s     fpssh1              no, go ahead and shift
+         move.l    #0,d7               force to zero
+fpssh1   lsr.l     d2,d7               convert to fixed point
+* force to +pi or below
+fpspck   cmp.l     d4,d7               ? greater than pi
+         ble.s     fpsckm              branch not
+         sub.l     d4,d7               subtract
+         sub.l     d4,d7               .  twopi
+         bra.s     fpspck              and check again
+ 
+fpsnmi   sub.b     #$80+64+6,d2        rid sign and get shift value
+         neg.b     d2                  for 5 non-fractional bits
+         cmp.b     #31,d2              ? very small number
+         bls.s     fpssh2              no, go ahead and shift
+         move.l    #0,d7               force to zero
+fpssh2   lsr.l     d2,d7               convert to fixed point
+         neg.l     d7                  make negative
+         neg.l     d4                  make -pi
+* force to -pi or above
+fpsnck   cmp.l     d4,d7               ? less than -pi
+         bge.s     fpsckm              branch not
+         sub.l     d4,d7               add
+         sub.l     d4,d7               .  twopi
+         bra.s     fpsnck              and check again
+ 
+*****************************************
+* cordic calculation registers:         *
+* d1 - loop count   a0 - table pointer  *
+* d2 - shift count                      *
+* d3 - x'   d5 - x                      *
+* d4 - y'   d6 - y                      *
+* d7 - test argument                    *
+*****************************************
+ 
+* input within range, now start cordic setup
+fpsckm   move.l    #0,d5               x=0
+         move.l    #nkfact,d6          y=negative inverse k factor seed
+         move.l    #$3243f6a8,d4       fixedpi>>2, setup fixed pi/2 constant
+         asl.l     #3,d7               now to binary(31,29) precision
+         bmi.s     fpsap2              branch if minus to add pi/2
+         neg.l     d6                  y=positive inverse k factor seed
+         neg.l     d4                  subtract pi/2 for positive argument
+fpsap2   add.l     d4,d7               add constant
+         lea       ffptheta,a0         load arctangent table
+         move.l    #23,d1              loop 24 times
+         move.l    #-1,d2              prime shift counter
+* cordic loop
+fsinlp   add.w     #1,d2               increment shift count
+         move.l    d5,d3               copy x
+         move.l    d6,d4               copy y
+         asr.l     d2,d3               shift for x'
+         asr.l     d2,d4               shift for y'
+         tst.l     d7                  test arg value
+         bmi.s     fsbmi               branch minus test
+         sub.l     d4,d5               x=x-y'
+         add.l     d3,d6               y=y+x'
+         sub.l     (a0)+,d7            arg=arg-table(n)
+         dbra      d1,fsinlp           loop until done
+         bra.s     fscom               enter common code
+fsbmi    add.l     d4,d5               x=x+y'
+         sub.l     d3,d6               y=y-x'
+         add.l     (a0)+,d7            arg=arg+table(n)
+         dbra      d1,fsinlp           loop until done
+ 
+* now split up tangent and ffpsincs from sine and cosine
+fscom    move.w    7*4(sp),d1          reload internal parameter
+         bpl.s     fssincos            branch for sine or cosine
+ 
+         add.b     #1,d1               see if was -1 for tangent
+         bne.s     fsdual              no, must be both sin and cosine
+* tangent finish
+         bsr.s     fsfloat             float y (sin)
+         move.l    d6,d7               setup for divide into
+         move.l    d5,d6               prepare x
+         bsr.s     fsfloat             float x (cos)
+         beq.s     fstinf              branch infinite result
+         jsr       ffpdiv              tangent = sin/cos
+fsinfrt  movem.l   (sp)+,d1-d6/a0      restore registers
+         add.l     #2,sp               delete internal parameter
+         rts                           return to caller
+* tangent is infinite. return maximum positive number.
+fstinf   move.l    #$ffffff7f,d7       largest ffp number
+         bra.s     fsinfrt             and clean up
+ 
+* sine and cosine
+fssincos beq.s     fssine              branch if sine
+         move.l    d5,d6               use x for cosine
+fssine   bsr.s     fsfloat             convert to float
+         move.l    d6,d7               return result
+         tst.b     d7                  and condition code test
+         movem.l   (sp)+,d1-d6/a0      restore registers
+         add.l     #2,sp               delete internal parameter
+         rts                           return to caller
+ 
+* both sine and cosine
+fsdual   move.l    d5,-(sp)            save cosine derivitive
+         bsr.s     fsfloat             convert sine derivitive to float
+         move.l    d6,6*4(sp)          place sine into saved d6
+         move.l    (sp)+,d6            restore cosine derivitive
+         bra.s     fssine              and continue restoring sine on the sly
+ 
+* fsfloat - float internal precision but truncate to zero if < 2**-21
+fsfloat  move.l    d6,d4               copy internal precision value
+         bmi.s     fsfneg              branch negative
+         cmp.l     #$000000ff,d6       ? test magnitude
+*        bhi       ffptnorm            normalize if not too small
+                bhi                     dobranch
+fsfzro   move.l    #0,d6               return a zero
+         rts                           return to caller
+fsfneg   asr.l     #8,d4               see if all ones bits 8-31
+         add.l     #1,d4               ? goes to zero
+*        bne       ffptnorm            normalize if not too small
+                bne                     dobranch
+         bra.s     fsfzro              return zero
+ 
+dobranch:
+                jmp             ffptnorm                        16-bit no-MMU problem
+ 
+         end
+
+              jmp             ffptnorm                        16-bit no-MMU problem
+ 
+         end
+
+              jmp             ffptnorm                        16-bit no-MMU problem
+ 
+         end
+
+              jmp             ffptnorm                        16-bit no-MMU problem

CPM OPERATING SYSTEMS/CPM 68K/1.2 SOURCE/7/FPFTOL.S

@@ -0,0 +1,58 @@
+* 
+*	Floating Point Float to Long Routine :
+*		Front End to FFP Floating Point Package.
+*
+*		long
+*		fpftol(fparg)
+*		double fparg;
+*
+*	Condition Codes : V bit signifies Overflow
+*
+*	Return : Fixed Point representation of Floating Point Number
+*
+.globl fpftol
+.globl _fpftol
+.globl ffpfpi
+.text
+fpftol:
+_fpftol:
+~~fpftol:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8(r14),r7
+jsr		ffpfpi
+move.l	r7,r0
+movem.l	(sp)+,d3-d7
+unlk	r14
+rts
+~~fpftol:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8r14),r7
+jsr		ffpfpi
+move.l	r7,r0
+movem.l	(sp)+,d3-d7
+unlk	r14
+rts
+~~fpftol:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8r14),r7
+jsr		ffpfpi
+move.l	r7,r0
+movem.l	(sp)+,d3-d7
+unlk	r14
+rts
+~~fpftol:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8r14),r7
+jsr		ffpfpi
+move.l	r7,r0
+movem.l	(sp)+,d3-d7
+unlk	r14
+rts
+~~fpftol:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8

CPM OPERATING SYSTEMS/CPM 68K/1.2 SOURCE/7/FPLTOF.S

@@ -0,0 +1,59 @@
+* 
+*	Floating Point Long to Float Routine :
+*		Front End to FFP Floating Point Package.
+*
+*		double
+*		fpltof(larg)
+*		long larg;
+*
+*	Return : Floating Point representation of Long Fixed point integer
+*
+.globl fpltof
+.globl _fpltof
+.globl ffpifp
+.text
+fpltof:
+_fpltof:
+~~fpltof:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8(r14),r7
+jsr		ffpifp
+move.l	r7,r0
+movem.l	(sp)+,d3-d7
+unlk	r14
+rts
+~~fpltof:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8(r14),r7
+jsr		ffpifp
+move.l	r7,r0
+movem.l	sp)+,d3-d7
+unlk	r14
+rts
+~~fpltof:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8(r14),r7
+jsr		ffpifp
+move.l	r7,r0
+movem.l	sp)+,d3-d7
+unlk	r14
+rts
+~~fpltof:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8(r14),r7
+jsr		ffpifp
+move.l	r7,r0
+movem.l	sp)+,d3-d7
+unlk	r14
+rts
+~~fpltof:
+link	r14,#-4
+movem.l	d3-d7,-(sp)
+move.l	8(r14),r7
+jsr		ffpifp
+move.l	r7,r0
+movem.l	

CPM OPERATING SYSTEMS/CPM 68K/1.2 SOURCE/7/FSCANF.C

@@ -0,0 +1,539 @@
+/*
+    Copyright 1982, 1983
+    Alcyon Corporation
+    8716 Production Ave.
+    San Diego, Ca. 92121
+
+    @(#)fscanf.c	1.1	11/9/83
+*/
+
+/*
+**  formatted read routine
+**
+**      functionally equivalent to scanf in portable C library
+*/
+
+#include <stdio.h>
+#include <math.h>
+
+/* Delimiters */
+
+#define NEWLINE '\n'
+#define TAB     '\t'
+#define SPACE   ' '
+#define NULL    '\0'
+
+/* returns from __next() */
+
+#define CHAR        0
+#define NOT_WHT     -1
+#define NOT_WHT_NL  1
+
+/* returns from __scan() */
+
+#define NORETURN    0
+#define VALID       1
+#define NOMATCH     -1
+#define AT_EOF      -2
+#define ERROR       -3
+
+FILE *__stream;
+char **_p, *__sstr, __holdch;
+int __smode, __hold;
+
+scanf(parlist)
+char *parlist;
+{
+    __smode = 0;
+    _p = &parlist;
+    return(__doscanf());
+}
+
+fscanf(stream,parlist)
+FILE *stream;
+char *parlist;
+{
+    if( (stream->_flag&(_RMODE|_UPDATE)) == 0 || feof(stream) ) 
+        return(EOF);
+        
+    __smode = 1;
+    __stream = stream;
+    _p = &parlist;
+    return(__doscanf());
+}
+
+sscanf(s,parlist)
+char *s, *parlist;
+{
+    __smode = 2;
+    __sstr = s;
+    _p = &parlist;
+    return(__doscanf());
+}
+
+__doscanf()
+{
+    register int    nmatch;
+    register char   ch;
+    char *format;
+    register char match_ch;
+
+    nmatch = __hold = 0;
+    format = *_p++;
+    while( 1 ) {
+        switch (ch = *format++) {
+
+         case NULL:
+            return(nmatch);
+
+         case '%':
+            if( *format != '%' ) {
+                switch (__scan(&format, *_p)) {
+    
+                 case VALID:    /* good return*/
+                    _p++;
+                    nmatch++;
+                 case NORETURN: /* no return*/
+                    break;
+    
+                 case NOMATCH:  /* no match */
+                    return(nmatch);
+    
+                 case AT_EOF:   /* end of file */
+                    return(nmatch ? nmatch : NOMATCH);
+    
+                 default:   /* syntax error */
+                    return(NOMATCH);
+    
+                }
+                break;
+            }
+            format++;
+
+         default:
+            match_ch = __next(CHAR);
+            if( ch != match_ch ) {
+                __unget(match_ch);
+                return(nmatch ? nmatch : AT_EOF);
+            }
+            break;
+
+        }
+    }
+}
+
+/*
+ * main scan routine -- look at characters in the conversion string
+ * and do their bidding
+ */
+__scan(spec, result)
+char    **spec;
+char    *result;
+{
+    register int    longf, length;
+    register char   ch;
+    extern int  __strend(), __splend();
+
+    longf = length = 0;
+    while( 1 ) {
+        switch (ch = *(*spec)++) {
+         case '*':
+            result = 0;
+            break;
+    
+         case '0':
+         case '1':
+         case '2':
+         case '3':
+         case '4':
+         case '5':
+         case '6':
+         case '7':
+         case '8':
+         case '9':
+            length = length * 10 + ch - '0';
+            break;
+    
+         case 'l':
+            if( longf )
+                return(ERROR);
+            longf = 1;
+            break;
+    
+         case 'h':  /* short */
+            if( longf )
+                return(ERROR);
+            longf = NOMATCH;
+            break;
+    
+         case 'o':
+         case 'O':
+            return(__dec(result, length ? length : 100, 8, longf));
+    
+         case 'd':
+         case 'D':
+            return(__dec(result, length ? length : 100, 10, longf));
+    
+         case 'x':
+         case 'X':
+            return(__dec(result, length ? length : 100, 16, longf));
+    
+         case 'c':
+         case 'C':
+            if( longf )
+                return(ERROR);
+            return(__char(result, length ? length : 1));
+    
+         case 's':
+         case 'S':
+            if( longf )
+                return(ERROR);
+            return(__strx(result, length ? length : 100, __strend));
+    
+         case 'e':
+         case 'E':
+         case 'f':
+         case 'F':
+            if( longf )
+                return(ERROR);
+            return(__float(result, length ? length : 100));
+            /*return(ERROR);        /* not yet implemented */
+    
+         case '[':
+            if( longf )
+                return(ERROR);
+            if( __inits(spec) )
+                return(ERROR);
+            return(__strx(result, length ? length : 100, __splend));
+    
+         default:
+            return(ERROR);
+    
+        }
+    }
+}
+
+/*
+ * get a constant -- octal, decimal, or hex depending on base
+ */
+__dec(result, length, base, longf)
+register int    *result;
+int length;
+int base;
+int longf;
+{
+    register char   ch;
+    register int    val;
+    register int    ndigit;
+    register long   *lresult;
+    register long   lres;
+    register int    ires;
+    register int    minus, ok;
+
+    ires = 0;
+    lres = 0;
+    ndigit = minus = 0;
+    switch (ch = __next(NOT_WHT_NL)) {
+
+         case NULL:
+         case EOF:
+            return(AT_EOF);
+
+         case '-':
+            minus = 1;
+         case '+':
+            ndigit++;
+            ch = __next(NOT_WHT);
+    }
+    ok = 0;
+    while( (val = __digit(ch, base)) >= 0 && ndigit++ < length ) {
+        ok++;
+        if( longf )
+            lres = lres * base + val;
+        else
+            ires = ires * base + val;
+        ch = __next(CHAR);
+    }
+    __unget(ch);
+    if( !ok )
+        return(NOMATCH);
+    if( !result )
+        return(NORETURN);
+    if( minus )
+        if( longf )
+            lres = -lres;
+        else
+            ires = -ires;
+    if( longf ) {
+        lresult = result;
+        *lresult = lres;
+    }
+    else
+        *result = ires;
+    return(VALID);
+}
+
+/*
+ * get a floating point constant
+ */
+__float(result, length)
+register double *result;
+int length;
+{
+    char buffer[100];
+    double val;
+    int ret, ch;
+
+    ret = __strx(buffer, 100, __strend);
+    val = atof(buffer);
+    *result = val;
+    return(ret);
+}
+
+__next(mode)
+int mode;
+{
+/*
+ *  mode -1: get next non-space or non-tab
+ *  mode 0:  get next character
+ *  mode 1:  get next non-space, non-tab, or non-newline
+ */
+    register int    ch;
+
+    if( (ch = __getch()) == EOF )
+        return(EOF);
+    if( mode == 0 )
+        return(ch);
+    while( ch == SPACE || ch == TAB || ch == NEWLINE ) {
+        if( ch == NEWLINE && mode < 0 )
+            break;
+        ch = __getch();
+    }
+    return(ch);
+}
+
+/*
+ * check an input character for a valid constant digit (octal, decimal,
+ * or hex) if found, return the proper numeric value.  Negative results
+ * indicate error.
+ */
+__digit(ch, base)
+register char   ch;
+register int    base;
+{
+    register int    n;
+
+    if( ch < '0' )
+        return(NOMATCH);
+    if( ch <= '7' )
+        return(ch - '0');
+    if( base == 8 )
+        return(NOMATCH);
+    if( ch <= '9' )
+        return(ch - '0');
+    if( base == 10 || ch < 'A' )
+        return(NOMATCH);
+    if( ch <= 'F' )
+        return(ch - 'A' + 10);
+    if( ch < 'a' || ch > 'f' )
+        return(NOMATCH);
+    return(ch - 'a' + 10);
+}
+
+/*
+ * check for an end of string delimiter
+ */
+__strend(cha)
+char    cha;
+{
+    register char   ch;
+
+    if( (ch = cha) == EOF )
+        return(EOF);
+    if( ch == SPACE || ch == TAB || ch == NEWLINE || ch == NULL )
+        return(VALID);
+    return(NORETURN);
+}
+
+char    __splset[128];
+
+/*
+ * check for the occurrance of any character in the set which
+ * the user wants to be end-of-string delimiters
+ */
+__splend(ch)
+char    ch;
+{
+    if( ch == EOF )
+        return(EOF);
+    return(__splset[ch]);
+}
+
+/*
+ * initialize the array which inidcates the special chars which the user
+ * wants to be included (or not included) in strings.
+ */
+__inits(spec)
+register char   **spec;
+{
+    register char   ch;
+    register int    i;
+    register int    val;
+
+    ch = *(*spec)++;
+    if( ch == '^' ) {
+        val = 0;
+        ch = *(*spec)++;
+    }
+    else
+        val = 1;
+    for (i = 1; i < 128; i++)
+        __splset[i] = val;
+    val = 1 - val;
+    while( ch != ']' ) {
+        if( ch == 0 )
+            return(NOMATCH);
+        __splset[ch & 0177] = val;
+        ch = *(*spec)++;
+    }
+    __splset[0] = 1;
+    return(NORETURN);
+}
+
+/*
+ * getting a string
+ */
+__strx(result, length, endfn)
+register char   *result;
+register int    length;
+register int    (*endfn)();
+{
+    register char   ch;
+    extern int  __splend();
+    register int    imode, notok;
+
+    notok = 1;
+    imode = (endfn != __splend);
+    if (imode) {
+		ch = __next(NOT_WHT_NL); 
+		__unget(ch);	/* bypass tab or space... */
+	}
+    while( !(*endfn)( (ch = __next(imode)) ) && length-- > 0 ) {
+        if( result )
+            *result++ = ch;
+        imode = notok = 0;
+    }
+    __unget(ch);
+    if( notok )
+        return(ch == EOF ? AT_EOF : NOMATCH);
+    if( !result )
+        return(NORETURN);
+    *result = 0;
+    return(VALID);
+}
+
+/*
+ * getting a character constant
+ */
+__char(result, length)
+register char   *result;
+register int    length;
+{
+    register char   *r, ch;
+    register int    l;
+
+    r = result;
+    l = length;
+
+    while( l-- ) {
+        if( (ch = __next(CHAR)) <= 0 ) {
+            if( l + 1 == length )
+                return(ch == EOF ? AT_EOF : NOMATCH);
+            else
+                return(result != 0);
+        }
+        if( result )
+            *result++ = ch;
+    }
+    return(result != 0);
+}
+
+__getch()
+{
+    switch(__smode) {
+        case 0:
+            return(__gstdi());
+        case 1:
+            return(getc(__stream));
+        case 2:
+            return(__gs());
+    }
+}
+
+__unget(ch)
+char ch;
+{
+    switch(__smode) {
+        case 0:
+            __ugstdi(ch);
+            break;
+        case 1:
+            ungetc(ch,__stream);
+            break;
+        case 2:
+            __ungs(ch);
+            break;
+    }
+}
+
+/*
+ * return the next char pointed to by *s 
+ */
+__gs()
+{
+    register char   c;
+
+    c = *__sstr;
+    if( c )
+        __sstr++;
+    else
+        return(EOF);
+    return(c);
+}
+
+/*
+ * put back a char for further scanning
+ */
+__ungs(c)
+char    c;
+{
+    if( c )
+        __sstr--;
+}
+
+__gstdi()
+{
+    if( !__hold)
+        return(getchar());
+    else {
+        __hold = 0;
+        return(__holdch);
+    }
+}
+
+__ugstdi(ch)
+char ch;
+{
+    __hold = 1;
+    __holdch = ch;
+}
+
+= 1;
+    __holdch = ch;
+}
+
+= 1;
+    __holdch = ch;
+}
+
+= 1;

CPM OPERATING SYSTEMS/CPM 68K/1.2 SOURCE/7/XDOPRTFP.C

@@ -0,0 +1,59 @@
+/****************************************************************************/
+/*									    */
+/*			X d o p r t f p   R o u t i n e			    */
+/*			-------------------------------			    */
+/*									    */
+/*	This file contains subroutines called from "_doprt()" which are	    */
+/*	specific to floating point.  The purpose of having a separate file  */
+/*	is so that these routines may be declared global in a special 	    */
+/*	version of "s.o", to allow running without the floating point 	    */
+/*	library routines.						    */
+/*									    */
+/*	Entry Points:							    */
+/*									    */
+/*		petoa(^float, ^buff, prec);				    */
+/*		pftoa(^float, ^buff, prec);				    */
+/*									    */
+/*	^float	is a pointer to the floating number to convert		    */
+/*	^buff	is a pointer to the buffer				    */
+/*	prec	is the precision specifier				    */
+/*									    */
+/****************************************************************************/
+#include <portab.h>			/*				    */
+BYTE	*ftoa();			/* Converts float to ascii "F" fmt  */
+BYTE	*etoa();			/* Converts float to ascii "E" fmt  */
+					/************************************/
+BYTE	*pftoa(addr,buf,prec)		/* Print "F" format		    */
+FLOAT	*addr;				/* -> Number to convert		    */
+BYTE	*buf;				/* -> Output buffer		    */
+WORD	prec;				/* Fraction precision specifier	    */
+{					/************************************/
+	FLOAT	fp;			/* Float temp			    */
+					/************************************/
+	prec = (prec < 0) ? 6 : prec;	/* If < 0, make it 6		    */
+	fp = *addr;			/* Load float number		    */
+	return(ftoa(fp,buf,prec));	/* Do conversion		    */
+}					/************************************/
+					/*				    */
+BYTE	*petoa(addr,buf,prec)		/* Print "E" format		    */
+FLOAT	*addr;				/* -> Number to convert		    */
+BYTE	*buf;				/* -> Output buffer		    */
+WORD	prec;				/* Fraction precision specifier	    */
+{					/************************************/
+	FLOAT	fp;			/* Floating temp		    */
+	prec = (prec < 0) ? 6 : prec;	/* If < 0, make it 6		    */
+	fp = *addr;			/* Load temp			    */
+	return(etoa(fp,buf,prec));	/* Do conversion		    */
+}					/************************************/
+;			/* Load temp			    */
+	return(etoa(fp,buf,prec));	/* Do conversion		    */
+}					/***********************************/
+;			/* Load temp			    */
+	return(etoa(fp,buf,prec));	/* Do conversion		    */
+}					/***********************************/
+;			/* Load temp			    */
+	return(etoa(fp,buf,prec));	/* Do conversion		    */
+}					/***********************************/
+;			/* Load temp			    */
+	return(etoa(fp,buf,prec));	/* Do conversion		    */
+}					/***