version 1.2, 1994/06/17 12:35:16
|
version 1.8, 1996/07/16 20:57:14
|
Line 1
|
Line 1
|
\ TOOLSEXT.FS [IF] [ELSE] [THEN] and more 20may93jaw |
\ Interpretative Structuren 16feb92py |
|
|
\ This here is fully ans compatible |
\ Copyright (C) 1995 Free Software Foundation, Inc. |
\ May be cross-compiled |
|
|
|
\ ( \ added 09jun93jaw |
\ This file is part of Gforth. |
|
|
\ very close to dpANS5 |
\ Gforth is free software; you can redistribute it and/or |
|
\ modify it under the terms of the GNU General Public License |
decimal |
\ as published by the Free Software Foundation; either version 2 |
|
\ of the License, or (at your option) any later version. |
CREATE Opennest 7 chars allot |
|
CREATE Closenest 7 chars allot |
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
: SKIPNEST |
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
1 BEGIN |
\ GNU General Public License for more details. |
BEGIN name count dup WHILE |
|
2dup Opennest count compare 0= |
\ You should have received a copy of the GNU General Public License |
IF 2drop 1+ |
\ along with this program; if not, write to the Free Software |
ELSE Closenest count compare 0= IF 1- THEN |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
THEN |
|
?dup 0= IF EXIT THEN |
|
REPEAT |
Variable countif |
2drop refill 0= |
|
UNTIL drop ; |
: dummy ; immediate |
|
: >exec >r ; restrict ( :-) |
\ : ( s" (" Opennest place |
: scanIF f83find dup 0= IF drop ['] dummy >name THEN ; |
\ s" )" Closenest place |
|
\ SKIPNEST ; immediate |
Create [struct]-search ' scanIF A, ' (reveal) A, ' drop A, |
|
Create [struct]-voc NIL A, [struct]-search A, |
: comment? ( c-addr u -- c-addr u ) |
NIL A, NIL A, |
2dup s" (" compare 0= |
|
IF postpone ( |
: ?if countif @ 0< |
ELSE 2dup s" \" compare 0= IF postpone \ THEN |
IF [ [struct]-voc 3 cells + ] ALiteral @ lookup ! THEN ; |
THEN ; |
|
|
UNLOCK Tlast @ NIL Tlast ! LOCK |
: [ELSE] |
|
1 BEGIN |
: [IF] 1 countif +! ?if ; immediate |
BEGIN name count dup WHILE |
: [THEN] -1 countif +! ?if ; immediate |
comment? |
: [ELSE] postpone [THEN] r> >exec postpone [IF] ; |
2dup s" [IF]" compare 0= |
immediate |
IF 2drop 1+ |
' [IF] Alias [IFDEF] immediate |
ELSE 2dup s" [ELSE]" compare 0= |
' [IF] Alias [IFUNDEF] immediate |
IF 2drop 1- dup IF 1+ THEN |
' [THEN] Alias [ENDIF] immediate |
ELSE s" [THEN]" compare 0= IF 1- THEN |
' [IF] Alias [BEGIN] immediate |
THEN |
' [IF] Alias [WHILE] immediate |
THEN |
' [THEN] Alias [UNTIL] immediate |
?dup 0= IF EXIT THEN |
' [THEN] Alias [AGAIN] immediate |
REPEAT |
' [IF] Alias [DO] immediate |
2drop refill 0= |
' [IF] Alias [?DO] immediate |
UNTIL drop ; immediate |
' [THEN] Alias [LOOP] immediate |
|
' [THEN] Alias [+LOOP] immediate |
: [THEN] ( -- ) ; immediate |
: [REPEAT] postpone [AGAIN] postpone [THEN] ; |
|
immediate |
: [IF] ( flag -- ) |
' ( Alias ( immediate |
0= IF postpone [ELSE] THEN ; immediate |
' \ Alias \ immediate |
|
|
\ [IFUNDEF] [IFDEF] 9may93jaw |
UNLOCK Tlast @ swap Tlast ! LOCK |
|
1 cells - [struct]-voc ! |
: [IFUNDEF] |
|
name find nip 0= postpone [IF] ; immediate |
\ Interpretative Structuren 30apr92py |
: [IFDEF] |
|
name find nip 0<> postpone [IF] ; immediate |
: defined bl word find nip 0<> ; immediate |
|
: [IF] 0= IF countif off |
|
lookup @ [ [struct]-voc 3 cells + ] ALiteral ! |
\ [IF]? 9jun93jaw |
[struct]-voc lookup ! |
|
THEN ; immediate |
\ same as comment? but skips [IF] .... [THEN] |
: [IFDEF] postpone defined postpone [IF] ; immediate |
|
: [IFUNDEF] postpone defined 0= postpone [IF] ; immediate |
: [if]? ( c-addr u -- c-addr u ) |
: [ELSE] 0 postpone [IF] ; immediate |
2dup s" [IF]" compare 0= >r |
: [THEN] ; immediate |
2dup s" [ELSE]" compare 0= >r |
: [ENDIF] ; immediate |
2dup s" [IFUNDEF]" compare 0= >r |
|
2dup s" [IFDEF]" compare 0= r> or r> or r> or |
\ Structs for interpreter 28nov92py |
IF s" [IF]" Opennest place |
|
s" [THEN]" Closenest place |
User (i) |
SKIPNEST THEN ; |
|
|
: [DO] ( start end -- ) >in @ -rot |
|
DO I (i) ! dup >r >in ! interpret r> swap +LOOP drop ; |
|
immediate |
|
: [?DO] 2dup = IF 2drop postpone [ELSE] ELSE postpone [DO] THEN ; |
|
immediate |
|
: [+LOOP] ( n -- ) rdrop rdrop ; immediate |
|
: [LOOP] ( -- ) 1 rdrop rdrop ; immediate |
|
: [FOR] ( n -- ) 0 swap postpone [DO] ; immediate |
|
: [NEXT] ( n -- ) -1 rdrop rdrop ; immediate |
|
: [I] ( -- index ) (I) @ postpone Literal ; immediate |
|
: [BEGIN] >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop ; |
|
immediate |
|
' [+LOOP] Alias [UNTIL] immediate |
|
: [REPEAT] ( -- ) false rdrop rdrop ; immediate |
|
' [REPEAT] Alias [AGAIN] immediate |
|
: [WHILE] ( flag -- ) |
|
0= IF postpone [ELSE] true rdrop rdrop 1 countif +! THEN ; |
|
immediate |
|
|