level1/89_cond_comp.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 vocabulary (concomp-flow)  (hidden)
   8 voc-set-active (concomp-flow)
   9
  10 : [IF]  ( level -- newlevel )  1+ ;
  11 alias [IF] [IFNOT]
  12 alias [IF] [IFDEF]
  13 alias [IF] [IFNDEF]
  14
  15 : [ELSE] ( level -- newlevel ) 1- dup if 1+ endif ;
  16
  17 : [ENDIF]  ( level -- newlevel )  1- ;
  18 alias [ENDIF] [THEN]
  19
  20 voc-set-active forth
  21
  22 : [ELSE]  ( -- )
  23   1 ;; level
  24   begin
  25     begin
  26       parse-skip-comments parse-name dup
  27       ifnot refill not ERR-UNBALANCED-IFDEF ?error endif
  28     dup until
  29     vocid: (concomp-flow) voc-search-noimm if execute else 2drop endif
  30   dup not-until drop
  31 ; immediate
  32
  33
  34 : [ENDIF]  ( -- )  ; immediate
  35 alias [ENDIF] [THEN]
  36
  37
  38 : [IF]  ( cond -- )
  39   ifnot [compile] [ELSE] endif
  40 ; immediate
  41
  42 : [IFNOT]  ( cond -- )
  43   if [compile] [ELSE] endif
  44 ; immediate
  45
  46 : [IFDEF]  ( -- )  \ word
  47   parse-name has-word? ifnot [compile] [ELSE] endif
  48 ; immediate
  49
  50 : [IFNDEF]  ( -- )  \ word
  51   parse-name has-word? if [compile] [ELSE] endif
  52 ; immediate
  53
  54 : [DEFINED]  ( -- flag )  \ word
  55   parse-name has-word?
  56 ; immediate
  57
  58 : [UNDEFINED]  ( -- flag )  \ word
  59   parse-name has-word? not
  60 ; immediate
  61
  62
  63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64 ;; sorry, i should find a better place for this
  65 $value "(.lib-info)" 0
  66 (hidden)
  67
  68 $value "(.lib-sttime)" 0
  69 (hidden)
  70
  71 $value "(.lib-used)" 0
  72 (hidden)
  73
  74 ;;$value "(.lib-tmp-mark)" 0
  75 ;; 1024 brk-alloc constant (.lib-info)
  76
  77 : (lib-current.)  ( -- )
  78   (.lib-info) ?dup if
  79     4 +cells count
  80     dup 0> over 1020 <= and if
  81       safe-type
  82     else
  83       2drop ." ???"
  84     endif
  85   else
  86     ." ???"
  87   endif
  88 ; (hidden)
  89
  90 : (.lib-put-cell)  ( addr value -- addr+4 )
  91   over ! cell+
  92 ;  (hidden)
  93
  94 : .LIB-START"  ( -- sttime stunused )  ;;"
  95   ;; (.lib-info) ifnot 1024 brk-alloc to (.lib-info) endif
  96   34 parse 1020 umin  ;; (.lib-info) c4s:COPY-counted
  97   dup 5 +cells simple-malloc throw dup >r
  98   r> over >r  ;; save buffer start
  99   (.lib-put-cell)               ;; mark
 100   (.lib-info) (.lib-put-cell)   ;; prev info pointer
 101   ;; update info pointer
 102   r> to (.lib-info)
 103   (.lib-sttime) (.lib-put-cell) ;; old sttime
 104   (.lib-used) (.lib-put-cell)   ;; old used
 105   ;; ( addr count cbufptr )
 106   over (.lib-put-cell)          ;; counter
 107   swap cmove                    ;; libname string
 108   TLOAD-VERBOSE-LIBS 1 > if
 109     ." *** compiling library \`" (lib-current.) ." \`\n"
 110   endif
 111   unused to (.lib-used)
 112   os:gettickcount to (.lib-sttime)
 113 ;
 114
 115
 116 : .LIB-END  ( -- )  ;;"
 117   TLOAD-VERBOSE-LIBS if
 118     os:gettickcount
 119     ." *** compiled library \`" (lib-current.) ." \`, size is "
 120     (.lib-used) unused - . ." bytes, "
 121     (.lib-sttime) - . ." msecs\n"
 122   endif
 123   ;; restore previous
 124   (.lib-info) 2 +cells @ to (.lib-sttime)
 125   (.lib-info) 3 +cells @ to (.lib-used)
 126   (.lib-info) cell+ @   ;; old pointer
 127   (.lib-info) @ simple-free throw
 128   to (.lib-info)
 129 ;