level0/syssrc/condcomp.f

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;; conditional compilation
   3 ;;
   4 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   5 ;;
   6 ;; This program is free software: you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation, version 3 of the License ONLY.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 : ([CND]-S=CI?EXIT)  ( addr1 count1 addr2 count2 -- true[exit the caller] // addr1 count1 )
  20   2over s=ci if rdrop 2drop true exit endif
  21 ; (hidden)
  22
  23 : ([IF]?)  ( addr count -- addr count false // true )
  24   s" [IF]" ([cnd]-s=ci?exit)
  25   s" [IFNOT]" ([cnd]-s=ci?exit)
  26   s" [IFDEF]" ([cnd]-s=ci?exit)
  27   s" [IFNDEF]" ([cnd]-s=ci?exit)
  28   false
  29 ; (hidden)
  30
  31 : ([ENDIF]?)  ( addr count -- addr count flag )
  32   s" [ENDIF]" ([cnd]-s=ci?exit)
  33   s" [THEN]" ([cnd]-s=ci?exit)
  34   false
  35 ; (hidden)
  36
  37 : ([ELSE]?)  ( addr count -- addr count flag )
  38   s" [ELSE]" ([cnd]-s=ci?exit)
  39   false
  40 ; (hidden)
  41
  42 : [ELSE]  ( -- )
  43   1  ;; level
  44   begin
  45     begin
  46       parse-name dup
  47       ifnot
  48         refill not ERR-UNBALANCED-IFDEF ?error
  49       endif
  50       dup
  51     until
  52          ([IF]?) if 1+
  53     else ([ELSE]?) if 1- dup if 1+ endif
  54     else ([ENDIF]?) if 1-
  55     else 2drop
  56     endif endif endif
  57     dup not
  58   until
  59   drop
  60 ; immediate
  61
  62
  63 : [ENDIF]  ( -- )  ; immediate
  64 alias [ENDIF] [THEN]
  65
  66
  67 : [IF]  ( cond -- )
  68   ifnot [compile] [ELSE] endif
  69 ; immediate
  70
  71 : [IFNOT]  ( cond -- )
  72   if [compile] [ELSE] endif
  73 ; immediate
  74
  75 : [IFDEF]  ( -- )  \ word
  76   parse-name has-word? ifnot [compile] [ELSE] endif
  77 ; immediate
  78
  79 : [IFNDEF]  ( -- )  \ word
  80   parse-name has-word? if [compile] [ELSE] endif
  81 ; immediate
  82
  83 : [DEFINED]  ( -- flag )  \ word
  84   parse-name has-word?
  85 ; immediate
  86
  87 : [UNDEFINED]  ( -- flag )  \ word
  88   parse-name has-word? not
  89 ; immediate
  90
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 63 constant (#user-abort-msg) (hidden)
  94 create (user-abort-msg) 0 c, (#user-abort-msg) allot create; (hidden)
  95
  96 : (abort-msg-reset)  ( -- ) (user-abort-msg) 0c! ;
  97 : (abort-msg-emit)  ( ch -- )  (user-abort-msg) c@ (#user-abort-msg) < if (user-abort-msg) dup c@ + 1+ c! 1 (user-abort-msg) c+! else drop endif ;
  98 : (abort-msg-type)  ( addr count -- )  dup +if (#user-abort-msg) min over + swap do i c@ (abort-msg-emit) loop else 2drop endif ;
  99
 100 : (abort-with-built-msg)  ( -- )
 101   endcr ." ABORT: " (user-abort-msg) ( ccount) dup c@ swap 1+ swap type space (abort-msg-reset) forth:error-line. cr
 102   ERR-USER-ERROR throw
 103 ;
 104
 105 : (abort-with-msg)  ( addr count -- )  (abort-msg-reset) (abort-msg-type) (abort-with-built-msg) ;
 106
 107 : (xabort-par)  ( -- )
 108   ?comp
 109   compile litstr
 110   (parse-compile-c4str)
 111   compile (abort-with-msg)
 112 ; (hidden)
 113
 114 : abort"  ( -- )  ;; "
 115   state @ if (xabort-par) else 34 parse (abort-with-msg) endif
 116 ; immediate
 117
 118 : ?abort"  ( flag -- )  ;; "
 119   state @ if
 120     [compile] if (xabort-par) [compile] endif
 121   else
 122     34 parse rot if (abort-with-msg) else 2drop endif
 123   endif
 124 ; immediate
 125
 126 : not-?abort"  ( flag -- )  ;; "
 127   state @ if
 128     [compile] ifnot (xabort-par) [compile] endif
 129   else
 130     34 parse rot ifnot (abort-with-msg) else 2drop endif
 131   endif
 132 ; immediate
 133
 134
 135 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 136 ;; sorry, i should find a better place for this
 137 create (.lib-name) 1024 allot
 138
 139 : .LIB-START"  ( -- sttime stunused )  ;;"
 140   34 parse 1020 umin (.lib-name) C4S-COPY-A-C
 141   TLOAD-VERBOSE-LIBS if
 142     ." *** compiling library \`" (.lib-name) count type ." \`\n"
 143   endif
 144   sys-gettickcount unused
 145 ;
 146
 147
 148 : .LIB-END  ( sttime stunused -- )  ;;"
 149   sys-gettickcount swap
 150   TLOAD-VERBOSE-LIBS if
 151     ." *** compiled  library \`" (.lib-name) count type ." \`, size is " unused - . ." bytes, " swap - . ." msecs\n"
 152   else
 153     2drop
 154   endif
 155 ;