level1/14_dstack.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 code: SP@  ( -- sp )
   8   push  TOS
   9   mov   TOS,esp
  10   urnext
  11 endcode
  12
  13 code: SP!  ( n -- )
  14   mov   esp,TOS
  15   pop   TOS
  16   urnext
  17 endcode
  18
  19 code: SP0!  ( -- )
  20   mov   esp,ts:[ua_ofs_sp0]
  21   xor   TOS,TOS
  22   urnext
  23 endcode
  24
  25 code: (SP-CHECK)  ( -- ok-flag )
  26   cp    esp,ts:[ua_ofs_sp0]
  27   jr    na,.ok
  28   mov   esp,ts:[ua_ofs_sp0]
  29   xor   TOS,TOS
  30   push  TOS
  31   urnext
  32 .ok:
  33   push  TOS
  34   mov   TOS,1
  35   urnext
  36 endcode
  37
  38
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40 code: DUP  ( n -- n n )
  41   push  TOS
  42   urnext
  43 endcode
  44
  45 code: 2DUP  ( n0 n1 -- n0 n1 n0 n1 )
  46   mov   eax,[esp]
  47   ;; TOS: n1
  48   ;; EAX: n0
  49   push  TOS
  50   push  eax
  51   urnext
  52 endcode
  53
  54 code: ?DUP  ( n0 -- n0 n0  ||  0 -- 0 )
  55   jecxz @f
  56   push  TOS
  57 @@:
  58   urnext
  59 endcode
  60
  61 code: DROP  ( n0 -- )
  62   pop   TOS
  63   urnext
  64 endcode
  65
  66 code: 2DROP  ( n0 n1 -- )
  67   pop   TOS
  68   pop   TOS
  69   urnext
  70 endcode
  71
  72 code: SWAP  ( n0 n1 -- n1 n0 )
  73   xchg  [esp],TOS
  74   urnext
  75 endcode
  76
  77 code: 2SWAP  ( n0 n1 n2 n3 -- n2 n3 n0 n1 )
  78   ;; TOS=n3
  79   pop   eax       ;; EAX=n2
  80   pop   edx       ;; FRG=n1
  81   xchg  [esp],eax ;; EAX=n0
  82   push  TOS
  83   push  eax
  84   mov   TOS,edx
  85   urnext
  86 endcode
  87
  88 code: OVER  ( n0 n1 -- n0 n1 n0 )
  89   push  TOS
  90   mov   TOS,[esp+4]
  91   urnext
  92 endcode
  93
  94 code: 2OVER  ( n0 n1 n2 n3 -- n0 n1 n2 n3 n0 n1 )
  95   ;; TOS=n3
  96   push  TOS
  97   mov   eax,[esp+12]
  98   mov   TOS,[esp+8]
  99   push  eax
 100   urnext
 101 endcode
 102
 103 code: ROT  ( n0 n1 n2 -- n1 n2 n0 )
 104   pop   edx
 105   pop   eax
 106   push  edx
 107   push  TOS
 108   mov   TOS,eax
 109   urnext
 110 endcode
 111
 112 code: NROT  ( n0 n1 n2 -- n2 n0 n1 )
 113   pop   edx
 114   pop   eax
 115   push  TOS
 116   push  eax
 117   mov   TOS,edx
 118   urnext
 119 endcode
 120
 121 alias NROT -ROT
 122
 123
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 ;; SWAP DROP
 126 code: NIP  ( n1 n2 -- n2 )
 127   pop   eax
 128   urnext
 129 endcode
 130
 131 ;; SWAP OVER
 132 code: TUCK  ( n1 n2 -- n2 n1 n2 )
 133   pop   eax
 134   push  TOS
 135   push  eax
 136   urnext
 137 endcode
 138
 139
 140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 141 code: DEPTH  ( -- stack-depth-before-this-call )
 142   push  TOS
 143   ld    TOS,ts:[ua_ofs_sp0]
 144   sub   TOS,esp
 145   sar   TOS,2
 146   dec   TOS
 147   urnext
 148 endcode
 149
 150
 151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 152 ;; remove idx, copy nth item; 0 PICK is the same as DUP
 153 code: PICK  ( ... idx -- ... n[top-idx-1] )
 154   ld    TOS,[esp+TOS*4]
 155   urnext
 156 endcode
 157
 158 alias PICK PEEK
 159
 160 ;; remove idx and val, set nth item (numbered as in PICK)
 161 code: POKE  ( ... val idx -- ... )
 162   pop   eax
 163   ld    [esp+TOS*4],eax
 164   pop   TOS
 165   urnext
 166 endcode
 167
 168 ;; remove idx, move item; 0 ROLL is the same as NOOP
 169 code: ROLL  ( ... idx -- ... n[top-idx-1] )
 170   jecxz .quit
 171   ld    edx,esi
 172   ld    eax,[esp+TOS*4]
 173   lea   esi,[esp+TOS*4]
 174   ld    edi,esi
 175   sub   esi,4
 176   std
 177   rep movsd
 178   cld
 179   ld    esi,edx
 180   ld    [esp],eax
 181 .quit:
 182   pop   TOS
 183   urnext
 184 endcode
 185
 186
 187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 188 code: ALLOCA  ( bytes -- addr )
 189   add   TOS,3
 190   and   TOS,-4
 191   sub   esp,TOS
 192   ld    TOS,esp
 193   urnext
 194 endcode
 195
 196 code: DEALLOCA  ( bytes -- )
 197   add   TOS,3
 198   and   TOS,-4
 199   add   esp,TOS
 200   pop   TOS
 201   urnext
 202 endcode