level0/urforth0_w_stack.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 "SP@",spget
  20   push  TOS
  21   mov   TOS,esp
  22   urnext
  23 urword_end
  24
  25 urword_code "RP@",rpget
  26   push  TOS
  27   mov   TOS,ERP
  28   urnext
  29 urword_end
  30
  31 urword_code "SP!",spset
  32   mov   esp,TOS
  33   pop   TOS
  34   urnext
  35 urword_end
  36
  37 urword_code "RP!",rpset
  38   mov   ERP,TOS
  39   pop   TOS
  40   urnext
  41 urword_end
  42
  43 urword_code "SP0!",spset0
  44   mov   esp,[fvar_sp0_data]
  45   xor   TOS,TOS
  46   urnext
  47 urword_end
  48
  49 urword_code "RP0!",rpset0
  50   mov   ERP,[fvar_rp0_data]
  51   urnext
  52 urword_end
  53
  54 urword_code "(SP-CHECK)",par_spcheck
  55   mov   eax,esp
  56   cmp   eax,[fvar_sp0_data]
  57   jr    na,.ok
  58   mov   esp,[fvar_sp0_data]
  59   xor   TOS,TOS
  60   push  TOS
  61   urnext
  62 .ok:
  63   push  TOS
  64   mov   TOS,1
  65   urnext
  66 urword_end
  67
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 urword_code "RDUP",rdup
  71   rpeek eax
  72   rpush eax
  73   urnext
  74 urword_end
  75
  76 urword_code "RDROP",rdrop
  77   rdrop
  78   urnext
  79 urword_end
  80
  81 urword_code ">R",rpush
  82   rpush TOS
  83   pop   TOS
  84   urnext
  85 urword_end
  86
  87 urword_code "R>",rpop
  88   push  TOS
  89   rpop  TOS
  90   urnext
  91 urword_end
  92
  93 urword_code "R@",rpeek
  94   push  TOS
  95   rpeek TOS
  96   urnext
  97 urword_end
  98
  99
 100 urword_code "2RDROP",2rdrop
 101   add   ERP,4*2
 102   urnext
 103 urword_end
 104
 105 urword_code "2>R",2rpush
 106 ;; ( n0 n1 -- || -- n0 n1 )
 107   pop   eax   ; n0
 108   rpush eax
 109   rpush TOS
 110   pop   TOS
 111   urnext
 112 urword_end
 113
 114 urword_code "2R>",2rpop
 115 ;; ( -- n0 n1 || n0 n1 -- )
 116   push  TOS
 117   rpop  TOS
 118   rpop  eax
 119   push  eax
 120   urnext
 121 urword_end
 122
 123 urword_code "2R@",2rpeek
 124 ;; ( -- n0 n1 || n0 n1 )
 125   push  TOS
 126   push  dword [ERP+4]
 127   mov   TOS,dword [ERP]
 128   urnext
 129 urword_end
 130
 131
 132 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 133 urword_code "DUP",dup
 134   push  TOS
 135   urnext
 136 urword_end
 137
 138 urword_code "2DUP",2dup
 139 ;; ( n0 n1 -- n0 n1 n0 n1 )
 140   mov   eax,[esp]
 141   ; TOS: n1
 142   ; EAX: n0
 143   push  TOS
 144   push  eax
 145   urnext
 146 urword_end
 147
 148 urword_code "?DUP",qdup
 149   or    TOS,TOS
 150   jz    @f
 151   push  TOS
 152 @@:
 153   urnext
 154 urword_end
 155
 156 ;; drop if zero
 157 urword_code "?DROP",qdrop
 158   or    TOS,TOS
 159   jr    nz,@f
 160   pop   TOS
 161 @@:
 162   urnext
 163 urword_end
 164
 165 urword_code "DROP",drop
 166   pop   TOS
 167   urnext
 168 urword_end
 169
 170 urword_code "2DROP",2drop
 171   pop   TOS
 172   pop   TOS
 173   urnext
 174 urword_end
 175
 176 urword_code "SWAP",swap
 177   xchg  [esp],TOS
 178   urnext
 179 urword_end
 180
 181 urword_code "2SWAP",2swap
 182 ;; ( n0 n1 n2 n3 -- n2 n3 n0 n1 )
 183   ; TOS=n3
 184   pop   eax       ; EAX=n2
 185   pop   FREEREG   ; FRG=n1
 186   xchg  [esp],eax ; EAX=n0
 187   push  TOS
 188   push  eax
 189   mov   TOS,FREEREG
 190   urnext
 191 urword_end
 192
 193 urword_code "OVER",over
 194   push  TOS
 195   mov   TOS,[esp+4]
 196   urnext
 197 urword_end
 198
 199 urword_code "2OVER",2over
 200 ;; ( n0 n1 n2 n3 -- n0 n1 n2 n3 n0 n1 )
 201   ; TOS=n3
 202   push  TOS
 203   mov   eax,[esp+12]
 204   mov   TOS,[esp+8]
 205   push  eax
 206   urnext
 207 urword_end
 208
 209 urword_code "ROT",rot
 210   pop   FREEREG
 211   pop   eax
 212   push  FREEREG
 213   push  TOS
 214   mov   TOS,eax
 215   urnext
 216 urword_end
 217
 218 urword_code "NROT",nrot
 219   pop   FREEREG
 220   pop   eax
 221   push  TOS
 222   push  eax
 223   mov   TOS,FREEREG
 224   urnext
 225 urword_end
 226
 227 urword_alias "-ROT",nrot_alias,nrot
 228
 229
 230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 231 ;; SWAP DROP
 232 urword_code "NIP",nip
 233 ;; ( n1 n2 -- n2 )
 234   pop   eax
 235   urnext
 236 urword_end
 237
 238 ;; SWAP OVER
 239 urword_code "TUCK",tuck
 240 ;; ( n1 n2 -- n2 n1 n2 )
 241   pop   eax
 242   push  TOS
 243   push  eax
 244   urnext
 245 urword_end
 246
 247
 248 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 249 urword_code "DEPTH",depth
 250 ;; ( -- stack-depth-before-this-call )
 251   push  TOS
 252   ld    TOS,[fvar_sp0_data]
 253   sub   TOS,esp
 254   sar   TOS,2
 255   dec   TOS
 256   urnext
 257 urword_end
 258
 259 urword_code "RDEPTH",rdepth
 260 ;; ( -- rstack-depth-before-this-call )
 261   push  TOS
 262   ld    TOS,[fvar_rp0_data]
 263   sub   TOS,ebp
 264   sar   TOS,2
 265   urnext
 266 urword_end
 267
 268
 269 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 270 urword_code "PICK",pick
 271 ;; ( ... idx -- ... n[top-idx-1] )
 272 ;; remove idx, copy item; 0 PICK is the same as DUP
 273   ld    TOS,[esp+TOS*4]
 274   urnext
 275 urword_end
 276
 277 urword_code "ROLL",roll
 278 ;; ( ... idx -- ... n[top-idx-1] )
 279 ;; remove idx, move item; 0 ROLL is the same as NOOP
 280   jecxz .quit
 281   ld    FREEREG,esi
 282   ld    eax,[esp+TOS*4]
 283   lea   esi,[esp+TOS*4]
 284   ld    edi,esi
 285   sub   esi,4
 286   std
 287   rep movsd
 288   cld
 289   ld    esi,FREEREG
 290   ld    [esp],eax
 291 .quit:
 292   pop   TOS
 293   urnext
 294 urword_end
 295
 296
 297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 298 urword_code "RPICK",rpick
 299 ;; ( ... idx -- ... n[top-idx-1] )
 300 ;; remove idx, copy item from return stack; 0 RPICK is the same as R@
 301   ld    TOS,[ebp+TOS*4]
 302   urnext
 303 urword_end