home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / tutor / l5p110 < prev    next >
Encoding:
Text File  |  1990-07-15  |  3.8 KB  |  89 lines
  1. \      ╔════════════════════════════════════════════════════╗
  2. \      ║ Lesson 5 Part 110  F-PC 3.5 Tutorial by Jack Brown ║
  3. \      ╚════════════════════════════════════════════════════╝
  4.  
  5. \ Part two of CHKBOOK.SEQ
  6.  
  7. /* ************************************************************ */
  8. /* Function: CLR_HBAR   Clear screan and draw horizontal bar    */
  9. /*                                                              */
  10. /* Date: July 25, 1988                                          */
  11. /*                                                              */
  12. /* Interface:   CLR_HBAR ( n   -- )                             */
  13. /*                                                              */
  14. /* ************************************************************ */
  15.  
  16. : CLR_HBAR ( n  -- )
  17.      27 EMIT ." [2J" CR HBAR ;
  18.  
  19. /* ************************************************************ */
  20. /* Function: GET_DOLLARS   Fetch dollars with error checking.   */
  21. /*                                                              */
  22. /* Date: July 22, 1988                                          */
  23. /*                                                              */
  24. /* Interface:   GET_DOLLARS ( --  n )                           */
  25. /*                                                              */
  26. /* ************************************************************ */
  27.  
  28. : GET_DOLLARS ( --  n )
  29.       BEGIN
  30.       27 EMIT ." [K Dollars: "
  31.       SCAN_FOR_INT CR DUP
  32.       9999 > OVER 0 < OR
  33.       WHILE
  34.       DROP 27 EMIT ." [1;A"
  35.       REPEAT ;
  36.  
  37. /* ************************************************************ */
  38. /* Function: GET_CENTS   Fetch cents with error checking.       */
  39. /*                                                              */
  40. /* Date: July 22, 1988                                          */
  41. /*                                                              */
  42. /* Interface:   GET_CENTS ( --  n )                             */
  43. /*                                                              */
  44. /* ************************************************************ */
  45.  
  46. : GET_CENTS ( --   n )
  47.         BEGIN
  48.         27 EMIT ." [K Cents: "
  49.         SCAN_FOR_INT CR DUP
  50.         99 > OVER 0 < OR
  51.         WHILE
  52.         DROP
  53.         27 EMIT ." [1;A"
  54.         REPEAT ;
  55.  
  56. /* ************************************************************ */
  57. /*                                                              */
  58. /* Function:    ROUND     - Roll cents into dollars.            */
  59. /*                                                              */
  60. /* Date: July 25, 1988                                          */
  61. /*                                                              */
  62. /* Interface:   ROUND ( dollars cents -- dollars' cents' )      */
  63. /*                                                              */
  64. /* ************************************************************ */
  65.  
  66. : ROUND ( dollars cents -- dollars' cents')
  67.       DUP >R
  68.       100 / +
  69.       R> 100 MOD ;
  70.  
  71. /* ************************************************************ */
  72. /*                                                              */
  73. /* Function: ADD_TO_BAL - Add dollars, cents amount to balance  */
  74. /*                                                              */
  75. /* Date: July 22, 1988                                          */
  76. /*                                                              */
  77. /* Interface:    ADD_TO_BAL ( dollars cents  -- )               */
  78. /*               dollars: dollar amount to be added             */
  79. /*               cents  : cents amount to be added              */
  80. /*                                                              */
  81. /* ************************************************************ */
  82.  
  83. : ADD_TO_BAL ( dollars cents  -- )
  84.       BAL_CENTS +!
  85.       BAL_DOLLARS +!
  86.       BAL_DOLLARS @ BAL_CENTS @ ROUND
  87.       BAL_CENTS ! BAL_DOLLARS ! ;
  88.  
  89.