preForth/seedForth-i386.pre

   1 \ seedForth - seed it, feed it, grow it - i386 (32 bit) ITC flavour   uho 2018-04-13
   2 \ ----------------------------------------------------------------------------------
   3 \
   4 \  - registers:
   5 \      EAX, EDX  general purpose
   6 \      ESI  instruction pointer
   7 \      EBP  return stack pointer
   8 \      ESP  data stack pointer
   9
  10 prelude
  11 ;;; This is seedForth - a small, potentially interactive Forth, that dynamically
  12 ;;; bootstraps from a minimal kernel.
  13 ;;;
  14 ;;;    cat seedForth.seed - | ./seedForth
  15 ;;;
  16 ;;; .seed-files are in byte-tokenized source code format.
  17 ;;;
  18 ;;; Use the seedForth tokenizer to convert human readable source code to byte-token form.
  19 ;
  20
  21 prefix
  22 format ELF
  23
  24 section '.bss' executable writable
  25
  26        DD 10000 dup(0)
  27 stck:  DD 16 dup(0)
  28
  29        DD 10000 dup(0)
  30 rstck: DD 16 dup(0)
  31
  32 _dp:    DD _start  ; dictionary pointer: points to next free location in memory
  33         ; free memory starts at _start
  34
  35 _hp:    DD 0       ; head pointer: points to first unused head
  36 _head:  DD 10000 dup (0)
  37
  38
  39 section '.text' executable writable align 4096
  40
  41 public main
  42 extrn putchar
  43 extrn getchar
  44 extrn fflush
  45 extrn exit
  46 extrn mprotect
  47
  48 macro next  {
  49        lodsd
  50        jmp dword [eax]
  51 }
  52
  53 origin:
  54
  55 main:  cld
  56        mov esp, dword stck
  57        mov ebp, dword rstck
  58
  59        ; make section writable
  60        push ebp
  61        mov ebp, esp
  62        sub esp, 16
  63        and esp, 0xfffffff0
  64        mov dword [esp+8], 7  ; rwx
  65        mov eax, memtop
  66        sub eax, origin
  67        mov dword [esp+4], eax
  68        mov dword [esp], origin
  69        call mprotect
  70        mov esp, ebp
  71        pop ebp
  72        or eax, eax     ; error?
  73        jz main0
  74        push ebp
  75        mov ebp, esp
  76        push eax
  77        and esp, 0xfffffff0
  78        ; call __error    ; get error code on Mac OS
  79        ; mov eax, [eax]
  80        ; call __errno_location ; get error on Linux
  81        ; mov eax, [eax]
  82        mov [esp], eax
  83        call exit
  84
  85 main0: mov esi, main1
  86        next
  87
  88 main1: DD _cold
  89        DD _bye
  90
  91 _nest:  lea ebp, [ebp-4]
  92         mov [ebp], esi
  93         lea esi, [eax+4]
  94         next
  95
  96 _dodoes: ; ( -- addr ) \ call me
  97         lea ebp, [ebp-4]  ; push IP
  98         mov [ebp], esi
  99         pop esi           ; set IP to caller
 100 _dovar: ; ( -- addr )
 101         lea eax,[eax+4] ; to parameter field
 102         push eax
 103         next
 104
 105 _O = 0
 106
 107 ;
 108
 109
 110 code bye ( -- )
 111     push ebp
 112     mov ebp, esp
 113     and esp, 0xfffffff0
 114     mov eax, 0
 115     mov [esp], eax
 116     call exit
 117 ;
 118
 119 code emit ( c -- )
 120     pop eax
 121
 122     push ebp
 123     mov  ebp, esp
 124     push eax
 125     and  esp, 0xfffffff0
 126
 127     mov dword [esp], eax
 128     call putchar
 129
 130     mov eax, 0
 131     mov [esp], eax
 132     call fflush   ; flush all output streams
 133
 134     mov esp, ebp
 135     pop ebp
 136     next
 137 ;
 138
 139 code key ( -- c )
 140         push ebp
 141         mov  ebp, esp
 142         and  esp, 0xfffffff0
 143
 144         call getchar
 145         mov esp, ebp
 146         pop ebp
 147         cmp eax,-1
 148         jnz key1
 149         mov eax,4
 150 key1:   push eax
 151         next
 152 ;
 153
 154 code dup ( x -- x x )
 155         pop eax
 156         push eax
 157         push eax
 158         next
 159 ;
 160
 161 code swap ( x y -- y x )
 162         pop edx
 163         pop eax
 164         push edx
 165         push eax
 166         next
 167 ;
 168
 169 code drop ( x -- )
 170         pop eax
 171         next
 172 ;
 173
 174 code 0< ( x -- flag )
 175         pop eax
 176         or eax, eax
 177         mov eax, 0
 178         jns zless1
 179         dec eax
 180 zless1: push eax
 181         next
 182 ;
 183
 184 code ?exit ( f -- )
 185         pop eax
 186         or eax, eax
 187         jz qexit1
 188         mov esi, [ebp]
 189         lea ebp,[ebp+4]
 190 qexit1: next
 191 ;
 192
 193 code >r ( x -- ) ( R -- x )
 194         pop ebx
 195         lea ebp,[ebp-4]
 196         mov [ebp], ebx
 197         next
 198 ;
 199
 200 code r> ( R x -- ) ( -- x )
 201         mov eax,[ebp]
 202         lea ebp, [ebp+4]
 203         push eax
 204         next
 205 ;
 206
 207 code - ( x1 x2 -- x3 )
 208         pop edx
 209         pop eax
 210         sub eax, edx
 211         push eax
 212         next
 213 ;
 214
 215 code unnest ( -- )
 216         mov esi,[ebp]
 217         lea ebp,[ebp+4]
 218         next
 219 ;
 220
 221 code lit ( -- )
 222         lodsd
 223         push eax
 224         next
 225 ;
 226
 227 code @ ( addr -- x )
 228         pop eax
 229         mov eax,[eax]
 230         push eax
 231         next
 232 ;
 233
 234 code c@ ( c-addr -- c )
 235         pop edx
 236         xor eax, eax
 237         mov al,byte [edx]
 238         push eax
 239         next
 240 ;
 241
 242 code ! ( x addr -- )
 243         pop edx
 244         pop eax
 245         mov dword [edx],eax
 246         next
 247 ;
 248
 249 code c! ( c c-addr -- )
 250         pop edx
 251         pop eax
 252         mov byte [edx], al
 253         next
 254 ;
 255
 256 code execute ( xt -- ) \ native code: >r :
 257         pop eax
 258         jmp dword [eax]
 259 ;
 260
 261 code branch ( -- )  \ threaded code: r>  @ >r ;
 262         lodsd
 263         mov esi,eax
 264         next
 265 ;
 266
 267 code ?branch ( f -- ) \ threaded code:  ?exit r> @ >r ;
 268         pop eax
 269         or eax,eax
 270         jz _branchX
 271         lea esi,[esi+4]
 272         next
 273 ;
 274
 275 : negate ( n1 -- n2 )
 276    0 swap - ;
 277
 278 : + ( x1 x2 -- x3 )
 279    negate - ;
 280
 281 : 0= ( x -- flag )
 282    0 swap ?exit drop -1 ;
 283
 284 : ?dup ( x -- x x | 0 )
 285    dup 0= ?exit dup ;
 286
 287 : cells ( x1 -- x2 )
 288    dup + dup + ;
 289
 290 : +! ( x addr -- )
 291    swap >r  dup @ r> +  swap ! ;
 292
 293 : h@ ( i -- addr )
 294    cells lit head + @ ;
 295
 296 : h! ( x i -- )
 297    cells lit head + ! ;
 298
 299 : h, ( x -- )
 300    lit hp @  h!   1 lit hp +! ;
 301
 302 : here ( -- addr )
 303    lit dp @ ;
 304
 305 : allot ( n -- )
 306    lit dp +! ;
 307
 308 : , ( x -- )
 309    here   1 cells allot  ! ;
 310
 311 : c, ( c -- )
 312    here   1 allot c! ;
 313
 314 : interpreter ( -- )
 315    key h@ execute   tail interpreter ;
 316
 317 : compiler ( -- )
 318    key ?dup 0= ?exit h@ ,   tail compiler ;
 319
 320 : fun ( -- )
 321    here h,  lit nest ,  compiler ;
 322
 323
 324 : create ( -- )
 325    here h, lit dovar , ;
 326
 327 : ,call ( x -- )
 328    232 c, here >r  0 ,   here -   r> ! ;  \ call near 32bit
 329
 330 : does ( -- )
 331    r>   lit hp @ 1 - h@  ! ; \ set code field of last defined word
 332
 333 : does> ( -- )
 334    lit does ,
 335    lit dodoes ,call ;
 336
 337
 338 : cold ( -- )
 339    's' emit 'e' dup emit emit  'd' emit 10 emit
 340    lit bye         h, \ 0   00
 341    lit emit        h, \ 1   01
 342    lit key         h, \ 2   02
 343    lit dup         h, \ 3   03
 344    lit swap        h, \ 4   04
 345    lit drop        h, \ 5   05
 346    lit 0<          h, \ 6   06
 347    lit ?exit       h, \ 7   07
 348    lit >r          h, \ 8   08
 349    lit r>          h, \ 9   09
 350    lit -           h, \ 10  0A
 351    lit unnest      h, \ 11  0B
 352    lit lit         h, \ 12  0C
 353    lit @           h, \ 13  0D
 354    lit c@          h, \ 14  0E
 355    lit !           h, \ 15  0F
 356    lit c!          h, \ 16  10
 357    lit execute     h, \ 17  11
 358    lit branch      h, \ 18  12
 359    lit ?branch     h, \ 19  13
 360    lit negate      h, \ 20  14
 361    lit +           h, \ 21  15
 362    lit 0=          h, \ 22  16
 363    lit ?dup        h, \ 23  17
 364    lit cells       h, \ 24  18
 365    lit +!          h, \ 25  19
 366    lit h@          h, \ 26  1A
 367    lit h,          h, \ 27  1B
 368    lit here        h, \ 28  1C
 369    lit allot       h, \ 29  1D
 370    lit ,           h, \ 30  1E
 371    lit c,          h, \ 31  1F
 372    lit fun         h, \ 32  20
 373    lit interpreter h, \ 33  21
 374    lit compiler    h, \ 34  22
 375    lit create      h, \ 35  23
 376    lit does>       h, \ 36  24
 377    lit cold        h, \ 37  25
 378    tail interpreter ;
 379
 380 pre
 381  _start: DB 43
 382          DD 10000 dup (0)
 383  memtop: DD 0
 384 ;