home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Yerk 3.64 ƒ / Float source / Float < prev    next >
Encoding:
Text File  |  1992-06-24  |  5.7 KB  |  197 lines  |  [TEXT/ttxt]
  1. \ float -- floating-point classes: Float and fArray
  2. \  9/22/85  cbd Version 1.0
  3. \  8/16/86  cdn Added LocalFloat
  4. \  4/10/90    rfl    fixed fltAt and fltTo to check for ivars
  5. \  9/25/90    rfl    added +to:
  6. \  3/15/92    rfl    added put: farray get: farray
  7. \  6/24/92    rfl    protect stack from getting more floats that floatmem allows
  8.  
  9. decimal
  10.  
  11. \ ========= Code support for methods - CBD 9/85 ======
  12. :CODE  getFlt  
  13.         move.l  YERK[(fltNew)],d7
  14.         jsr     0(a3,d7.l)  ; get new float in d1
  15.         move.l  d5,a2       ; get mstack
  16.         move.l  (a2),a0     ; base address
  17.         adda.l   a3,a0
  18.         lea     2(a3,d1.l),a1 
  19.         move.l  (a0)+,(a1)+ ; copy float data
  20.         move.l  (a0)+,(a1)+       
  21.         move.w  (a0)+,(a1)+   
  22.         move.l  d1,-(a7)    ; return new float
  23. ;CODE    
  24.  
  25. :CODE  putFlt  
  26.         move.l  (a7),d0
  27.         move.l  YERK[(fltDisp)],d7
  28.         jsr     0(a3,d7.l)     ; get rid of float in D0
  29.         move.l  d5,a2       ; get mstack
  30.         move.l  (a2),a1     ; base address
  31.         adda.l   a3,a1
  32.         move.l  (a7)+,d0
  33.         lea     2(a3,d0.l),a0
  34.         move.l  (a0)+,(a1)+ ; copy float data
  35.         move.l  (a0)+,(a1)+       
  36.         move.w  (a0)+,(a1)+   
  37. ;CODE   
  38.  
  39. \ set up stack for float object arithmetics so that the 
  40. \ result is stored in the receiver.  ( parm -- rcvr parm )
  41. :CODE  fltOp
  42.         move.l  d5,a2       ; get mstack
  43.         move.l  (a7),d0
  44.         move.l  (a2),(a7)   ; base address
  45.         subq.l  #2,(a7)     ; floats have status word
  46.         move.l  d0,-(a7)
  47. ;CODE         
  48.              
  49. :CLASS  Float   <Super Object
  50.         10 Bytes data
  51.  
  52. \ ( -- x ) push private data onto stack
  53. :M  GET:   getFlt  ;M
  54.  
  55. \ ( x -- ) store float into private data
  56. :M  PUT:   putFlt  ;M
  57.  
  58. \ ( Float -- ) assign this float's data to another object
  59. :M  =:     getFlt swap put: Float ;M
  60.  
  61. \ ----- Arithmetic operations take a stack float (not a float obj)
  62. \ ( x -- ) add a float to the contents of this object 
  63. :M  +:      fltOp f+ drop  ;M
  64.  
  65. \ ( x -- ) 
  66. :M  -:      fltOp f- drop ;M
  67.  
  68. \ ( x -- )  
  69. :M  *:      fltOp f*  drop  ;M
  70.  
  71. \ ( x -- )   
  72. :M  /:      fltOp f/  drop ;M
  73.  
  74. \ ( -- sin )     return sine of object  
  75. :M  SIN:      getFlt sin   ;M
  76.  
  77. \ ( -- cos )     return cosine of object  
  78. :M  COS:      getFlt cos   ;M
  79.  
  80. \ ( -- tan )     return tangent of object  
  81. :M  TAN:      getFlt tan   ;M
  82.  
  83. \ ( -- arcTan)     return arctangent of object  
  84. :M  ARCTAN:    getFlt arcTan    ;M
  85.  
  86. \ ( -- ln)     return natural log of object  
  87. :M  LN:       getFlt ln      ;M
  88.  
  89. \ ( -- exp )     return exp of object  
  90. :M  EXP:      getFlt exp   ;M
  91.  
  92. \ ( -- log)     return log base 10 of object  
  93. :M  LOG:      getFlt log   ;M
  94.  
  95. \ ( -- alog)     return antilog of object  
  96. :M  ANTILOG:  getFlt antilog   ;M
  97.  
  98. \ ( -- )     convert radians to degrees and return result
  99. :M  DEG:      getFlt rad2deg    ;M
  100.  
  101. \ ( -- )     convert from radians to degrees and return result
  102. :M  RAD:      getFlt deg2rad    ;M
  103.  
  104. \ ( -- )     compute absolute value and return result
  105. :M  ABSVAL:   getFlt fabs    ;M
  106.  
  107. \ ( -- )     change sign and return result
  108. :M  NEG:      getFlt fnegate     ;M
  109.  
  110. \ ( -- )   negate this object's data
  111. :M  NEGATE:   copym 2- fnegate  drop ;M
  112.  
  113. \ ( -- )     
  114. :M  PRINT:      getFlt e.      ;M
  115.  
  116. ;CLASS
  117.  
  118. \ optimized access primitives for float array
  119. :CODE  fltAt
  120.         move.l  YERK[(fltNew)],d7
  121.         jsr     0(a3,d7.l)      ; get new float in d1
  122.         move.l  d5,a2           ; get mstack
  123.         move.l  (a2),a0         ; object base
  124.         adda.l   a3,a0
  125.         move.l    -4(a0),d7        ; get class
  126.         adda.w    $12(a3,d7.l),a0    ; offset for ivar
  127.         move.l  (a7),d0         ; get idx
  128.         mulu    #10,d0          ; convert to offset
  129.         lea     4(a0,d0.l),a0   ; pt to element
  130.         lea     2(a3,d1.l),a1   ; pt to target
  131.         move.l  (a0)+,(a1)+     ; deep copy of float data
  132.         move.l  (a0)+,(a1)+
  133.         move.w  (a0)+,(a1)+
  134.         move.l  d1,(a7)         ; push float ptr
  135. ;CODE
  136.  
  137. :CODE  fltTo
  138.         move.l  4(a7),d0        ; get the source float
  139.         move.l  YERK[(fltDisp)],d7
  140.         jsr     0(a3,d7.l)      ; dispose of source float in d0
  141.         move.l  d5,a2           ; get mstack
  142.         move.l  (a2),a0         ; object base
  143.         adda.l   a3,a0
  144.         move.l    -4(a0),d7        ; get class
  145.         adda.w    $12(a3,d7.l),a0    ; offset for ivar
  146.         move.l  (a7)+,d1        ; get idx
  147.         mulu    #10,d1          ; convert to offset
  148.         lea     4(a0,d1.l),a1   ; pt to element
  149.         move.l  (a7)+,d0        ; get new float ptr
  150.         lea     2(a3,d0.l),a0   ; pt to source float
  151.         move.l  (a0)+,(a1)+     ; deep copy of float data
  152.         move.l  (a0)+,(a1)+
  153.         move.w  (a0)+,(a1)+
  154. ;CODE
  155.         
  156.  
  157. :CLASS  fArray  <Super Object   10 <Indexed
  158.  
  159. ( index -- )
  160. \ ( -- x ) return the float at index
  161. :M  AT:     fltAt  ;M
  162.  
  163. ( index -- )
  164. \ ( x -- ) store a new float at index
  165. :M  TO:     fltTo   ;M
  166.  
  167. :M +TO: ( x ind -- ) dup fltAt rot f+ swap fltTo ;M
  168.  
  169. \ ( x -- ) fill all elements wih x
  170. :M  FILL:      limit 0
  171.                 DO fdup I to: self LOOP fdrop     ;M
  172.  
  173. :M  PUT: ( x x x...) limit 0 DO limit i- 1- to: self LOOP ;M
  174.  
  175. :M  GET: ( - x x x ..) limit limit: fltmem > classerr" 129
  176.     limit 0 DO i at: self LOOP ;M
  177.  
  178. \ Prints all elements
  179. :M  PRINT:  limit: self 0 DO i dup 4 .r space at: self e. cr LOOP ;M
  180.  
  181. ;CLASS
  182.  
  183. \ ( -- )  Initializes private floating point variables when present
  184. :f LocalFloat 
  185.     R 6 - dup c@ dup $ 0f and   \ number of input parameters
  186.     rot 1+ c@ over >>           \ get float mask and dump bits for input parms
  187.     rot 4 >>                    \ number of local variables
  188.     0 DO                      
  189.         dup 1 and               \ get right most bit
  190.         IF  over i + mPuts @mp  \ if on then param+i is a float
  191.             0.0 swap execute
  192.         THEN
  193.         1 >>    \ shift mask for next iteration
  194.     LOOP
  195.     2drop
  196. ;f
  197.