path: root/jefs.fs

\ i think something is going on with the stack. i dunno
\ things TODO:
\ DO LOOP
\ s\"
\ add error handling to compiling words
\ <builds does>
\ argc/argv
\ file io
\ interactive input

: cell+  8 + ;
: say ( c-addr u -- )  swap 1 1 syscall3 drop ;
: emit ( chr -- )  sp cell+ 1 swap 1 1 syscall3 2drop ;
: cr  10 emit ;

: octal  8 base ! ;
: decimal  10 base ! ;
: hex  16 base ! ;

\ FLOW CONTROL {{{
\ jump helpers from forth83 (got them from pforth tho ehehe)
\ < backward jump  > forward jump
\ adding/subtracting 4 gets to the next instruction.
: <mark  here @ ;
: <resolve  here @ 4 + - d, ;
: >mark  here @ 0 d, ;
: >resolve  dup here @ swap - 4 - swap d! ;

: begin  <mark ; immediate
: again  branch <resolve ; immediate
: until  ?branch <resolve ; immediate
: if  ?branch >mark ; immediate ( I: -- a )
: else  branch >mark swap >resolve ; immediate
: then  >resolve ; immediate
: while  ?branch >mark ; immediate
: repeat  branch swap <resolve >resolve ; immediate

: ?dup  dup 0<> if dup then ;
\ }}}

: nip  swap drop ;
: tuck  swap over ;

hex : ret,  c3 c, ; decimal

: execute  [ hex
	4d c, 8b c, 1e c, \ mov r11, [r14]
	\ REX.W + 8B /r  --  MOV r64, r/m64
	\ rex w (64 bit operand size), r (modrm.reg ext), b (modrm.rm ext)
	\ modrm 00 011 110
	\ mod [r/m]  reg 1.011 (r11)  r/m 1.110 (r14)
	4d c, 8d c, 76 c, 08 c, \ lea r14, [r14+8]
	\ REX.W + 8D /r  --  LEA r64, m
	\ rex w (64 bit operand size), r (modrm.reg ext), b (modrm.rm ext)
	\ modrm 01 110 110
	\ mod [r/m+disp8]  reg 1.110 (r14)  r/m 1.110 (r14)
	41 c, ff c, d3 c, \ call r11
	\ FF /2  --  CALL r/m64
	\ rex b (.rm ext)
	\ modrm 11 010 011
	\ mod r/m  reg /2   r/m 1.011 (r11)
	decimal ] ;

: ?comp  state @ 0<> if 3 error ! handler execute then ;
: ?intr  state @ if 4 error ! handler execute then ;

: cells  8 * ;
: allot@  here @ swap here +! ;
: allot  allot@ drop ;

: [compile]  parse find drop >cfa compile, ; immediate
: '  parse find drop >cfa state @ if [compile] lit then ; immediate \ note: no error handling (yet)
: recurse  latest @ >cfa compile, ; immediate

: literal  [compile] lit ; immediate
: constant  create [compile] lit ret, ;
: variable  1 cells allot@ create [compile] lit ret, ;
\ maybe i made bad design decisions, this is CREATE but it pushes a pointer to just after its definition. for arrays and the like
\ does not use LIT because we want to fill it in After
: make  create here @ 18 + [compile] lit ret, ;
\ creates a word called _ (so don't create an actual word called that!!!)
\ maybe it could be an empty string but that might require some rewriting
\ (maybe a bad solution, but ; expects a header and reads from LATEST...
\ maybe WORDS should skip words whose name is just _?)
\ it may not be a bad idea to redefine ; above this so it works with :> words.
\ maybe a NONAMING? variable so we know it's a :> word and thus does not need to be unsmudged?
\ also we can't use CREATE because it reads from tib. eugh
: :>  here @ latest @ , 0 c, 1 w, [ char _ ] literal c, latest ! smudge here @ ( ← xt ) [compile] ] ;

\ jonesforth impl
: case  0 ; immediate
: of  ' over compile, ' = compile, [compile] if ' drop compile, ; immediate
: endof  [compile] else ; immediate
: endcase  ' drop compile, begin ?dup while [compile] then repeat ; immediate

: value  create [compile] lit ret, ;
: to  parse find drop >cfa 6 + state @ if
	[compile] lit ' ! compile, else ! then ; immediate

\ TODO interpret mode strings?
: s"  1 >in +! [ char " ] literal cparse branch >mark >r 2dup cmove, nip r> dup >resolve 4 + [compile] lit [compile] lit ; immediate
: ."  [compile] s" ' say compile, ; immediate \ lol this word breaks the highlighting, here have another "
: z"  1 >in +! [ char " ] literal cparse branch >mark >r 2dup cmove, 0 c, nip r> dup >resolve 4 + [compile] lit drop ( 1+ [compile] lit ) ; immediate

\ ASSEMBLER {{{
\ https://wiki.osdev.org/X86-64_Instruction_Encoding
\ see dusk os asm/x86.fs
\ my idea is that operands are given in the reverse order that
\ they are in intel notation, so that intel notation can be vaguely
\ turned into this assembler by moving the mnemonic to the end,
\ like: mov r11, r12  ->  smth like r11 r12 mov,
\ a lot of this would probably be more elegant but i have to get around
\ to <builds and does>. i don't want to have to
hex
variable rex
variable modrm
variable disp

: asm$  0 rex ! c0 modrm ! 0 disp ! ;

: rex.w  rex @ 48 or rex ! ;
: rex.r  rex @ 44 or rex ! ;
: rex.x  rex @ 42 or rex ! ;
: rex.b  rex @ 41 or rex ! ;
: rex,  rex @ ?dup if c, then ;

\ REGISTERS {{{
: rax  modrm @ 0 or modrm ! ; : rcx  modrm @ 1 or modrm ! ;
: rdx  modrm @ 2 or modrm ! ; : rbx  modrm @ 3 or modrm ! ;
: rsp  modrm @ 4 or modrm ! ; : rbp  modrm @ 5 or modrm ! ;
: rsi  modrm @ 6 or modrm ! ; : rdi  modrm @ 7 or modrm ! ;
: r8   modrm @ 0 or modrm ! rex.b ; : r9   modrm @ 1 or modrm ! rex.b ;
: r10  modrm @ 2 or modrm ! rex.b ; : r11  modrm @ 3 or modrm ! rex.b ;
: r12  modrm @ 4 or modrm ! rex.b ; : r13  modrm @ 5 or modrm ! rex.b ;
: r14  modrm @ 6 or modrm ! rex.b ; : r15  modrm @ 7 or modrm ! rex.b ;

: rax,  modrm @ 00 or modrm ! ; : rcx,  modrm @ 08 or modrm ! ;
: rdx,  modrm @ 10 or modrm ! ; : rbx,  modrm @ 18 or modrm ! ;
: rsp,  modrm @ 20 or modrm ! ; : rbp,  modrm @ 28 or modrm ! ;
: rsi,  modrm @ 30 or modrm ! ; : rdi,  modrm @ 38 or modrm ! ;
: r8,   modrm @ 00 or modrm ! rex.r ; : r9,   modrm @ 08 or modrm ! rex.r ;
: r10,  modrm @ 10 or modrm ! rex.r ; : r11,  modrm @ 18 or modrm ! rex.r ;
: r12,  modrm @ 20 or modrm ! rex.r ; : r13,  modrm @ 28 or modrm ! rex.r ;
: r14,  modrm @ 30 or modrm ! rex.r ; : r15,  modrm @ 38 or modrm ! rex.r ;
\ }}}

: /0  modrm @ 00 or modrm ! ; : /1  modrm @ 08 or modrm ! ;
: /2  modrm @ 10 or modrm ! ; : /3  modrm @ 18 or modrm ! ;
: /4  modrm @ 20 or modrm ! ; : /5  modrm @ 28 or modrm ! ;
: /6  modrm @ 30 or modrm ! ; : /7  modrm @ 38 or modrm ! ;
: modrm,  ;

\ TODO store and write the displacement if given
: mod0  modrm @ 3f and modrm ! ;
: d)  disp ! mod0 0<> if modrm @ 40 or modrm ! then ; \ disp8 or 0 only for now

: mov,  rex, 8b c, modrm @ c, asm$ ;

\ example idea: (from execute below)
\ rex.w r11, r14 0 d) mov,
\ rex.w r14, r14 8 d) lea,
\ r11 call,
decimal
\ }}}

: not  0= ;
: /  /mod swap drop ;
: mod  /mod drop ;
: negate  0 swap - ;
: abs  dup 0< if negate then ;
: */mod  >r * r> /mod ;
: */  */mod nip ;
: %  100 */ ;

32 constant bl
: space  bl emit ;
: spaces  begin dup 0> while space 1- repeat drop ;

\ PNO {{{
\ mostly from pforth
255 allot variable pad
variable hld
: <#  pad hld ! ;
: hold  1 hld -! ( chr ) hld @ c! ;
: sign  0< if [ char - ] literal hold then ;
: #  base @ /mod swap 9 over > if 7 + then [ char 0 ] literal + hold ;
: #s  begin # dup 0= until ;
: #>  drop hld @ pad over - ;

: (u.)  <# #s #> ;
: u.  (u.) say space ;
: u.r  >r (u.) r> over - spaces say ;

: (.)  dup abs <# #s swap sign #> ;
: . (.)  say space ;
: .r  >r (.) r> over - spaces say ;

: (.byte)  hex <# # # #> decimal ;
: .byte  (.byte) say space ;
: (.word)  hex <# # # # # #> decimal ;
: .word  (.word) say space ;
: (.dword)  hex <# # # # # # # # # #> decimal ;
: .dword  (.dword) say space ;
: (.qword)  hex <# # # # # # # # # # # # # # # # # #> decimal ;
: .qword  (.qword) say space ;
\ }}}

: ?  @ . ;
: .s  sp cell+ ( skip sp itself ) begin dup s0 @ > while dup @ .qword cell+ repeat drop cr ;
: .rs  rp cell+ ( skip rsp itself ) begin dup rs0 @ > while dup @ .qword cell+ repeat drop cr ;

: bytes-allocated  heremax @ herestart @ - ;
: bytes-used  here @ herestart @ - ;
: bytes-free  bytes-allocated bytes-used - ;
: .free  bytes-free u. ." of " bytes-allocated u. ." bytes free (used " bytes-used (.) say ." )" cr ;

: #bye ( code -- )  60 syscall1 ;
:>  >s0 error @ dup case
	1 of ." stack underflow" endof
	2 of ." word not found" endof
	3 of ." compile mode only" endof
	4 of ." interpret mode only" endof
	." unknown error"
	endcase cr #bye ; to handler
: fuck ( n -- )  error ! handler execute ;

: >ffa ( lfa -- ffa )  8 + ;
: >nfa ( lfa -- nfa )  9 + ;
: (words) ( lfa -- )  >nfa dup w@ swap 2 + swap say 2 spaces ;
: words  latest @ begin ?dup 0<> while dup (words) @ repeat cr ;

: (evaluate) ( c-addr u -- )  0 >in ! ( u ) #tib ! ( c-addr ) tib ! interpret ;
: evaluate ( c-addr u -- )  tib @ >r #tib @ >r >in @ >r (evaluate) r> >in ! r> #tib ! r> tib ! ;

\ SYSCALL ERRORS {{{
: errno ( rax -- ?val err|0 ) dup 0< if negate else 0 then ;
: errno-flag ( rax -- err|0 ) dup 0< if negate else drop 0 then ;

2 constant enoent
9 constant ebadf
13 constant eacces

: .errno ( err -- ) ?dup 0<> if case
	enoent of ." no such file or directory" endof
	ebadf of ." bad file descriptor" endof
	eacces of ." permission denied" endof
	." mystery error (spooky)"
	endcase cr then ;
\ }}}

\ I/O {{{
0 constant stdin
1 constant stdout
2 constant stderr

: sysread ( u c-addr fd -- )  0 syscall3 ;
: syswrite ( u c-addr fd -- n )  1 syscall3 ;
: sysopen ( mode flags filename -- )  2 syscall3 ;
: sysclose ( fd -- )  3 syscall1 ;

0 constant r/o
1 constant w/o
2 constant r/w

\ TODO error handling (0< abs → errno i think)
\ flags are zero on success
\ maybe there should be some sort of read buffering support here
: open-file ( mode zstr -- ?fd flag )  0 -rot sysopen errno ;
: close-file ( fd -- flag )  sysclose errno-flag ;
: read-file ( c-addr u fd -- ?u flag )  >r swap r> sysread errno ;
: write-file ( c-addr u fd -- ?u flag )  >r swap r> syswrite errno ;
\ }}}

\ USER INPUT {{{
8192 constant file-buffer-length
make file-buffer file-buffer-length allot
\ }}}

\ INTERACTIVITY {{{
\ i hate dealing with user input!!!
\ but my idea is: when reading forth from a file,
\ words are read into a buffer, and read from there.
\ }}}

.free
\ file-buffer file-buffer-length stdin read-file drop file-buffer swap evaluate
bye