\\ Conditional Compilation a la ANS-Forth by U.Hoffmann

   $Logfile:   C:/SRC/FPC/FPC-ANS/VCS/CONDCOMP.SEV  $
   $Revision: 1.4 $
   $Date: 1999/04/10 11:40:16 $
   $Author: uho $

 /-----------------------------------------------------uh 09Oct94
 | This file contains definitions to add NESTABLE conditional   |
 | compilation constructs to F-PC as specified in the ANS-FORTH |
 | standard (Programming-Tools extension word set).             |
 |                                                              |
 | The implemented conditional compilation structures - [IF]    |
 | [ELSE] and [THEN] - behave like the already defined words #if|
 | #else and #then but are nestable as required by the standard.|
 |                                                              |
 | The implementation is similar to that found in appendix A    |
 | (Rationale) of the draft proposed standard. (A.15.6.2.2533)  |
 |                                                              |
 |           This Code is public domain software                |
 |                                                              |
 | Remarks and comments are welcome.                            |
 |                                                              |
 |               Ulrich Hoffmann                                |
 |               Sehestedter Strasse 26                         |
 |               24340 Eckernfoerde                             |
 |               Germany                                        |
 |               +49 4351 712 217                               |
 |               +49 4351 712 216 (FAX)                         |
 |               Ulrich.E.Hoffmann@gmx.de                       |
 |                                                              |
 \--------------------------------------------------------------/

{

Anew *conditinal-compilation*

beheadable hwords+

| : "= ( addr1 len1 addr2 len2 -- f )
      rot over - IF  drop 2drop false EXIT THEN
      [ also Forth ] compare  [ previous ] 0= ;

| : [IF]?   ( addr len -- f )   "" [IF]"   "= ;
| : [ELSE]? ( addr len -- f )   "" [ELSE]" "= ;
| : [THEN]? ( addr len -- f )   "" [THEN]" "= ;

| : file-refill ( -- f )
    \ Read next line from loadfile
    \ return true when another line was available
    \ return false when end of file reached
    filltib  inlength 0<> ;

: [ELSE] ( -- )  ?loading
  1 BEGIN                                       \ level
      BEGIN
        bl word ?uppercase count  dup           \ get next word
      WHILE                                     \ another word on this line
        2dup [IF]?   IF  2drop 1+ ELSE          \ increase level on [IF]
        2dup [ELSE]? IF  2drop 1- dup  IF 1+ THEN ELSE  \ de- and increase
             [THEN]? IF  1-  THEN THEN THEN     \ decrease level on [THEN]
        ?dup 0= ?EXIT                           \ done when level down to 0
      REPEAT
      2drop                                     \ no more words on this line
      file-refill 0=                            \ get next line
     UNTIL
   drop  ( true Abort" [THEN] expected!"  )     \ eof reached
; immediate

: [IF]   ( flag -- )  ?loading  ?EXIT  [COMPILE] [ELSE] ; immediate
: [THEN] ( -- )  ?loading ; immediate

behead   !> beheadable

cr .( Conditional compilation with [IF] [ELSE] and [THEN] loaded! )

\s demo
\ ----------------------------------------------------------

: Y/N( ( -- f )  [compile] .(  ." Y/N? " key cr upc Ascii Y = ;

cr .( Demo ) cr
Y/N( outer ) [IF]
.( outer true ) cr
      Y/N( inner ) [IF]  .( inner true ) cr
                   [ELSE] .( inner false ) cr
                   [THEN]
[ELSE]
.( outer false ) cr
[THEN]


\s
------------------------------------------------------------
Revision history:
$Log: condcomp.seq,v $
Revision 1.4  1999/04/10 11:40:16  uho
Changed Email Address

Revision 1.3  1997/08/28 10:31:46  uho
make sure the right compare is found in "=

   
      Rev 1.3  1997/08/28 10:02:37  uho
   Changed email address


      Rev 1.2   17 Nov 1995  1:21:08
   Clean up for release.
   

      Rev 1.1   17 Nov 1995  0:09:06
   EOF Error message removed: Needed when rest of source is 
   skipped with \S or \\
   
   
      Rev 1.0   09 Oct 1994 15:45:02
   Initial revision.