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

   1 \ @(#) condcomp.fth 98/01/26 1.2\r
   2 \ Conditional Compilation support\r
   3 \\r
   4 \ Words: STRINGS= [IF] [ELSE] [THEN] EXISTS?\r
   5 \\r
   6 \ Lifted from X3J14 dpANS-6 document.\r
   7 \r
   8 anew task-condcomp.fth\r
   9 \r
  10 : [ELSE]  ( -- )\r
  11     1\r
  12     BEGIN                                 \ level\r
  13       BEGIN\r
  14         BL WORD                           \ level $word\r
  15         COUNT  DUP                        \ level adr len len\r
  16       WHILE                               \ level adr len\r
  17         2DUP  S" [IF]"  COMPARE 0=\r
  18         IF                                \ level adr len\r
  19           2DROP 1+                        \ level'\r
  20         ELSE                              \ level adr len\r
  21           2DUP  S" [ELSE]"\r
  22           COMPARE 0=                      \ level adr len flag\r
  23           IF                              \ level adr len\r
  24              2DROP 1- DUP IF 1+ THEN      \ level'\r
  25           ELSE                            \ level adr len\r
  26             S" [THEN]"  COMPARE 0=\r
  27             IF\r
  28               1-                          \ level'\r
  29             THEN\r
  30           THEN\r
  31         THEN\r
  32         ?DUP 0=  IF EXIT THEN             \ level'\r
  33       REPEAT  2DROP                       \ level\r
  34     REFILL 0= UNTIL                       \ level\r
  35     DROP\r
  36 ;  IMMEDIATE\r
  37 \r
  38 : [IF]  ( flag -- )\r
  39         0=\r
  40         IF POSTPONE [ELSE]\r
  41         THEN\r
  42 ;  IMMEDIATE\r
  43 \r
  44 : [THEN]  ( -- )\r
  45 ;  IMMEDIATE\r
  46 \r
  47 : EXISTS? ( <name> -- flag , true if defined )\r
  48     bl word find\r
  49     swap drop\r
  50 ; immediate\r