level0/urforth0_w_litbase.asm

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;;
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;;
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, version 3 of the License ONLY.
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;; GNU General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU General Public License
  15 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 urword_code "LIT",lit
  20 urword_arg_lit
  21 urword_hidden
  22   push  TOS
  23   lodsd
  24   mov   TOS,eax
  25   urnext
  26 urword_end
  27
  28 urword_code "LITSTR",strlit
  29 urword_arg_c4strz
  30 urword_hidden
  31   push  TOS
  32   lodsd
  33   push  EIP
  34   mov   TOS,eax
  35   add   EIP,eax
  36   inc   EIP  ;; skip trailing zero
  37   urnext
  38 urword_end
  39
  40 urword_code "LITCFA",cfalit
  41 urword_arg_cfa
  42 urword_hidden
  43   push  TOS
  44   lodsd
  45   mov   TOS,eax
  46   urnext
  47 urword_end
  48
  49 urword_code "LITCBLOCK",cblocklit
  50 urword_arg_cblock
  51 urword_hidden
  52   ; next cell is continue address
  53   ; leave next next cell address as cfa
  54   push  TOS
  55   lodsd
  56   ld    TOS,EIP
  57   ld    EIP,eax
  58   urnext
  59 urword_end
  60
  61 ; used in "TO"
  62 urword_code "LITTO!",littopush
  63 urword_arg_cfa
  64 urword_hidden
  65 ;; ( value -- )
  66   lodsd
  67   add   eax,5   ; skip cfa
  68   ld    [eax],TOS
  69   pop   TOS
  70   urnext
  71 urword_end
  72
  73 ; used in "+TO"
  74 urword_code "LIT+TO!",litaddtopush
  75 urword_arg_cfa
  76 urword_hidden
  77 ;; ( value -- )
  78   lodsd
  79   add   eax,5   ; skip cfa
  80   add   [eax],TOS
  81   pop   TOS
  82   urnext
  83 urword_end
  84
  85 ; used in "-TO"
  86 urword_code "LIT-TO!",litsubtopush
  87 urword_arg_cfa
  88 urword_hidden
  89 ;; ( value -- )
  90   lodsd
  91   add   eax,5   ; skip cfa
  92   sub   [eax],TOS
  93   pop   TOS
  94   urnext
  95 urword_end
  96
  97
  98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99 urword_code "BRANCH",branch
 100 urword_arg_branch
 101 urword_hidden
 102   lodsd
 103   mov   EIP,eax
 104   urnext
 105 urword_end
 106
 107 urword_code "0BRANCH",0branch
 108 urword_arg_branch
 109 urword_hidden
 110   lodsd
 111   or    TOS,TOS
 112   pop   TOS
 113   jnz   @f
 114   mov   EIP,eax
 115 @@:
 116   urnext
 117 urword_end
 118
 119 urword_code "TBRANCH",tbranch
 120 urword_arg_branch
 121 urword_hidden
 122   lodsd
 123   or    TOS,TOS
 124   pop   TOS
 125   jz    @f
 126   mov   EIP,eax
 127 @@:
 128   urnext
 129 urword_end
 130
 131 ;; branch if positive or zero
 132 urword_code "+0BRANCH",p0branch
 133 urword_arg_branch
 134 urword_hidden
 135   lodsd
 136   cp    TOS,0
 137   pop   TOS
 138   jr    l,@f
 139   ld    EIP,eax
 140 @@:
 141   urnext
 142 urword_end
 143
 144 ;; branch if negative or zero
 145 urword_code "-0BRANCH",m0branch
 146 urword_arg_branch
 147 urword_hidden
 148   lodsd
 149   cp    TOS,0
 150   pop   TOS
 151   jr    g,@f
 152   ld    EIP,eax
 153 @@:
 154   urnext
 155 urword_end
 156
 157 ;; branch if positive (not zero)
 158 urword_code "+BRANCH",pbranch
 159 urword_arg_branch
 160 urword_hidden
 161   lodsd
 162   cp    TOS,0
 163   pop   TOS
 164   jr    le,@f
 165   ld    EIP,eax
 166 @@:
 167   urnext
 168 urword_end
 169
 170 ;; branch if negative (not zero)
 171 urword_code "-BRANCH",mbranch
 172 urword_arg_branch
 173 urword_hidden
 174   lodsd
 175   cp    TOS,0
 176   pop   TOS
 177   jr    ge,@f
 178   ld    EIP,eax
 179 @@:
 180   urnext
 181 urword_end
 182
 183 ;; used in "CASE": drops additional value if branch is NOT taken
 184 urword_code "0BRANCH-DROP",0branch_drop
 185 urword_arg_branch
 186 urword_hidden
 187   lodsd
 188   or    TOS,TOS
 189   pop   TOS
 190   jnz   @f
 191   mov   EIP,eax
 192   urnext
 193 @@:
 194   ; branch not taken, drop one more data value
 195   pop   TOS
 196   urnext
 197 urword_end
 198
 199 ;; if two values on the stack are equal, drop them, and take a branch
 200 ;; if they aren't equal, do nothing
 201 urword_code "?DO-BRANCH",qdo_branch
 202 urword_arg_branch
 203 urword_hidden
 204   lodsd
 205   cp    TOS,[esp]
 206   jr    nz,@f
 207   ;; values are equal, drop them, and take a branch
 208   pop   TOS
 209   pop   TOS
 210   mov   EIP,eax
 211 @@:
 212   urnext
 213 urword_end
 214
 215
 216 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 217 urword_code "EXECUTE",execute
 218   mov   eax,TOS
 219   pop   TOS
 220   jmp   eax
 221 urword_end
 222
 223 urword_code "OVERRIDE-EXECUTE",override_execute
 224 ;; ( ... xtoken -- ... )
 225   mov   eax,TOS
 226   pop   TOS
 227   rpush EIP
 228   ld    EIP,eax
 229   urnext
 230 urword_end
 231
 232 urword_code "(EXECUTE-INTR-CMPL)",par_execute_intr_cmpl
 233 urword_hidden
 234 ;; ( intrcfa cmplcfa -- )
 235   pop   eax
 236   ;; TOS: cmplcfa
 237   ;; EDX: intrcfa
 238   cp    dword [fvar_state_data],0
 239   cmovnz eax,TOS
 240   pop   TOS
 241   jmp   eax
 242 urword_end
 243
 244
 245 urword_code "EXIT",exit
 246 urword_noreturn
 247   rpop  EIP
 248   urnext
 249 urword_end
 250
 251 urword_code "0?EXIT",q0exit
 252 ;; ( flag -- )
 253   or    TOS,TOS
 254   pop   TOS
 255   jr    nz,@f
 256   rpop  EIP
 257 @@:
 258   urnext
 259 urword_end
 260
 261
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263 urword_code "(DO)",par_do
 264 urword_hidden
 265 ;; ( limit start -- | limit counter )
 266 ;; loops from start to limit-1
 267   ; ANS loops
 268   pop   eax
 269   ld    edx,0x80000000
 270   sub   edx,eax
 271   add   TOS,edx
 272   sub   ERP,4+4
 273   ld    [ERP+4],edx  ; 80000000h-to
 274   ld    [ERP],TOS    ; 80000000h-to+from
 275   pop   TOS
 276   urnext
 277 urword_end
 278
 279 urword_code "(+LOOP)",par_ploop
 280 urword_hidden
 281 ;; ( delta -- | limit counter )
 282   ; ANS loops
 283   add   TOS,[ERP]
 284   jr    o,.done
 285   ; next iteration
 286   ld    [ERP],TOS
 287   lodsd
 288   mov   EIP,eax
 289   pop   TOS
 290   urnext
 291 .done:
 292   add   esi,4
 293   add   ERP,4+4
 294   pop   TOS
 295   urnext
 296 urword_end
 297
 298 urword_code "(LOOP)",par_loop
 299 urword_hidden
 300 urword_uses par_ploop
 301 ;; ( -- | limit counter )
 302   push  TOS
 303   ld    TOS,1
 304   jr    fword_par_ploop
 305 urword_end
 306
 307
 308 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 309 ;; as i moved high-level compiler out of the core, we should do it there
 310 ;urword_alias "LEAVE",leave,break
 311 ;urword_immediate
 312
 313 urword_code "UNLOOP",unloop
 314 ;; k8
 315 ;; ( | limit counter -- )
 316 ;; removes loop arguments from return stack
 317 ;; can be used as: UNLOOP EXIT
 318 ;; "BREAK" compiles this word before branching out of the loop
 319   add   ERP,4+4
 320   urnext
 321 urword_end
 322
 323 urword_code "I",i
 324 ;; ( -- counter )
 325   push  TOS
 326   ld    TOS,[ERP]
 327   sub   TOS,[ERP+4]
 328   urnext
 329 urword_end
 330
 331 urword_code "J",j
 332 ;; ( -- counter )
 333   push  TOS
 334   ld    TOS,[ERP+8]
 335   sub   TOS,[ERP+8+4]
 336   urnext
 337 urword_end