home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / System source / floating point < prev    next >
Encoding:
Text File  |  1995-02-06  |  36.7 KB  |  1,829 lines  |  [TEXT/MSET]
  1. \  Aug 90  mrh  Mops version.
  2. \  Dec 90  mrh  Direct FPU support added - float now 14 bytes long.
  3. \  Apr 91  mrh    More optimization of FPU code.  FP source files combined.
  4. \        Number of parms/locals increased via ExtraLocals area.
  5.  
  6. \ The floating heap is a region of heap that is divided into 14-byte blocks.
  7. \ Each block consists of two bytes of status information, along with 12
  8. \ bytes of data.  If the status field is $0001, the block is in use.
  9. \ Otherwise, the status field holds the offset of the next free block from
  10. \ the start of the array, and bit 0 is off because the offset must be even.
  11. \ The data field is a 96-bit floating point number in 68881/68882 FPU
  12. \ extended format.  This is basically the same as the SANE 80-bit
  13. \ extended format, since the 3rd and 4th bytes are unused (zero), and
  14. \ the SANE format is identical except that these unused 2 bytes are not
  15. \ represented.  If we don't have an FPU we call SANE, and this means we
  16. \ have to adjust the format first.
  17.  
  18. false -> useFPU?
  19.  
  20. \ floating-point error handlers
  21.  
  22. : NOTINIT    cr ." Uninitialized float argument"  abort ;
  23. : FullErr    cr ." Floating point heap is full"  abort  ;
  24. : NF        cr ." Not a float: "  .  abort  ;
  25.  
  26.  
  27. :code NoFloat        \ Assume A0 -> float that isn't
  28.         push.l    a0
  29.         bra.s    dic[NF]
  30. ;code
  31.  
  32.  
  33. :class  FLTHEAP  super{ object }  14 indexed
  34.  
  35. record
  36. {    int    FreeHead        \ offset of first free block 
  37. }
  38.  
  39. :mcode NEW:        \ ( -- fPtr )
  40.  
  41. \ Returns a ptr to a new block.  Interestingly,
  42. \ the Mops register usage means that this routine is only
  43. \ half as long as it was in Neon.  Note that unlike Neon,
  44. \ fPtr points to the floating data, not to the status word.
  45.  
  46.         loc
  47.         move.w    (a2),d0            ; D0(lo) = offset of first free block
  48.         beq        dic[fullErr]
  49.         lea        0(a2,d0.w),a0    ; A0 -> the block
  50.         move.w  (a0),(a2)        ; Move next free block 
  51.                                 ;  offs to free list hdr
  52.         move.w    #1,(a0)+        ; Mark block in use
  53.         push.l    a0                ; Return data addr
  54. ;mcode
  55.  
  56.  
  57. :mcode RELEASE:        \ ( fptr -- )  Disposes of block for fptr
  58.         pop.l    a0                ; A0 -> float data
  59.         cmpi.w    #1,-(a0)        ; Float block must have $0001 in 
  60.                                 ;  its status field
  61.         bne        dic[noFloat]
  62.         move.w  (a2),(a0)        ; Move free list hdr to blk
  63.                                 ;  being freed
  64.         sub.l    a2,a0            ; Get offs of block
  65.         move.w  a0,(a2)            ; Store in free head ptr        
  66. ;mcode
  67.  
  68.  
  69. :m ROOM: { \ offs #free -- #free }    \  Returns # of float blocks remaining
  70.                                     \ in float heap
  71.     get: freeHead  -> offs  0 -> #free
  72.     BEGIN    offs
  73.     WHILE    offs ^base + w@  -> offs  1 ++> #free 
  74.     REPEAT
  75.     #free  ;m
  76.  
  77. :m CLASSINIT:        \ Sets all blocks to free and links them together.
  78.     limit 1- 0 
  79.     DO
  80.         i 1+ ^elem  ^base -   i ^elem  w!
  81.     LOOP
  82.     0 limit 1-  ^elem  w!
  83.     0 ^elem  ^base -  put: freeHead  ;m
  84.  
  85. :m INIT:    classinit: self  ;m
  86.  
  87. ;class
  88.  
  89.  
  90.  100    fltHeap  FLTMEM
  91.  
  92.  
  93. \ (FLTNEW) is a subroutine which returns a new float ptr in A0.
  94. \ Uses D0.
  95.  
  96. :code (FLTNEW)
  97.         loc
  98.         lea        dicobj[fltMem],a0
  99.         move.w    (a0),d0                ; D0(lo) = offset of first free 
  100.                                     ;  block
  101.         beq    dic[fullErr]
  102.         add.w    d0,a0                ; A0 -> the block
  103.         move.w  (a0),dicobj[fltMem]    ; Move next free block offs to 
  104.                                     ;  free list hdr
  105.         move.w    #1,(a0)+            ; Mark block in use, update A0 to 
  106.                                     ;  float data addr
  107. ;code
  108.  
  109.  
  110. \ (FLTDISP) is a subroutine to dispose of the float in A0.  Uses A0.
  111.  
  112. :code (FLTDISP)
  113.         push.l    a1                    ; Save a1
  114.         cmpi.w    #1,-(a0)            ; Float block must have $0001 in 
  115.                                     ;  its status field
  116.         bne        dic[noFloat]
  117.         lea        dicobj[fltMem],a1
  118.         move.w    (a1),(a0)            ; Move free list hdr to blk being 
  119.                                     ;  freed
  120.         sub.l    a1,a0                ; Get offset of block
  121.         move.w    a0,(a1)                ; Store in free list header
  122.         pop.l    a1                    ; Restore a1
  123. ;code
  124.  
  125. :code (FLTDISP2)    \ Subroutine to dispose of floats in A0,A1
  126.                     \ Uses A0, A1, D0, D1
  127.         move.l    a1,d1                ; Save
  128.         cmpi.w    #1,-(a0)            ; Float must have $0001 in its status field
  129.         bne        dic[noFloat]
  130.         lea        dicobj[fltMem],a1
  131.         move.w    (a1),(a0)            ; Move free list hdr to blk being freed
  132.         sub.l    a1,a0                ; Get offset of block
  133.         move.w    a0,d0                ; Save in D0
  134.         move.l    d1,a0                ; Now the other one.
  135.         cmpi.w    #1,-(a0)            ; Float must have $0001 in its 
  136.                                     ;  status field
  137.         bne        dic[noFloat]
  138.         move.w    d0,(a0)                ; Move next free blk offs to blk being freed
  139.         sub.l    a1,a0                ; Get offset of block
  140.         move.w    a0,(a1)                ; Store in free list header
  141. ;code
  142.  
  143.  
  144. :code FLIT
  145.         bsr        dic[(fltNew)]        ; New float ptr to A0
  146.         push.l    a0                    ; Push it
  147.         move.l    (a7),a1
  148.         move.w    (a1)+,(a0)+            ; Literal is in 80-bit format
  149.         clr.w    (a0)+                ; Expand to FPU format
  150.         move.l    (a1)+,(a0)+
  151.         move.l    (a1)+,(a0)
  152.         move.l    a1,(a7)                ; Update return address
  153. ;code
  154.  
  155. :code (FPULIT)
  156.         move.l    (a7)+,a1
  157.         jmp        12(a1)
  158. ;code
  159.  
  160. :code FDUP
  161.         bsr        dic[(fltNew)]        ; New float to A0
  162.         move.l    (a6),a1                ; Float to dup to A1
  163.         push.l    a0                    ; Push new float
  164.         move.w    -2(a1),-2(a0)        ; Move status word
  165.         movem.l    (a1),d0-d2            ; Move data
  166.         movem.l    d0-d2,(a0)
  167. ;code
  168.  
  169. :code FOVER
  170.         bsr        dic[(fltNew)]        ; New float to A0
  171.         move.l    4(a6),a1            ; Float to copy to A1
  172.         push.l    a0                    ; Push new float
  173.         move.w    -2(a1),-2(a0)        ; Move status word
  174.         movem.l    (a1),d0-d2            ; Move data
  175.         movem.l    d0-d2,(a0)
  176. ;code
  177.     
  178. : F2DUP        fOver fOver  ;
  179.  
  180. :code FDROP
  181.         pop.l    a0
  182.         bra        dic[(fltDisp)]
  183. ;code
  184.  
  185. :code F2DROP
  186.         pop.l    a0
  187.         pop.l    a1
  188.         bra        dic[(fltDisp2)]
  189. ;code
  190.  
  191. ( ops opCode -- )
  192.  
  193. : FP68K        \ Call FP68K.  Floating-point package.
  194.     makeint  call pack4  ;  
  195.  
  196. : ELEMS68K    \ Call ELEMS68K.  Transcendentals package.
  197.     makeint  call pack5  ;
  198.  
  199.  
  200. \                ==============================
  201.  
  202. \                          FP code words
  203.  
  204. \                ==============================
  205.  
  206. $ 4E58    constant    XINFOMK            \ Must agree with defn in Defn.asm *****
  207.  
  208. : :FP1        \ ( opcode -- )
  209.     header
  210.     -80 w,                \ handler code FP1_h
  211.     xinfoMk w,            \ Marks this word as having extra non-code info
  212.     2 w,                \  which is 2 bytes long
  213.     w,                    \ This is it -- the opcode
  214.     postpone ]            \ start compiling
  215. ;  immediate
  216.  
  217.  
  218. : :FP2        \ ( opcode -- )
  219.     header
  220.     -82 w,                \ handler code FP2_h
  221.     xinfoMk w,            \ Marks this word as having extra non-code info
  222.     2 w,                \  which is 2 bytes long
  223.     w,                    \ This is it -- the opcode
  224.     postpone ]            \ start compiling
  225. ;  immediate
  226.  
  227.  
  228. : :FPcmp    \ ( opcode -- )
  229.     header
  230.     -84 w,                \ handler code FPcmp_h
  231.     xinfoMk w,            \ Marks this word as having extra non-code info
  232.     2 w,                \  which is 2 bytes long
  233.     w,                    \ This is it -- the opcode
  234.     postpone ]            \ start compiling
  235. ;  immediate
  236.  
  237.  
  238. \        =========== Dyadic comparisons ==========
  239.  
  240. :code FCMP2        \ ( flt0 flt1 -- abs1 abs2)  Subroutine to set up stack for
  241.                 \    dyadic comparison and kill floats.
  242.                 \    Uses D0,D1,D2 and A0,A1.
  243.         loc
  244. fcmp2    pop.l    a1                ; A1 -> flt1
  245.         move.l    (a6),a0            ; A0 -> flt0
  246.         move.w    (a0)+,(a0)        ; Convert both to 80-bit SANE format
  247.         move.w    (a1)+,(a1)
  248.         move.l    a1,(a6)
  249.         push.l    a0                ; Push addrs for SANE call.  Note
  250.                                 ;  SANE operands are reversed.
  251.         subq    #2,a0            ; Restore original float to A0/1 
  252.                                 ;  for (fltDisp2)
  253.         subq    #2,a1
  254.         moveq    #0,d2            ; Ready for result
  255.         bra    dic[(fltDisp2)]        ; Kill floats (but data still valid)
  256. ;code
  257.  
  258.  
  259. :code FPUCMP2    \ ( flt0 flt1 -- )  Subroutine to set up FPU for comparison.
  260.  
  261. FPUcmp2    pop.l    a1
  262.         pop.l    a0
  263.         fmove.x    (a0),fp0
  264. ;code
  265.  
  266.  
  267. \ Stack frame for all dyadic comparisons:
  268. \ ( float1 float2 -- b )
  269.  
  270. \ If we have an FPU, we use it.  In this case we defer as much
  271. \ housekeeping as possible to the time after the floating comparison
  272. \ but before we test the FPU condition code.  This time comes almost
  273. \ free of charge since it will be overlapped with the comparison op.
  274.  
  275. $ 3F0E  :FPcmp  F>
  276. ToCode
  277.         loc
  278.         tst.b    3(dic[FPU?])
  279.         beq.s    noFPU1
  280.         bsr.s    dic[FPUcmp2]
  281.         fcmp.x    (a1),fp0
  282.         bsr    dic[(fltDisp2)]
  283.         fsgt    d2
  284. FixBool    ext.w    d2
  285.         ext.l    d2
  286.         push.l    d2
  287.         rts
  288.  
  289. noFPU1    bsr.s    dic[Fcmp2]        ; Setup
  290.         push.w    #8                ; Code for FCMPX
  291.         exg    a6,a7
  292.         call    pack4
  293.         exg    a6,a7
  294.         sgt    d2
  295.         bra.s    fixBool
  296. ;code
  297.  
  298.  
  299. $ 3F0D  :FPcmp  F<
  300. ToCode
  301.         tst.b    3(dic[FPU?])
  302.         beq.s    noFPU2
  303.         bsr        dic[FPUcmp2]
  304.         fcmp.x    (a1),fp0
  305.         bsr        dic[(fltDisp2)]
  306.         fslt    d2
  307.         bra        fixBool
  308.  
  309. noFPU2    bsr    dic[Fcmp2]            ; Setup
  310.         push.w    #8                ; Code for FCMPX
  311.         exg    a6,a7
  312.         call    pack4
  313.         exg    a6,a7
  314.         slt    d2
  315.         bra    fixBool
  316. ;code
  317.  
  318. $ 3F0C  :FPcmp  F>=
  319. ToCode
  320.         tst.b    3(dic[FPU?])
  321.         beq.s    noFPU3
  322.         bsr        dic[FPUcmp2]
  323.         fcmp.x    (a1),fp0
  324.         bsr        dic[(fltDisp2)]
  325.         fsge    d2
  326.         bra        fixBool
  327.  
  328. noFPU3    bsr    dic[Fcmp2]            ; Setup
  329.         push.w    #8                ; Code for FCMPX
  330.         exg    a6,a7
  331.         call    pack4
  332.         exg    a6,a7
  333.         sge    d2
  334.         bra    fixBool
  335. ;code
  336.  
  337. $ 3F0F  :FPcmp  F<=
  338. ToCode
  339.         tst.b    3(dic[FPU?])
  340.         beq.s    noFPU4
  341.         bsr        dic[FPUcmp2]
  342.         fcmp.x    (a1),fp0
  343.         bsr        dic[(fltDisp2)]
  344.         fsle    d2
  345.         bra        fixBool
  346.  
  347. noFPU4    bsr    dic[Fcmp2]        ; Setup
  348.         push.w    #8            ; Code for FCMPX
  349.         exg        a6,a7
  350.         call    pack4
  351.         exg        a6,a7
  352.         sle        d2
  353.         bra        fixBool
  354. ;code
  355.  
  356. $ 3F07  :FPcmp  F=
  357. ToCode
  358.         tst.b    3(dic[FPU?])
  359.         beq.s    noFPU5
  360.         bsr        dic[FPUcmp2]
  361.         fcmp.x    (a1),fp0
  362.         bsr        dic[(fltDisp2)]
  363.         fseq    d2
  364.         bra        fixBool
  365.  
  366. noFPU5    bsr    dic[Fcmp2]        ; Setup
  367.         push.w    #8            ; Code for FCMPX
  368.         exg        a6,a7
  369.         call    pack4
  370.         exg        a6,a7
  371.         seq        d2
  372.         bra        fixBool
  373. ;code
  374.  
  375. $ 3F06  :FPcmp  F<>
  376. ToCode
  377.         tst.b    3(dic[FPU?])
  378.         beq.s    noFPU6
  379.         bsr        dic[FPUcmp2]
  380.         fcmp.x    (a1),fp0
  381.         bsr        dic[(fltDisp2)]
  382.         fsne    d2
  383.         bra        fixBool
  384.         rts
  385.  
  386. noFPU6    bsr    dic[Fcmp2]        ; Setup
  387.         push.w    #8            ; Code for FCMPX
  388.         exg        a6,a7
  389.         call    pack4
  390.         exg        a6,a7
  391.         sne        d2
  392.         bra        fixBool
  393. ;code
  394.  
  395.  
  396. \        ========= Monadic comparisons ==========
  397.  
  398. variable    FZERO        0 , 0 ,        \ Source of zero
  399.  
  400. :code FCMP1    \ ( flt -- abs )  Subroutine to set up stack for
  401.             \ monadic comparison and kill float.
  402.             \ Uses D0,D1,D2 and A0,A1.
  403.         loc
  404. fcmp1    move.l    (a6),a0            ; A0 -> flt
  405.         move.w    (a0)+,(a0)        ; Convert to 80-bit SANE format
  406.         lea        dic[FZero],a1
  407.         move.l    a1,(a6)
  408.         push.l    a0
  409.         subq    #2,a0            ; Restore original float to A0 for 
  410.                                 ;  (fltDisp)
  411.         moveq    #0,d2            ; Ready for result
  412.         bra        dic[(fltDisp)]    ; Kill float (but data still 
  413.                                 ;  valid)
  414. ;code
  415.  
  416.  
  417. $ 3F17  :FPcmp  F0=
  418. ToCode
  419.         loc
  420.         tst.b    3(dic[FPU?])
  421.         beq.s    noFPU1
  422.         pop.l    a0
  423.         ftst.x    (a0),fp0
  424.         bsr        dic[(fltDisp)]
  425.         fseq    d2
  426. FixBool    ext.w    d2
  427.         ext.l    d2
  428.         push.l    d2
  429.         rts
  430.  
  431. noFPU1    bsr        dic[Fcmp1]        ; Setup
  432.         push.w    #8                ; Code for FCMPX
  433.         exg        a6,a7
  434.         call    pack4
  435.         exg        a6,a7
  436.         seq        d2
  437.         bra.s    fixBool
  438. ;code
  439.  
  440. $ 3F16  :FPcmp  F0<>
  441. ToCode
  442.         tst.b    3(dic[FPU?])
  443.         beq.s    noFPU2
  444.         pop.l    a0
  445.         ftst.x    (a0),fp0
  446.         bsr        dic[(fltDisp)]
  447.         fsne    d2
  448.         bra        fixBool
  449.  
  450. noFPU2    bsr        dic[Fcmp1]        ; Setup
  451.         push.w    #8                ; Code for FCMPX
  452.         exg        a6,a7
  453.         call    pack4
  454.         exg        a6,a7
  455.         sne        d2
  456.         bra        fixBool
  457. ;code
  458.  
  459. $ 3F1C  :FPcmp  F0>=
  460. ToCode
  461.         tst.b    3(dic[FPU?])
  462.         beq.s    noFPU3
  463.         pop.l    a0
  464.         ftst.x    (a0),fp0
  465.         bsr        dic[(fltDisp)]
  466.         fsge    d2
  467.         bra        fixBool
  468.  
  469. noFPU3    bsr        dic[Fcmp1]    ; Setup
  470.         push.w    #8            ; Code for FCMPX
  471.         exg        a6,a7
  472.         call    pack4
  473.         exg        a6,a7
  474.         sge        d2
  475.         bra        fixBool
  476. ;code
  477.  
  478. $ 3F1D  :FPcmp  F0<
  479. ToCode
  480.         tst.b    3(dic[FPU?])
  481.         beq.s    noFPU4
  482.         pop.l    a0
  483.         ftst.x    (a0),fp0
  484.         bsr        dic[(fltDisp)]
  485.         fslt    d2
  486.         bra        fixBool
  487.  
  488. noFPU4    bsr        dic[Fcmp1]    ; Setup
  489.         push.w    #8            ; Code for FCMPX
  490.         exg        a6,a7
  491.         call    pack4
  492.         exg        a6,a7
  493.         slt        d2
  494.         bra        fixBool
  495. ;code
  496.  
  497. $ 3F1F  :FPcmp  F0<=
  498. ToCode
  499.         tst.b    3(dic[FPU?])
  500.         beq.s    noFPU5
  501.         pop.l    a0
  502.         ftst.x    (a0),fp0
  503.         bsr        dic[(fltDisp)]
  504.         fsle    d2
  505.         bra        fixBool
  506.  
  507. noFPU5    bsr        dic[Fcmp1]    ; Setup
  508.         push.w    #8            ; Code for FCMPX
  509.         exg        a6,a7
  510.         call    pack4
  511.         exg        a6,a7
  512.         sle        d2
  513.         bra        fixBool
  514. ;code
  515.  
  516. $ 3F1E  :FPcmp  F0>
  517. ToCode
  518.         tst.b    3(dic[FPU?])
  519.         beq.s    noFPU6
  520.         pop.l    a0
  521.         ftst.x    (a0),fp0
  522.         bsr        dic[(fltDisp)]
  523.         fsgt    d2
  524.         bra        fixBool
  525.  
  526. noFPU6    bsr        dic[Fcmp1]    ; Setup
  527.         push.w    #8            ; Code for FCMPX
  528.         exg        a6,a7
  529.         call    pack4
  530.         exg        a6,a7
  531.         sgt        d2
  532.         bra        fixBool
  533. ;code
  534.  
  535. \    =============== Arithmetic operators ==============
  536.  
  537. :code FOP2    \ ( flt0 flt1 -- flt0 addr1 addr0 )  Subroutine to set up for
  538.             \  2-operand operation, where flt0 takes the result.
  539.         loc
  540.         pop.l    a0                ; A0 -> flt1
  541.         move.l    (a6),a1            ; A1 -> flt0.  Also leave on stk for result.
  542.         move.w    (a0)+,(a0)        ; Convert both to 80-bit SANE format
  543.         move.w    (a1)+,(a1)
  544.         push.l    a0                ; Push addrs for SANE call.  Note SANE
  545.         push.l    a1                ;  operands are reversed.
  546.         subq    #2,a0            ; Restore original flt1 addr to A0 for (fltDisp)
  547.         bra        dic[(fltDisp)]    ; Kill flt1 (but data still valid)
  548. ;code
  549.  
  550. :code FOP1
  551.         move.l    (a6),a0
  552.         move.w    (a0)+,(a0)
  553.         push.l    a0
  554. ;code
  555.  
  556. :code ADJUST_RESULT    \ ( flt -- flt )
  557.         move.l    (a6),a0
  558.         move.w    2(a0),(a0)
  559.         clr.w    2(a0)
  560. ;code
  561.  
  562.  
  563. \ ( f1 f2 -- f1<op>f2 )  Result gets stored in f1's data.
  564.  
  565. $ 41 :fp2  F+
  566. ToCode
  567.         loc
  568.         tst.b    3(dic[FPU?])
  569.         beq.s    noFPU
  570.         pop.l    a0
  571.         move.l    (a6),a1
  572.         fmove.x (a1),fp0
  573.         fadd.x    (a0),fp0
  574.         bsr        dic[(fltDisp)]
  575.         move.l    (a6),a1
  576.         fmove.x fp0,(a1)
  577.         rts
  578.  
  579. noFPU    bsr.s    dic[fop2]    ; Setup
  580.         clr.w    -(a6)        ; Code for FADDX
  581.         exg        a6,a7
  582.         call    pack4
  583.         exg        a6,a7
  584.         bra        dic[adjust_result]
  585. ;code
  586.  
  587.  
  588. $ 48 :fp2  F-
  589. ToCode
  590.         loc
  591.         tst.b    3(dic[FPU?])
  592.         beq.s    noFPU
  593.         pop.l    a0
  594.         move.l    (a6),a1
  595.         fmove.x (a1),fp0
  596.         fsub.x    (a0),fp0
  597.         bsr        dic[(fltDisp)]
  598.         move.l    (a6),a1
  599.         fmove.x fp0,(a1)
  600.         rts
  601.  
  602. noFPU    bsr        dic[fop2]    ; Setup
  603.         push.w    #2            ; Code for FSUBX
  604.         exg        a6,a7
  605.         call    pack4
  606.         exg        a6,a7
  607.         bra        dic[adjust_result]
  608. ;code
  609.  
  610. $ 42 :fp2  F*
  611. ToCode
  612.         loc
  613.         tst.b    3(dic[FPU?])
  614.         beq.s    noFPU
  615.         pop.l    a0
  616.         move.l    (a6),a1
  617.         fmove.x    (a1),fp0
  618.         fmul.x    (a0),fp0
  619.         bsr        dic[(fltDisp)]
  620.         move.l    (a6),a1
  621.         fmove.x    fp0,(a1)
  622.         rts
  623.  
  624. noFPU    bsr        dic[fop2]    ; Setup
  625.         push.w    #4            ; Code for FMULX
  626.         exg        a6,a7
  627.         call    pack4
  628.         exg        a6,a7
  629.         bra        dic[adjust_result]
  630. ;code
  631.  
  632. $ 49 :fp2  F/
  633. ToCode
  634.         loc
  635.         tst.b    3(dic[FPU?])
  636.         beq.s    noFPU
  637.         pop.l    a0
  638.         move.l    (a6),a1
  639.         fmove.x (a1),fp0
  640.         fdiv.x    (a0),fp0
  641.         bsr        dic[(fltDisp)]
  642.         move.l    (a6),a1
  643.         fmove.x fp0,(a1)
  644.         rts
  645.  
  646. noFPU    bsr        dic[fop2]    ; Setup
  647.         push.w    #6            ; Code for FDIVX
  648.         exg        a6,a7
  649.         call    pack4
  650.         exg        a6,a7
  651.         bra        dic[adjust_result]
  652. ;code
  653.  
  654.  
  655. \        ============= Monadic operations ==============
  656.  
  657. \ FNEGATE and FABS simply operate on the sign bit, so we don't need to
  658. \ call SANE at all.  The SANE manual actually recommends this.
  659.  
  660. $ 55 :fp1  FNEGATE
  661. toCode
  662.         move.l    (a6),a0
  663.         bchg    #7,(a0)
  664. ;code
  665.  
  666. $ 54 :fp1 FABS
  667. toCode
  668.         move.l    (a6),a0
  669.         bclr    #7,(a0)
  670. ;code
  671.  
  672.  
  673. $ 5A :fp1 SQRT
  674. ToCode
  675.         loc
  676.         tst.b    3(dic[FPU?])
  677.         beq.s    noFPU
  678.         move.l    (a6),a0
  679.         fsqrt.x    (a0),fp0
  680.         fmove.x fp0,(a0)
  681.         rts
  682.  
  683. noFPU    move.l    (a6),a0
  684.         move.w    (a0)+,(a0)
  685.         push.l    a0
  686.         exg        a6,a7
  687.         move.w  #$12,-(a7)    ; FSQRTX
  688.         call    pack4
  689.         exg        a6,a7
  690.         bra        dic[adjust_result]
  691. ;code
  692.  
  693. hex
  694.  
  695. : ROUND        fop1  w 14  call pack4  adjust_result  ;
  696. : TRUNC        fop1  w 16  call pack4  adjust_result  ;
  697. : LOGBIN    fop1  w 1A  call pack4  adjust_result  ;
  698.  
  699. decimal
  700.  
  701. :code SCALEBIN        \ ( x n -- x*(2**n) )
  702.         loc
  703.         pop.l    hi
  704.         move.l    (a6),a0
  705.         exg        a6,a7
  706.         pea        lo
  707.         move.w    (a0)+,(a0)
  708.         move.l    a0,-(a7)
  709.         move.w    #$18,-(a7)    ; FSCALBX
  710.         call    pack4
  711.         exg        a6,a7
  712.         bra        dic[adjust_result]
  713.  
  714. hi    dc.w    0
  715. lo    dc.w    0
  716. ;code
  717.  
  718.  
  719. \    =========== Conversion to/from integers ============
  720.  
  721. :code FLOAT>    \ ( flt -- int32 )
  722.  
  723. \ Special note: the 68040's integrated FP doesn't implement
  724. \ FINTRZ -- so it's handled via a trap.  We definitely need to
  725. \ avoid this instruction!!!  The conversion can simply be done
  726. \ by FMOVEint the float to a D register.
  727.  
  728.         move.l    (a6),d2            ; Source float
  729.         move.l    d2,a0
  730.         bsr        dic[(fltDisp)]    ; Kill it
  731.         move.l    d2,a0
  732.         move.b    3(dic[useFPU?]),d0
  733.         beq.s    noFPU
  734.         fmove.x    (a0),fp0        ; get the number
  735.         fmove.l    fp0,(a6)        ; convert to integer
  736.         rts
  737.  
  738. noFPU    move.w    (a0)+,(a0)
  739.         move.l    a6,d0            ; Save result cell addr
  740.         push.l    a0                ; Source (the float data)
  741.         push.l    d0                ; Dest (the result cell)
  742.         push.w    #$2810            ; Extended to Longint
  743.         exg        a6,a7
  744.         call    pack4
  745.         exg        a6,a7
  746. ;code
  747.  
  748.  
  749. :code FLOAT>D    \ ( flt -- int64 )  We've added this in case someone 
  750.         \ needs to convert to a double integer.  SANE Comp 
  751.         \ format is essentially a double integer (the only 
  752.         \ difference is the special NaN value
  753.         \ $8000 0000 0000 0000)
  754.  
  755.         move.l    (a6),d2            ; Source float
  756.         move.l    d2,a0
  757.         bsr        dic[(fltDisp)]    ; Kill it
  758.         move.l    d2,a0
  759.         move.w    (a0)+,(a0)
  760.         subq    #4,a6            ; Make room for double result cell
  761.         move.l    a6,d0            ; Save result cell addr
  762.         push.l    a0                ; Source (the float data)
  763.         push.l    d0                ; Dest (the result cell)
  764.         push.w    #$3010            ; Extended to Comp
  765.         exg        a6,a7
  766.         call    pack4
  767.         exg        a6,a7
  768. ;code
  769.  
  770.  
  771. :code >FLOAT    \ ( int32 -- flt )
  772.         push.l    a6            ; Push ptr to the longint
  773.         bsr    dic[(fltNew)]    ; New float to A0
  774.         move.l    a0,d2        ; Save in D2
  775.         addq.l    #2,d2
  776.         push.l    d2
  777.         push.w    #$280E        ; Longint to Extended
  778.         exg        a6,a7
  779.         call    pack4
  780.         exg        a6,a7
  781.         move.l    d2,a0
  782.         move.w    (a0),-(a0)
  783.         clr.w    2(a0)
  784.         move.l    a0,(a6)        ; Replace the long cell with
  785.                             ;  float ptr
  786. ;code
  787.  
  788. :code D>FLOAT    \ ( int64 -- flt )
  789.         push.l    a6                ; Push ptr to the longint
  790.         bsr        dic[(fltNew)]    ; New float to A0
  791.         move.l    a0,d2            ; Save in D2
  792.         addq.l    #2,d2
  793.         push.l    d2
  794.         push.w    #$300E            ; Comp to Extended
  795.         exg        a6,a7
  796.         call    pack4
  797.         exg        a6,a7
  798.         addq    #4,a6
  799.         move.l    d2,a0
  800.         move.w    (a0),-(a0)
  801.         clr.w    2(a0)
  802.         move.l    a0,(a6)            ; Replace the double cell with 
  803.                                 ;  float ptr
  804. ;code
  805.  
  806. \    ============= Environmental control =============
  807.  
  808.     0    value    TMP
  809.  
  810. :code GETENV        \ ( -- env )
  811.         exg        a6,a7
  812.         pea        2(dic[tmp])
  813.         move.w    #3,-(a7)        ; FGETENV
  814.         call    pack4
  815.         exg        a6,a7
  816.         moveq    #0,d0
  817.         move.w    2(dic[tmp]),d0
  818.         push.l    d0
  819. ;code
  820.  
  821. :code SETENV        \ ( env -- )
  822.         pop.l    dic[tmp]
  823.         exg        a6,a7
  824.         pea        2(dic[tmp])
  825.         move.w    #1,-(a7)        ; FSETENV
  826.         call    pack4
  827.         exg        a6,a7
  828. ;code
  829.  
  830. \     =========== Masks for environment word ===========
  831.  
  832. hex
  833.  
  834. \ Rounding
  835.  
  836. 2000    constant    RoundUp
  837. 4000    constant    RoundDown
  838. 6000    constant    RoundToZero
  839.  
  840. \ Exception flags
  841.  
  842. 0100    constant    Invalid
  843. 0200    constant    Underflow
  844. 0400    constant    Overflow
  845. 0800    constant    Zdivide
  846. 1000    constant    Inexact
  847.  
  848. \ Halts
  849.  
  850. 0001    constant    InvHalt
  851. 0002    constant    UfHalt
  852. 0004    constant    OvHalt
  853. 0008    constant    ZDHalt
  854. 0010    constant    InxHalt
  855.  
  856. decimal
  857.  
  858. : SETHALT    \ ( proc-addr -- )
  859.     -> tmp  ['] tmp  w 5  call pack4  ;
  860.  
  861. : GETHALT    \ ( -- proc-addr )
  862.     ['] tmp  w 7  call pack4  tmp  ;
  863.  
  864.  
  865. :proc    FPERR    ." FP error"  cr
  866.     i->l ." opcode  " .h  cr
  867.     ." dst addr     " .h  cr
  868.     ." src addr     " .h  cr
  869.     ." src2 addr    " .h  cr
  870.     ." misc rec ptr " .h  cr        ;proc
  871.  
  872. ' FPerr  sethalt
  873.  
  874.  
  875. \            ===================================
  876.  
  877. \                FP named parms and locals
  878.  
  879. \            ===================================
  880.  
  881. \ In Mops, parms/locals are in D4-D7, and in the ExtraLocals area.
  882. \ Any floating locals have the float ptr in the D reg or XL location.
  883. \ To fetch a floating local, we compile
  884. \
  885. \    move.l    <whatever>,A1
  886. \    jsr    Lfloat
  887. \
  888. \ and to store or whatever to a floating local, we compile
  889. \
  890. \    move.l    <whatever>,D2
  891. \    move.w    #<opcode>,D1
  892. \    jsr        ToLfloat
  893. \    move.l    D2,<whatever>
  894. \
  895. \ Handlers does the hard work of generating this code (which isn't very
  896. \ hard, really).  Lfloat and ToLfloat are forward defined in the nucleus,
  897. \ and are resolved here.
  898. \ Note also, that for F@ which we use for some floating array accesses,
  899. \ we JSR to Lfloat+8, thus skipping the check for the status word that
  900. \ precedes scalar floats.
  901.  
  902. init: fltMem        \ In case we're reloading
  903.  
  904. :code FPOPS
  905.         fadd.x    (a0),fp0
  906.         rts
  907.         nop
  908.         fsub.x    (a0),fp0
  909.         rts
  910.         nop
  911.         fmul.x    (a0),fp0
  912.         rts
  913.         nop
  914.         fdiv.x    (a0),fp0
  915. ;code
  916.  
  917. :code (LFLOAT)
  918.         loc
  919.         cmpi.w    #1,-2(a1)        ; Check source
  920.         bne.s    noflt
  921.                                 ; F@ comes in here.
  922.         bsr        dic[(fltNew)]    ; Get new float to A0
  923.         push.l    a0                ; Push as result
  924. movit    movem.l    (a1),d0-d2        ; Move data
  925.         movem.l    d0-d2,(a0)
  926.         rts
  927.  
  928. noflt    move.l    a1,a0
  929.         bra        dic[NoFloat]
  930. ;code
  931.  
  932. :code (TOLFLOAT)
  933.         tst.l    d1
  934.         bpl.s    operate
  935.         tst.l    d2
  936.         beq.s    noDisp
  937.         move.l    d2,a0
  938.         bsr        dic[(fltDisp)]
  939. noDisp    pop.l    d2
  940.         rts
  941.  
  942. operate    tst.l    d2
  943.         beq        dic[notInit]
  944. oprt1    cmpi.w    #$003E,d1
  945.         bhs.s    AbsNeg
  946.         tst.b    3(dic[FPU?])
  947.         beq.s    noFPU
  948.  
  949.         move.l    d2,a0
  950.         fmove.x    (a0),fp0
  951.         move.l    (a6)+,a0
  952.         lea        dic[FPops],a1
  953.         lsl.w    #2,d1
  954.         jsr        0(a1,d1.w)
  955.         bsr        dic[(fltDisp)]        ; Do Fxxx  (A0),FP0
  956.         move.l    d2,a0
  957.         fmove.x    fp0,(a0)
  958.         rts
  959.  
  960. AbsNeg    move.l    d2,a0                ; Doesn't change CC
  961.         bhi.s    Neg
  962.         bclr    #7,(a0)
  963.         rts
  964.  
  965. Neg        bchg    #7,(a0)
  966.         rts
  967.  
  968. noFPU    move.l    (a6),a0
  969.         bsr        dic[(fltDisp)]
  970.         move.l    (a6),a0
  971.         move.w    (a0)+,(a0)
  972.         move.l    a0,(a6)
  973.         move.l    d2,a0
  974.         move.w    (a0)+,(a0)
  975.         push.l    a0
  976.         push.w    d1
  977.         exg        a6,a7
  978.         call    pack4
  979.         exg        a6,a7
  980.         move.l    d2,a0
  981.         move.w    2(a0),(a0)
  982.         clr.w    2(a0)
  983. ;code
  984.  
  985. :code (TOFVAL)
  986.         move.l    a1,d2
  987.         tst.w    d1
  988.         bpl        oprt1
  989.         pop.l    a0
  990.         movem.l    (a0),d0-d2
  991.         movem.l    d0-d2,(a1)
  992.         bra        dic[(fltDisp)]
  993. ;code
  994.  
  995. \ (LFDISP) disposes of floating locals and parms at the end of a definition.
  996. \ D2 = FltFlg, modified and shifted to exclude any operands in FP regs, so
  997. \ that the rightmost bit always means D4, and so on.  This longword has a
  998. \ bit set for every operand we need to dispose.
  999.  
  1000. :code (LFDISP)
  1001.         loc
  1002.         lsr.l    #1,d2
  1003.         bcc.s    chkd5a
  1004.         tst.l    d4
  1005.         beq.s    chkd5
  1006.         move.l    d4,a0
  1007.         bsr        dic[(fltDisp)]
  1008.  
  1009. chkd5    tst.l    d2
  1010. chkd5a    beq.s    end
  1011.         lsr.l    #1,d2
  1012.         bcc.s    chkd6a
  1013.         tst.l    d5
  1014.         beq.s    chkd6
  1015.         move.l    d5,a0
  1016.         bsr        dic[(fltDisp)]
  1017.     
  1018. chkd6    tst.l    d2
  1019. chkd6a    beq.s    end
  1020.         lsr.l    #1,d2
  1021.         bcc.s    chkd7a
  1022.         tst.l    d6
  1023.         beq.s    chkd7
  1024.         move.l    d6,a0
  1025.         bsr        dic[(fltDisp)]
  1026.  
  1027. chkd7    tst.l    d2
  1028. chkd7a    beq.s    end
  1029.         lsr.l    #1,d2
  1030.         bcc.s    chkXLa
  1031.         tst.l    d7
  1032.         beq.s    chkXL
  1033.         move.l    d7,a0
  1034.         bsr        dic[(fltDisp)]
  1035.  
  1036. chkXL    tst.l    d2
  1037. chkXLa    beq.s    end
  1038.         lea        dic[ExtraLocals],a1
  1039.  
  1040. XLloop    lsr.l    #1,d2
  1041.         bcc.s    XLnxta
  1042.         tst.l    (a1)
  1043.         beq.s    XLnxt
  1044.         move.l    (a1),a0
  1045.         bsr        dic[(fltDisp)]
  1046.  
  1047. XLnxt    tst.l    d2
  1048. XLnxta    beq.s    end
  1049.         addq.l    #4,a1
  1050.         bra.s    XLloop
  1051. end
  1052. ;code
  1053.  
  1054. \            ====================================
  1055.  
  1056. \                    Fvalues and Fcons
  1057.  
  1058. \            ====================================
  1059.  
  1060. \ In Mops, we handle Fvalues and Fcons along the same lines as floating
  1061. \ locals (which is logical).  Thus, to fetch an Fvalue/Fconstant, we compile
  1062. \
  1063. \    lea        <addr>,a1
  1064. \    jsr        Lfloat
  1065. \
  1066. \ and to store or whatever to a floating Value, we compile
  1067. \
  1068. \    lea        <addr>,a1
  1069. \    move.w    #<opcode>,d1
  1070. \    jsr        ToFval
  1071. \
  1072. \ As usual, Handlers takes care of this for us.  Here, we just have to make
  1073. \ sure that Fvalues and Fcons get the right handler code.  We also put a
  1074. \ "1" word in front of the float, so that Lfloat and ToLfloat won't think
  1075. \ it's an error.  They handle floating named parameters as well, so they do
  1076. \ need to check.
  1077.  
  1078. \ An FCRcon is essentially an Fcon, but is used for constants that are in
  1079. \ the 68881/2 ROM.  If we're compiling FPU code we use the ROM version which
  1080. \ is a lot faster.  But the floating value is stored in the dic as for an
  1081. \ Fcon as well in case there's no FPU.
  1082.  
  1083. : FLIT,        \ ( flt -- )
  1084.             \ Writes a float into dictionary: analogous to , or c,
  1085.             \ We omit the 2 unused bytes.  If we're compiling FPU code,
  1086.             \ we call CompFPUL instead of coming here.
  1087.     dup w@  here w!  2 allot
  1088.     dup 4+ here 8 cmove  8 allot  fdrop  ;
  1089.  
  1090. : FCON,        \ ( flt -- )
  1091.             \ As for FLIT, but we include the 2 unused bytes.  We handle
  1092.             \ FCONs and FVALs this way, since they are operated on by the
  1093.             \ same code as for floating locals.
  1094.     dup here 12 cmove  12 allot  fdrop  ;
  1095.  
  1096. : FVALUE
  1097.     header
  1098.     FvalCode w,            \ Handler code
  1099.     1 w,  fcon,  ;
  1100.  
  1101. : FCON
  1102.     header
  1103.     -76 w,                \ Fcon handler code
  1104.     1 w,  fcon,  ;
  1105.  
  1106. : FCRCON    \ ( offs -- )
  1107.     header
  1108.     -88 w,                \ FCRcon handler code
  1109.     w,                    \ ROM offset
  1110.     1 w,  fcon,  ;
  1111.  
  1112. header  F@
  1113.     -100 w,                \ handler code
  1114.     xinfoMk w,            \ "extra non-code info" of zero length means
  1115.     0 w,                \  compilation only
  1116.  
  1117.  
  1118. header  F!
  1119.     -102 w,                \ handler code
  1120.     xinfoMk w,            \ "extra non-code info" of zero length means
  1121.     0 w,                \  compilation only
  1122.  
  1123.  
  1124. \            =====================================
  1125. \                   FP to/from decimal conversion
  1126. \            =====================================
  1127.  
  1128. \ Some useful constants:
  1129.  
  1130.  256    constant    NEG
  1131.    0    constant    POS
  1132.  
  1133.  256    constant    FixedDecimal
  1134.    0    constant    FloatDecimal
  1135.  
  1136. false    value        VALID?    \ Needed by the scanner.  But we never
  1137.                     \  use it otherwise.
  1138.  
  1139. :code FP>        \ ( flt -- flt )
  1140.         move.l    (a6),a0
  1141.         cmpi.w    #1,-2(a0)
  1142.         bne        dic[noFloat]
  1143.         move.w    (a0)+,(a0)
  1144. ;code
  1145.  
  1146.  
  1147. :class  DEC    super{ object }
  1148.  
  1149.   \ SANE Record Decimal ( x = (-1)^sign * 10^exp * digits )
  1150.  
  1151.     int        SIGN
  1152.     int        EXP
  1153. 22    bytes    DIGITS        \ to fake string[20] ; 22 to make even
  1154.  
  1155.         int    INDEX        \ Used by the scanner.
  1156.  
  1157.   \ SANE Record DecForm
  1158.  
  1159.     int        STYLE
  1160.     int        #DIGITS        \ # of sig digits,if float;
  1161.                         \ # dec. places,if fixed.
  1162. :m CLEAR:
  1163.     addr: sign 26 erase  ;m
  1164.  
  1165. :m EINIT:    clear: self  FloatDecimal  put: style  19  put: #digits  ;m
  1166. :m FINIT:    clear: self  FixedDecimal  put: style  ;m
  1167.  
  1168. :m SETSTYLE:    put: style    ;m
  1169. :m SET#DIGITS:    put: #digits    ;m
  1170. :m SETEXP:        put: exp    ;m
  1171. :m EXP:            get: exp    ;m
  1172. :m SIGN:        get: sign    ;m
  1173.  
  1174. :m ZERO:        \ Puts a zero in decimal record
  1175.     clear: self  $ 0130  addr: #digits  w!  ;m
  1176.  
  1177. :m >FLOAT:  { \ flt  -- flt }
  1178.         ^base                        \ Addr of decimal record
  1179.         new: fltMem -> flt  flt 2+    \ Destination address
  1180.         $ 0009                        \ FFEXT FOD2B + -- Opcode for decimal to
  1181.                                     \           binary; dest=extended
  1182.         fp68k  flt adjust_result
  1183. ;m
  1184.  
  1185. \ =>: converts the passed-in float to decimal.
  1186.  
  1187. :m =>:  { flt -- }
  1188.     addr: style                        \ Addr of decform record
  1189.     flt FP> 2+                        \ Addr of source
  1190.     ^base                            \ Addr of decimal record
  1191.     $ 000B                            \ FFEXT FOB2D + -- Opcode for binary to
  1192.                                     \                   decimal; source=extended
  1193.     fp68k  flt fdrop  ;m            \ Call SANE, dispose of float
  1194.  
  1195. \ Ascii input
  1196.  
  1197. :m SCAN:    \ ( addr len -- )
  1198.     str255  1+
  1199.     clear: index  addr: index
  1200.     ^base  ['] valid? 3+  w 2  call Pack7  ;m
  1201.  
  1202. :m CONV?:  { addr len -- b }
  1203.         \ Attempts to convert the passed-in string, using SCAN:.
  1204.         \ Returns True if all the input was read.  Otherwise
  1205.         \ we assume the terminating (non-scanned) character is
  1206.         \ invalid, and return False.
  1207.     addr len  scan: self
  1208.     get: index  len  =  ;m
  1209.  
  1210. \ Ascii output
  1211.  
  1212. :m FORMAT:    \ ( -- addr len )
  1213.     addr: style  ^base  pad  w 3  call Pack7
  1214.     pad count  ;m
  1215.  
  1216. :m PRINT:
  1217.     format: self  type  ;m
  1218.  
  1219. :m DUMP:
  1220.     ." sign:    "    get: sign  IF  & -  ELSE  & +  THEN  emit  cr
  1221.     ." exp:     "    get: exp  .  cr
  1222.     addr: digits  count  type  cr
  1223.     ." style:   "    get: style  IF  ." fixed"  ELSE  ." float"  THEN  cr
  1224.     ." index:   "    get: index  .  cr
  1225.     ." #digits: "    get: #digits  .  cr  ;m
  1226.     
  1227. ;class
  1228.  
  1229. dec    theDec
  1230.  
  1231. : #DIGITS    set#digits: theDec  ;
  1232.  
  1233. : E.R  { flt wid \ svOut -- }
  1234.     out -> svOut
  1235.     floatDecimal  setStyle: theDec
  1236.     wid 6 -  #digits        \ Allow for point, sign, and e+nn
  1237.     flt =>: theDec
  1238.     print: theDec
  1239.     wid  out svOut -  -  spaces  ;
  1240.  
  1241. : E.    26 e.r  ;
  1242.  
  1243. : F.R  { flt wid \ #dig svOut -- }
  1244.     out -> svOut
  1245.     floatDecimal  setStyle: theDec
  1246.     wid 2-  #digits            \ Allow for sign and dec point
  1247.     flt =>: theDec
  1248.     fixedDecimal setStyle: theDec
  1249.     exp: theDec  negate  dup -> #dig  #digits
  1250.     sign: theDec NIF  space  THEN
  1251.     #dig NIF  space  THEN        \ In this case, no dec point
  1252.     print: theDec
  1253.     wid  out svOut -  -  spaces  ;
  1254.  
  1255. : FCONV?  { addr len \ flt -- flt T  |  -- F }
  1256.                 \ Converts the passed-in ASCII string to
  1257.                 \ floating, if possible.  I like this name better
  1258.                 \ than ATOF which Neon had, but change it back if
  1259.                 \ you want to.
  1260.     addr len  conv?: thedec  NIF  false  EXIT  THEN
  1261.     new: fltMem -> flt
  1262.     thedec  flt 2+  9  FP68K
  1263.     flt adjust_result  true  ;
  1264.  
  1265.  
  1266. \            ==============================
  1267.  
  1268. \                      Interpretation
  1269.  
  1270. \            ==============================
  1271.  
  1272.  
  1273. : FNUMBER    \ ( addr -- flt T  |  -- F )
  1274.             \ Attempts to convert token at addr to a float.
  1275.     count  fconv?  ;
  1276.  
  1277.  
  1278. : FLITERAL  { flt -- }    \ Compiles an in-line float.
  1279.     useFPU?
  1280.     IF    flt 8 + @  flt 4+ @  flt @  compFPUL  flt fdrop
  1281.     ELSE    postpone flit  flt flit,
  1282.     THEN  ;
  1283.  
  1284.  
  1285. : (FNUM)  { addr -- flt T  |  -- addr F }
  1286.         \ Checks if string at Here is a float, defined by containing
  1287.         \ a decimal point.  Error if there is a point, but not a legal
  1288.         \ float.
  1289.     addr count  & .  scan  nip  NIF  addr  false  EXIT  THEN
  1290.     addr fnumber  ?notFound
  1291.     state  IF  fLiteral  THEN  true  ;
  1292.  
  1293.  
  1294. : FLOAT?  { adr -- b }
  1295.     adr 1 and  IF  false  EXIT  THEN
  1296.     adr  ['] fltmem   >
  1297.     adr  ['] (fltnew) <
  1298.     and  NIF  false  EXIT  THEN
  1299.     adr 2- w@ 1 =  ;
  1300.  
  1301.  
  1302. ' (Lfloat)    -> ^Lfloat        \ So f@ below will compile properly
  1303.  
  1304. : (.CELLF)  { adr -- }        \ FP version of stack cell typing word
  1305.     adr @ float?
  1306.     IF        adr @ f@ e.
  1307.     ELSE    adr @ .
  1308.     THEN  ;
  1309.  
  1310.  
  1311. : FPINIT    \ Initialization word for FP package
  1312.     init: fltMem
  1313.     ['] (fltNew)    -> ^FPnew
  1314.     ['] (fltDisp)    -> ^FPdisp
  1315.     ['] (fltDisp2)    -> ^FPdisp2
  1316.     ['] (Lfloat)    -> ^Lfloat
  1317.     ['] (ToLfloat)    -> ^ToLfloat
  1318.     ['] (ToFval)    -> ^ToFval
  1319.     ['] (LFdisp)    -> ^LFdisp
  1320.     ['] (FPUlit)    -> ^FPULit
  1321.     ['] (.cellf)    -> .cell
  1322. ;
  1323.  
  1324.  
  1325. : CLEANFLOAT    \ New error word
  1326.     cl3  init: fltMem  ;
  1327.  
  1328.  
  1329. : MOPS>FLT
  1330.     ['] (Fnum) -> Fnum?
  1331.     ['] FPinit  add: init_actions
  1332.     ['] cleanFloat -> abortVec  ;
  1333.  
  1334.  
  1335. : MOPS>INT
  1336.     0 -> Fnum?
  1337.     ['] FPinit  removeXT: init_actions
  1338.     ['] cl3 -> abortVec  ;
  1339.  
  1340. FPinit  mops>flt
  1341.  
  1342.  
  1343. \                =================================
  1344. \                          Transcendentals
  1345. \                =================================
  1346.  
  1347. :code LN        \ Natural log
  1348.         move.l    (a6),a0
  1349.         move.w    (a0)+,(a0)
  1350.         push.l    a0
  1351.         exg        a6,a7
  1352.         clr.w    -(a7)            ; FLNX code
  1353.         call    pack5
  1354.         exg        a6,a7
  1355.         bra        dic[adjust_result]
  1356. ;code
  1357.  
  1358. :code LOG2        \ Base 2 log
  1359.         move.l    (a6),a0
  1360.         move.w    (a0)+,(a0)
  1361.         push.l    a0
  1362.         exg        a6,a7
  1363.         move.w  #2,-(a7)        ; FLOG2X
  1364.         call    pack5
  1365.         exg        a6,a7
  1366.         bra        dic[adjust_result]
  1367. ;code
  1368.  
  1369. :code LN1        \ ln(1+x)
  1370.         move.l    (a6),a0
  1371.         move.w    (a0)+,(a0)
  1372.         push.l    a0
  1373.         exg        a6,a7
  1374.         move.w  #4,-(a7)        ; FLN1X
  1375.         call    pack5
  1376.         exg        a6,a7
  1377.         bra        dic[adjust_result]
  1378. ;code
  1379.  
  1380. :code LOG21        \ log2(1+x).  I don't think LOG21 is a very helpful name
  1381.                 \  (pure computerese), but I guess we're stuck with it.
  1382.         move.l    (a6),a0
  1383.         move.w    (a0)+,(a0)
  1384.         push.l    a0
  1385.         exg        a6,a7
  1386.         move.w  #6,-(a7)        ; FLOG21X
  1387.         call    pack5
  1388.         exg        a6,a7
  1389.         bra        dic[adjust_result]
  1390. ;code
  1391.  
  1392. :code EXP        \ Base e exponential
  1393.         move.l    (a6),a0
  1394.         move.w    (a0)+,(a0)
  1395.         push.l    a0
  1396.         exg        a6,a7
  1397.         move.w  #8,-(a7)        ; FEXPX
  1398.         call    pack5
  1399.         exg        a6,a7
  1400.         bra        dic[adjust_result]
  1401. ;code
  1402.  
  1403. :code EXP2        \ Base 2 exponential
  1404.         move.l    (a6),a0
  1405.         move.w    (a0)+,(a0)
  1406.         push.l    a0
  1407.         exg        a6,a7
  1408.         move.w  #$A,-(a7)        ; FEXP2X
  1409.         call    pack5
  1410.         exg        a6,a7
  1411.         bra        dic[adjust_result]
  1412. ;code
  1413.  
  1414. :code EXP1        \ e**x - 1
  1415.         move.l    (a6),a0
  1416.         move.w    (a0)+,(a0)
  1417.         push.l    a0
  1418.         exg        a6,a7
  1419.         move.w  #$C,-(a7)        ; FEXP1X
  1420.         call    pack5
  1421.         exg        a6,a7
  1422.         bra        dic[adjust_result]
  1423. ;code
  1424.  
  1425. :code EXP21    \ 2**x - 1
  1426.         move.l    (a6),a0
  1427.         move.w    (a0)+,(a0)
  1428.         push.l    a0
  1429.         exg        a6,a7
  1430.         move.w  #$E,-(a7)        ; FEXP21X
  1431.         call    pack5
  1432.         exg        a6,a7
  1433.         bra        dic[adjust_result]
  1434. ;code
  1435.  
  1436. :code **N    \ ( x n -- x**n )  Integer exponentiation.  This wasn't
  1437.             \  in Neon, but might be useful.  Note this operation
  1438.             \  ignores the high-order 16 bits of n.
  1439.         loc
  1440.         pop.l    hi
  1441.         move.l    (a6),a0
  1442.         move.w    (a0)+,(a0)
  1443.         exg        a6,a7
  1444.         pea        lo
  1445.         move.l    a0,-(a7)
  1446.         move.w    #$8010,-(a7)    ; FXPWRI
  1447.         call    pack5
  1448.         exg        a6,a7
  1449.         bra        dic[adjust_result]
  1450.  
  1451. hi        dc.w    0
  1452. lo        dc.w    0
  1453. ;code
  1454.  
  1455. :code F**    \ ( x y -- x**y )  General exponentiation - takes 2 floats.
  1456.             \  Here I think the Neon name was crazy.  But we've still
  1457.             \  got it below for compatibility.
  1458.         bsr        dic[fop2]
  1459.         move.w    #$8012,-(a6)    ; FXPWRY
  1460.         exg        a6,a7
  1461.         call    pack5
  1462.         exg        a6,a7
  1463.         bra        dic[adjust_result]
  1464. ;code
  1465.  
  1466. :code X**Y            \ For Neon compatibility
  1467.     bra.s    dic[f**]
  1468. ;code
  1469.  
  1470.  
  1471. \ Financial functions.  I never have enough finances to need these myself.
  1472.  
  1473. :code COMPOUND    \ ( rate #periods -- compound_interest)
  1474.  
  1475.         bsr    dic[(fltNew)]        ; New float to A0 (will be 
  1476.                                 ;  result). Must get before
  1477.         move.l    a0,d2            ;  killing src floats. Save in D2
  1478.         pop.l    a0
  1479.         pop.l    a1
  1480.         move.w    (a0)+,(a0)
  1481.         move.w    (a1)+,(a1)
  1482.         push.l    a1
  1483.         push.l    a0
  1484.         subq    #2,a0
  1485.         subq    #2,a1
  1486.         bsr        dic[(fltDisp2)]        ; Kill source floats
  1487.         move.l    d2,a0
  1488.         move.w    (a0)+,(a0)
  1489.         push.l    a0    ; Destination
  1490.         push.w    #$C014
  1491.         exg        a6,a7
  1492.         call    pack5
  1493.         exg        a6,a7
  1494.         push.l    d2
  1495.         bsr        dic[adjust_result]
  1496. ;code
  1497.     
  1498. :code ANNUITY    \ ( rate #periods -- annuity)
  1499.         bsr        dic[(fltNew)]    ; New float to A0 (will be 
  1500.                                 ;  result). Must get before
  1501.         move.l    a0,d2            ;  killing src floats. Save in D2
  1502.         pop.l    a0
  1503.         pop.l    a1
  1504.         move.w    (a0)+,(a0)
  1505.         move.w    (a1)+,(a1)
  1506.         push.l    a1
  1507.         push.l    a0
  1508.         subq    #2,a0
  1509.         subq    #2,a1
  1510.         bsr        dic[(fltDisp2)]            ; Kill source floats
  1511.         move.l    d2,a0
  1512.         move.w    (a0)+,(a0)
  1513.         push.l    a0    ; Destination
  1514.         push.w    #$C016
  1515.         exg        a6,a7
  1516.         call    pack5
  1517.         exg        a6,a7
  1518.         push.l    d2
  1519.         bsr        dic[adjust_result]
  1520. ;code
  1521.  
  1522.  
  1523. \ Trig functions.
  1524.  
  1525. $ 56 :fp1 SIN
  1526. ToCode
  1527.         loc
  1528.         tst.b    3(dic[FPU?])
  1529.         beq.s    noFPU
  1530.         move.l    (a6),a0
  1531.         fsin.x    (a0),fp0
  1532.         fmove.x fp0,(a0)
  1533.         rts
  1534.  
  1535. noFPU    move.l    (a6),a0
  1536.         move.w    (a0)+,(a0)
  1537.         push.l    a0
  1538.         exg        a6,a7
  1539.         move.w  #$18,-(a7)    ; FSINX
  1540.         call    pack5
  1541.         exg        a6,a7
  1542.         bra        dic[adjust_result]
  1543. ;code
  1544.  
  1545. $ 57 :fp1 COS
  1546. ToCode
  1547.         loc
  1548.         tst.b    3(dic[FPU?])
  1549.         beq.s    noFPU
  1550.         move.l    (a6),a0
  1551.         fcos.x    (a0),fp0
  1552.         fmove.x fp0,(a0)
  1553.         rts
  1554.  
  1555. noFPU    move.l    (a6),a0
  1556.         move.w    (a0)+,(a0)
  1557.         push.l    a0
  1558.         exg        a6,a7
  1559.         move.w  #$1A,-(a7)        ; FCOSX
  1560.         call    pack5
  1561.         exg        a6,a7
  1562.         bra        dic[adjust_result]
  1563. ;code
  1564.  
  1565. $ 58 :fp1 TAN
  1566. ToCode
  1567.         loc
  1568.         tst.b    3(dic[FPU?])
  1569.         beq.s    noFPU
  1570.         move.l    (a6),a0
  1571.         ftan.x    (a0),fp0
  1572.         fmove.x fp0,(a0)
  1573.         rts
  1574.  
  1575. noFPU    move.l    (a6),a0
  1576.         move.w    (a0)+,(a0)
  1577.         push.l    a0
  1578.         exg        a6,a7
  1579.         move.w  #$1C,-(a7)        ; FTANX
  1580.         call    pack5
  1581.         exg        a6,a7
  1582.         bra        dic[adjust_result]
  1583. ;code
  1584.  
  1585. $ 59 :fp1 ARCTAN
  1586. ToCode
  1587.         loc
  1588.         tst.b    3(dic[FPU?])
  1589.         beq.s    noFPU
  1590.         move.l    (a6),a0
  1591.         fatan.x    (a0),fp0
  1592.         fmove.x fp0,(a0)
  1593.         rts
  1594.  
  1595. noFPU    move.l    (a6),a0
  1596.         move.w    (a0)+,(a0)
  1597.         push.l    a0
  1598.         exg        a6,a7
  1599.         move.w  #$1E,-(a7)    ; FATANX
  1600.         call    pack5
  1601.         exg        a6,a7
  1602.         bra        dic[adjust_result]
  1603. ;code
  1604.  
  1605.  
  1606. :code FRAND        \ floating-pt random number routine
  1607.         move.l    (a6),a0
  1608.         move.w    (a0)+,(a0)
  1609.         push.l    a0
  1610.         exg        a6,a7
  1611.         move.w  #$20,-(a7)
  1612.         call    pack5
  1613.         exg        a6,a7
  1614.         bra        dic[adjust_result]
  1615. ;code
  1616.  
  1617.  
  1618. \            ======================================
  1619. \            Sundry useful constants and operations
  1620. \            ======================================
  1621.  
  1622. 1.0            fcon    1.0
  1623. 0.0            fcon    0.0
  1624. 1.0 exp        fcon    E
  1625. 10.0 ln        fcon    LN(10)
  1626.  
  1627. 0.0        fcon    PI                \ Not the real value yet!!!
  1628. 0.0        fcon    UNDEF            \ Ditto
  1629.  
  1630. : SetPi  { \ adr -- }            \ Sets up PI according to the value in the
  1631.                                 \ 68882 ROM.
  1632.     ['] pi -> adr
  1633.     $ 40000000    adr 2+     !
  1634.     $ C90FDAA2    adr 6 +     !
  1635.     $ 2168C235    adr 10 + !  ;
  1636.  
  1637. : SetUndef  { \ adr -- }        \ Sets up UNDEF to NAN(255).
  1638.     ['] undef -> adr
  1639.     $ 7FFF0000    adr 2+ !
  1640.     $ FFFFFFFF    adr 6 + !
  1641.     $ FFFFFFFF    adr 10 + !  ;
  1642.  
  1643. SetPi   SetUndef        forget SetPi
  1644.  
  1645. \ 0    FCRcon    PI
  1646.  
  1647. : 1/X    1.0 swap f/  ;
  1648.  
  1649. : LOG        \ ( x -- log(x) )  Log base 10 of x
  1650.     ln ln(10) f/  ;
  1651.  
  1652. : ANTILOG    \ ( x -- antilog(x) )  Antilog ( 10^x ) of x
  1653.     ln(10) f* exp  ;
  1654.  
  1655. : COT        \ ( x -- cot(x) )  Cotangent of x
  1656.     tan 1/x  ;
  1657.   
  1658. : DEG2RAD    \ ( deg -- rad )  Converts degrees to radians
  1659.     pi f* 180. f/  ;
  1660.  
  1661. : RAD2DEG    \ ( rad -- deg )  Converts radians to degrees
  1662.     180. f* PI f/  ;
  1663.  
  1664.  
  1665. \            ===================================
  1666. \                        Class Float
  1667. \            ===================================
  1668.  
  1669. \ Class Float allows a floating value to be a high-level object, which
  1670. \ means it can be an ivar.  There is something of a performance
  1671. \ penalty if FPU code is being generated, since a Float object must
  1672. \ be in main memory, which increases the amount of data movement
  1673. \ between the FPU and the integer unit.  This is slow on a 68030, but
  1674. \ shouldn't be such a problem on a 68040.
  1675.  
  1676.  
  1677. :class  FLOAT  super{ object }
  1678.  
  1679. 12    bytes    data
  1680.  
  1681. :m GET:        \ ( -- x )    Pushes private data onto stack
  1682.     inline{ obj f@}  ^base f@  ;m
  1683.  
  1684. :m PUT:        \ ( x -- ) store float into private data
  1685.     inline{ obj f!}  ^base f!  ;m
  1686.  
  1687. :m ->:        \ ( float -- )  Assigns value of passed-in Float to this Float
  1688.     inline{ f@ obj f!}
  1689.     f@  ^base f!  ;m
  1690.  
  1691.  
  1692. \ ----- Arithmetic operations take a stack float (not a Float obj)
  1693.  
  1694. :m +:
  1695.     inline{ obj f@ f+ obj f!}
  1696.     ^base f@  f+  ^base f!  ;m
  1697.  
  1698. :m -:
  1699.     inline{ obj f@ f- obj f!}
  1700.     ^base f@  f-  ^base f!  ;m
  1701.  
  1702. :m *:
  1703.     inline{ obj f@ f* obj f!}
  1704.     ^base f@  f*  ^base f!  ;m
  1705.  
  1706. :m /:
  1707.     inline{ obj f@ f/ obj f!}
  1708.     ^base f@  f/  ^base f!  ;m
  1709.  
  1710. :m SIN:        \ ( -- sin )  returns sine of object  
  1711.     inline{ obj f@ sin}
  1712.     ^base f@  sin  ;m
  1713.     
  1714. :m COS:        \ ( -- cos )  returns cosine of object  
  1715.     inline{ obj f@ cos}
  1716.     ^base f@  cos  ;m
  1717.  
  1718. :m TAN:        \ ( -- tan )  returns tangent of object  
  1719.     inline{ obj f@ tan}
  1720.     ^base f@  tan  ;m
  1721.  
  1722. :m ARCTAN:    \ ( -- arcTan)  returns arctangent of object  
  1723.     inline{ obj f@ arctan}
  1724.     ^base f@  arctan  ;m
  1725.  
  1726. :m LN:        \ ( -- ln)  returns natural log of object  
  1727.     inline{ obj f@ ln}
  1728.     ^base f@  ln  ;m
  1729.  
  1730. :m EXP:        \ ( -- exp )  returns exp of object  
  1731.     inline{ obj f@ exp}
  1732.     ^base f@  exp  ;m
  1733.  
  1734. :m LOG:        \ ( -- log )  returns log base 10 of object  
  1735.     inline{ obj f@ log}
  1736.     ^base f@  log  ;m
  1737.  
  1738. :m ANTILOG:    \ ( -- 10**x )  returns antilog of object  
  1739.     inline{ obj f@ antilog}
  1740.     ^base f@  antilog  ;m
  1741.  
  1742. :m DEG:        \ ( -- degrees )  converts radians to degrees
  1743.     inline{ obj f@ rad2deg}
  1744.     ^base f@  rad2deg  ;m
  1745.  
  1746. :m RAD:        \ ( -- radians )  converts from radians to degrees
  1747.     inline{ obj f@ deg2rad}
  1748.     ^base f@  deg2rad  ;m
  1749.  
  1750. :m ABSVAL:    \ ( -- abs )  Returns absolute value.
  1751.     inline{ obj f@ fabs}
  1752.     ^base f@  fabs  ;m
  1753.  
  1754. :mcode  ABS:    \ ( -- )  Replaces obj's data with its absolute. Doesn't
  1755.                 \            return anything.
  1756.         bclr    #7,(a2)
  1757. ;mcode
  1758.  
  1759. :m NEG:        \ ( -- val )  Returns object value with sign negated
  1760.     inline{ obj f@ fnegate}
  1761.     ^base f@ fnegate  ;m
  1762.  
  1763. :mcode  NEGATE:    \ ( -- )  Negates the object's data. Doesn't return anything.
  1764.         bchg    #7,(a2)
  1765. ;mcode
  1766.  
  1767. :m PRINT:    ^base f@  e.  ;m
  1768.  
  1769. ;class
  1770.  
  1771.  
  1772. \            =================================
  1773. \                    Floating arrays
  1774. \            =================================
  1775.  
  1776.  
  1777. :code (^ELEM)    \ ( idx -- ) A subroutine to get the element addr to A1.
  1778.         loc
  1779.         pop.l    d0    ; d0 = index
  1780.         move.l    a2,a1
  1781.         add.w    -2(a1),a1        ; now a1 -> ^class
  1782.         add.w    -2(a1),a1        ; now a1 -> start of indexed area
  1783.         tst.w    -4(a1)            ; Skip bounds check if this is
  1784.         bne.s    mul12            ;  a LARGE farray
  1785.         chk        -2(a1),d0        ; bounds check
  1786. mul12    move.l    d0,d1            ; mult by 12 and add to index base in a1
  1787.         add.l    d1,d0
  1788.         add.l    d1,d0
  1789.         asl.l    #2,d0
  1790.         add.l    d0,a1            ; Element addr to a1
  1791. ;code
  1792.  
  1793.  
  1794. :class     FARRAY    super{ indexed-obj }  12 indexed
  1795.  
  1796. :mcode ^ELEM:    \ ( idx -- addr )
  1797.         bsr.s    dic[(^Elem)]
  1798.         push.l    a1
  1799. ;mcode
  1800.  
  1801. :mcode  AT:
  1802.         bsr        dic[(^Elem)]    ; Get element addr to a1
  1803.         bsr        dic[(fltNew)]    ; New float to a0
  1804.         push.l    a0                ; Push it
  1805.         movem.l    (a1),d0-d2
  1806.         movem.l    d0-d2,(a0)        ; Move data over
  1807. ;mcode
  1808.  
  1809. :mcode TO:        \ ( flt idx -- )
  1810.         bsr        dic[(^Elem)]    ; Get element addr to a1
  1811.         pop.l    a0
  1812.         movem.l    (a0),d0-d2        ; Move data over
  1813.         movem.l    d0-d2,(a1)
  1814.         bsr        dic[(fltDisp)]    ; Dispose of stack float
  1815. ;mcode
  1816.  
  1817. :m FILL:        \ ( x -- )  Fills all elements with x
  1818.         limit 0 DO  fdup  i to: self  LOOP  fdrop   ;m
  1819.  
  1820. :m PRINT:    \ Prints all elements
  1821.         limit: self 0 ?DO  i dup  4 .r  space  at: self  e. cr
  1822.         LOOP  ;m
  1823.  
  1824. :m CLASSINIT:
  1825.         undef
  1826.         limit: self  FOR  fdup  i  to: self  NEXT  fdrop  ;m
  1827.  
  1828. ;class
  1829.