git.gag.com Git - debian/pforth/blob - misc1.fth

   1 \ @(#) misc1.fth 98/01/26 1.2
   2 \ miscellaneous words
   3 \
   4 \ Author: Phil Burk
   5 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
   6 \
   7 \ The pForth software code is dedicated to the public domain,
   8 \ and any third party may reproduce, distribute and modify
   9 \ the pForth software code or any derivative works thereof
  10 \ without any compensation or license.  The pForth software
  11 \ code is provided on an "as is" basis without any warranty
  12 \ of any kind, including, without limitation, the implied
  13 \ warranties of merchantability and fitness for a particular
  14 \ purpose and their equivalents under the laws of any jurisdiction.
  15
  16 anew task-misc1.fth
  17 decimal
  18
  19 : >> rshift ;
  20 : << lshift ;
  21 : CELL* ( n -- n*cell )  2 lshift ;
  22
  23 : (WARNING")  ( flag $message -- )
  24     swap
  25     IF count type
  26     ELSE drop
  27     THEN
  28 ;
  29
  30 : WARNING" ( flag <message> -- , print warning if true. )
  31         [compile] "  ( compile message )
  32         state @
  33         IF  compile (warning")
  34         ELSE (warning")
  35         THEN
  36 ; IMMEDIATE
  37
  38 : (ABORT")  ( flag $message -- )
  39     swap
  40     IF count type cr abort
  41     ELSE drop
  42     THEN
  43 ;
  44
  45 : ABORT" ( flag <message> -- , print warning if true. )
  46         [compile] "  ( compile message )
  47         state @
  48         IF  compile (abort")
  49         ELSE (abort")
  50         THEN
  51 ; IMMEDIATE
  52
  53
  54 : ?PAUSE ( -- , Pause if key hit. )
  55     ?terminal
  56     IF  key drop cr ." Hit space to continue, any other key to abort:"
  57         key dup emit BL = not abort" Terminated"
  58     THEN
  59 ;
  60
  61 60 constant #cols
  62
  63 : CR?  ( -- , do CR if near end )
  64     OUT @ #cols 16 - 10 max >
  65     IF cr
  66     THEN
  67 ;
  68
  69 : CLS ( -- clear screen )
  70         40 0 do cr loop
  71 ;
  72 : PAGE ( -- , clear screen, compatible with Brodie )
  73         cls
  74 ;
  75
  76 : $ ( <number> -- N , convert next number as hex )
  77     base @ hex
  78     32 lword number? num_type_single = not
  79     abort" Not a single number!"
  80     swap base !
  81     state @
  82     IF [compile] literal
  83     THEN
  84 ; immediate
  85
  86 : .HX   ( nibble -- )
  87         dup 9 >
  88         IF    $ 37
  89         ELSE  $ 30
  90         THEN  + emit
  91 ;
  92
  93 variable TAB-WIDTH  8 TAB-WIDTH !
  94 : TAB  ( -- , tab over to next stop )
  95     out @ tab-width @ mod
  96     tab-width @   swap - spaces
  97 ;
  98
  99 \ Vocabulary listing
 100 : WORDS  ( -- )
 101         0 latest
 102         BEGIN  dup 0<>
 103         WHILE  dup id. tab cr? ?pause
 104                 prevname
 105                 swap 1+ swap
 106         REPEAT drop
 107         cr . ."  words" cr
 108 ;
 109
 110 variable CLOSEST-NFA
 111 variable CLOSEST-XT
 112
 113 : >NAME  ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
 114         0 closest-nfa !
 115         0 closest-xt !
 116         latest
 117         BEGIN  dup 0<>
 118                 IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
 119                         IF true  ( addr below this cfa, can't be it)
 120                         ELSE ( -- addr nfa )
 121                                 2dup name>  ( addr nfa addr xt ) =
 122                                 IF ( found it ! ) dup closest-nfa ! false
 123                                 ELSE dup name> closest-xt @ >
 124                                         IF dup closest-nfa ! dup name> closest-xt !
 125                                         THEN
 126                                         true
 127                                 THEN
 128                         THEN
 129                 ELSE false
 130                 THEN
 131         WHILE
 132             prevname
 133         REPEAT ( -- cfa nfa )
 134         2drop
 135         closest-nfa @
 136 ;
 137
 138 : @EXECUTE  ( addr -- , execute if non-zero )
 139         x@ ?dup
 140         IF execute
 141         THEN
 142 ;
 143
 144 : TOLOWER ( char -- char_lower )
 145     dup ascii [ <
 146     IF  dup ascii @ >
 147                 IF ascii A - ascii a +
 148                 THEN
 149     THEN
 150 ;