home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / jbinput.seq < prev    next >
Encoding:
Text File  |  1988-10-12  |  8.1 KB  |  193 lines
  1. \ Original Date: September 12, 1988
  2. \ Last Modified: September 28, 1988
  3. \ Author:        Jack W. Brown
  4. \ Function:      Boiler plate, Bullet proof integer numeric input.
  5. \ Usage:         <position cursor>  #IN ( -- number )
  6.  
  7. \ Overview:
  8. \ The idea is to allow only valid single signed integer input
  9. \ with editing by checking each key press as it arrives. All
  10. \ invalid key presses including function keys will be rejected.
  11. \ The value of the number is formed as valid digits are entered
  12. \ so that it is impossible to enter a number outside the range
  13. \ of -32767 through 32767.  If the cursor is first positioned
  14. \ screen entry will be limited to 6 character positions from this
  15. \ initial cursor postion.
  16.  
  17. \ Notes:
  18. \ 1) All word defintions have been author and date coded to
  19. \    reflect the date and author of the most recent change.
  20. \ 2) Revision history added to beginning of file.
  21. \    This is absolute requirement when a team of programmers
  22. \    is working on a very large application.  Any change made
  23. \    is reflected in the revision history and with the actual
  24. \    word definition.
  25. \ 3) Only non-FORTH83 word used in #OUT
  26.  
  27. \ Possible Improvements:
  28. \ 1) Modify code to allow single signed number input in any BASE.
  29. \ 2) Modify code or make a new version called D#IN for bullet proof
  30. \    input of signed double integers.
  31.  
  32. \ Revision History:
  33. \ JWB 12 09 88  Converted from F83 Blocks to *.SEQ file for F-PC
  34. \ JWB 28 09 88  Commented out test for invalid interval in (IN)
  35. \ JWB 28 09 88  Inserted comment about non standard word #OUT.
  36. \ JWB 28 09 88  Added CONSTANTs to make code more readable and
  37. \               to avoid non standard ASCII and CONTROL.
  38. \ JWB 28 09 88  Clarified operation of RUBOUT.
  39. \ JWB 28 09 88  Clarified operation of +DIGIT.
  40. \ JWB 28 09 88  Renamed RESET? to CLEAR_SIGN? for readability.
  41. \ JWB 28 09 88  Changed . to _ in CORRECT.IT and PROCESS.IT
  42. \ JWB 28 09 88  Modified NEGATIVE? to include DUP
  43. \ JWB 28 09 88  Reformated #IN and removed DUP to accomodate above.
  44.  
  45. \  Constants added for readablilty.
  46. 07 CONSTANT CONTROL_G   \ Bell character
  47. 08 CONSTANT CONTROL_H   \ Back space character.
  48. 48 CONSTANT ASCII_0     \ The digit " 0 "
  49. 57 CONSTANT ASCII_9     \ The digit " 9 "
  50. 45 CONSTANT ASCII_-     \ The minus sign character.
  51. 13 CONSTANT CONTROL_M   \ The carriage return character
  52.  
  53. \ Interval testing words. Naming convention motivated by the
  54. \ mathematical intervals (a,b) [a,b] (a,b] and [a,b).
  55. \ Would better names be  (A,B) [A,B] ... ?
  56. \ Application Note:  In VP-Planner these four words were
  57. \ implemented in machine code and saved approximately 500 bytes,
  58. \ resulted in increased execution speed and better readability
  59. \ than when actual tests were coded inline in highlevel Forth.
  60.  
  61. \ (IN)  leaves a true flag if   a < x < b
  62. : (IN)  ( x a b --  flag )  ( JWB 28 09 88 )
  63. \        2DUP < NOT ABORT" Invalid interval."
  64.          -ROT OVER < -ROT > AND ;
  65.  
  66. \ [IN]  leaves a true flag if a <= x <= b  , otherwise false.
  67. : [IN]  ( x a b --  flag ) ( JWB 02 10 85 )
  68.         1+ SWAP 1- SWAP (IN) ;
  69.  
  70. \ (IN]  leaves a true flag if a <  x <= b  , otherwise false.
  71. : (IN]  ( x a b --  flag ) ( JWB 02 10 85 )
  72.         1+ (IN) ;
  73.  
  74. \ [IN)  leaves a true flag if a <= x <  b  , otherwise false.
  75. : [IN)  ( x a b --  flag ) ( JWB 02 10 85 )
  76.         SWAP 1- SWAP (IN) ;
  77.  
  78. \ Note #OUT is not in the FORTH83 standard. ( JWB 28 09 88 )
  79. \ #OUT is a variable that contains the number of charaters output since
  80. \ the last carriage return.  Its value must be corrected so that words
  81. \ EMITing characters leave its value the same as the actual horizontal
  82. \ cursor position.  If this is not done systems like L&P F83 may produce
  83. \ auto word wrap when #OUT exceeds 80.
  84.  
  85. \ Sound alarm bell.
  86. : BELL    ( -- ) ( JWB 07 10 85 )
  87.         CONTROL_G EMIT -1 #OUT +! ;
  88.  
  89. \ Leave true flag if valid digit.
  90. : DIGIT?  ( n --  flag ) ( JWB 07 10 85 )
  91.         ASCII_0 ASCII_9 [IN] ;
  92.  
  93. \ Rub out most recent digit. Note that correction to #OUT is -4
  94. \ because three characters have been EMITed and the cursor ends
  95. \ up one character position to the left!
  96. : RUBOUT  ( -- ) ( JWB 28 09 88 )
  97.         CONTROL_H EMIT SPACE
  98.         CONTROL_H EMIT
  99.         -4 #OUT +! ;
  100.  
  101. \ Erase digit from screen, adjust number being formed and
  102. \ decrement the digit count. Note:
  103. \ count = number of digits that have currently been entered.
  104. \ n     = the value of the number currently on the screen.
  105. : -DIGIT  ( count n  --  count-1 n/10 ) ( JWB 28 09 88 )
  106.         RUBOUT        \ Remove character from screen.
  107.         SWAP 1- SWAP  \ Adjust digit count.
  108.         10 / ;        \ Adjust value of number.
  109.  
  110. \ Increment digit count and add in digit. This word is complicated
  111. \ by the fact that we must check to make sure that the digit entered
  112. \ must not allow the number formed to be outside the valid single
  113. \ signed integer range.  Note: n'= 10n+key-48
  114. : +DIGIT  ( count n key --  count+1 n'   If valid key) ( JWB 28 09 88 )
  115.           (             --  count   n    If invalid key )
  116.         SWAP 10 UM*        \ Scale number by 10 and leave as double#.
  117.         2 PICK ASCII_0 -   \ Convert key to digit value.
  118.         0 D+               \ Extend to double, add to leave new value.
  119.         32767. 2OVER DU<   \ Check for out of range single number.
  120.         IF   10 UM/MOD     \ Too big, restore original value.
  121.              NIP NIP BELL  \ remove remainder, and key.
  122.         ELSE DROP          \ convert double number to single number.
  123.              SWAP EMIT     \ Echo digit key to the screen.
  124.              SWAP 1+ SWAP  \ Increment the current digit count.
  125.         THEN ;
  126.  
  127. \ Reset sign flag to indicate non negative number if digit count
  128. \ is zero.
  129. : CLEAR_SIGN? ( flag count n --  ff count n ) ( JWB 28 09 88 )
  130.       OVER 0= IF  ROT DROP FALSE -ROT THEN ;
  131.  
  132. \ Correct an error input.
  133. : CORRECT_IT ( flag count num key --  flag count num ) ( JWB 28 09 88 )
  134.        DROP OVER  0<>         \ Is digit count non zero?
  135.        IF   -DIGIT            \ Remove most recent digit.
  136.        ELSE BELL              \ Sound warning.
  137.        THEN
  138.        CLEAR_SIGN? ; \ Clear numbers sign if count is 0.
  139.  
  140. \ Process all other keystrokes.
  141. : PROCESS_IT ( flag count num key --  flag count num ) ( JWB 28 09 88 )
  142.        DUP  DIGIT?            \ Check for digit.
  143.        IF   +DIGIT            \ Echo & convert digit, inc count
  144.        ELSE DROP BELL         \ Invalid key or overflow.
  145.        THEN ;
  146.  
  147. \ Apply sign to number.
  148. : APPLY-SIGN  ( flg count num key -- num ) ( JWB 28 09 88 )
  149.        DROP NIP SWAP          \ Drop key, nip count, get sign flag.
  150.        IF NEGATE THEN  ;      \ Apply sign to number.
  151.  
  152. \ Negative number?
  153. : NEGATIVE? ( count num key  -- count num key flag ) ( JWB 28 09 88 )
  154.        DUP ASCII_- =  3 PICK 0= AND ;
  155.  
  156. \ Set sign flag to true indicating a negative number
  157. \ is being input.
  158. : SET-FLAG  ( flg cnt num key --  flg cnt num ) ( JWB 07 10 85 )
  159.       EMIT ROT DROP TRUE -ROT   \ Set sign flag true.
  160.       SWAP 1+ SWAP  ;           \ Increment digit count.
  161.  
  162. \ This is the boiler plate, bullet proof interger number
  163. \ input routine.  It supposedly only allows input of positive
  164. \ or negative 16 bit integers.  Only valid digit keys are
  165. \ allowed.
  166. \ flag  = sign flag, true means negative number being entered.
  167. \                   false means positive number.
  168. \ count = current count of digits entered.
  169. \ number= current value of number on users screen.
  170. \ key   = key press code from users input.
  171. : #IN   ( --   number ) ( JWB 28 09 88 )
  172.       FALSE 0 0    ( flag count number )
  173.       BEGIN KEY    ( flag count number key ) \ Fetch key press.
  174.         NEGATIVE?                    \ Negative number?
  175.         IF   SET-FLAG                \ Set sign flag true.
  176.         ELSE DUP CONTROL_M =         \ Return entered?
  177.              IF   APPLY-SIGN EXIT    \ Apply sign to number and exit
  178.              THEN
  179.              DUP CONTROL_H =         \ Correct error input?
  180.              IF   CORRECT_IT         \ This does it.
  181.              ELSE PROCESS_IT         \ Process all other keys.
  182.              THEN
  183.         THEN
  184.       AGAIN ;
  185.  
  186. \ Word to test #IN
  187. : TEST ( -- )
  188.       BEGIN
  189.            CR #IN 3 SPACES DUP .
  190.       0= UNTIL ;
  191.  
  192.  
  193.