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

   1 \ @(#) quit.fth 98/01/26 1.2
   2 \ Outer Interpreter in Forth
   3 \
   4 \ This used so that THROW can be caught by QUIT.
   5 \
   6 \ Author: Phil Burk
   7 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
   8 \
   9 \ The pForth software code is dedicated to the public domain,
  10 \ and any third party may reproduce, distribute and modify
  11 \ the pForth software code or any derivative works thereof
  12 \ without any compensation or license.  The pForth software
  13 \ code is provided on an "as is" basis without any warranty
  14 \ of any kind, including, without limitation, the implied
  15 \ warranties of merchantability and fitness for a particular
  16 \ purpose and their equivalents under the laws of any jurisdiction.
  17
  18 include? catch catch.fth
  19
  20 anew task-quit.fth
  21
  22 : FIND&COMPILE ( $word --  {n} , find word in dictionary and handle it )
  23         dup >r   \ save in case needed
  24         find ( -- xt flag | $word 0 )
  25
  26         CASE
  27                 -1 OF           \ not immediate
  28                         state @     \ compiling?
  29                         IF compile,
  30                         ELSE execute
  31                         THEN
  32                 ENDOF
  33
  34                 1 OF execute    \ immediate, so execute regardless of STATE
  35                 ENDOF
  36
  37                 0 OF
  38                         number?     \ is it a number?
  39                         num_type_single =
  40                         IF   ?literal  \ compile it or leave it on stack
  41                         ELSE
  42                                 r@ count type ."   is not recognized!!" cr
  43                                 abort
  44                         THEN
  45                 ENDOF
  46         ENDCASE
  47
  48         rdrop
  49 ;
  50
  51 : CHECK.STACK  \ throw exception if stack underflows
  52         depth 0<
  53         IF
  54                 ." QUIT: Stack underflow!" cr
  55                 depth negate 0  \ restore depth
  56                 ?DO 0
  57                 LOOP
  58                 ERR_UNDERFLOW throw
  59         THEN
  60 ;
  61
  62 \ interpret whatever is in source
  63 : INTERPRET ( ?? -- ?? )
  64         BEGIN
  65                 >in @ source nip ( 1- ) <   \ any input left? !!! is -1 needed?
  66         WHILE
  67                 bl word
  68                 dup c@ 0>
  69                 IF
  70                         0 >r \ flag
  71                         local-compiler @
  72                         IF
  73                                 dup local-compiler @ execute  ( ?? -- ?? )
  74                                 r> drop TRUE >r
  75                         THEN
  76                         r> 0=
  77                         IF
  78                                 find&compile   ( -- {n} , may leave numbers on stack )
  79                         THEN
  80                 ELSE
  81                         drop
  82                 THEN
  83                 check.stack
  84         REPEAT
  85 ;
  86
  87 : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
  88 \ save current input state and switch to pased in string
  89         source >r >r
  90         set-source
  91         -1 push-source-id
  92         >in @ >r
  93         0 >in !
  94 \ interpret the string
  95         interpret
  96 \ restore input state
  97         pop-source-id drop
  98         r> >in !
  99         r> r> set-source
 100 ;
 101
 102 : POSTPONE  ( <name> -- )
 103         bl word find
 104         CASE
 105                 0 OF ." Postpone could not find " count type cr abort ENDOF
 106                 1 OF compile, ENDOF \ immediate
 107                 -1 OF (compile) ENDOF \ normal
 108         ENDCASE
 109 ; immediate
 110
 111 : OK
 112         ."  OK  "
 113         trace-stack @
 114         IF   .s
 115         ELSE cr
 116         THEN
 117 ;
 118
 119 variable QUIT-QUIT
 120
 121 : QUIT  ( -- , interpret input until none left )
 122         quit-quit off
 123         postpone [
 124         BEGIN
 125                 refill
 126                 quit-quit @ 0= and
 127         WHILE
 128 \               ." TIB = " source type cr
 129                 ['] interpret catch ?dup
 130                 IF
 131                         ." Exception # " . cr
 132                 ELSE
 133                         state @ 0= IF ok THEN
 134                 THEN
 135         REPEAT
 136 ;