path: root/jefs.fs

\ i think something is going on with the stack. i dunno
\ things TODO:
\ standardise stack comment abbrs (i like leo brodie's forth_style.txt)
\ DO LOOP
\ s\"
\ add error handling to compiling words
\ better syscall error handling
\ <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] ] ;

0 constant false
-1 constant true

\ 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

\ 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 ;
\ i don't know how to implement these correctly with 64 bit single cells
: */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 ;
\ }}}

\ 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 ;

0 constant Enone
2 constant ENOENT
9 constant EBADF
13 constant EACCES
22 constant EINVAL

: .errno ( err -- ) ?dup 0<> if case
	Enone of endof
	ENOENT of ." no such file or directory" endof
	EBADF of ." bad file descriptor" endof
	EACCES of ." permission denied" endof
	EINVAL of ." invalid argument" endof
	." mystery error (spooky)"
	endcase cr then ;
\ }}}

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

\ USER MEMORY {{{
hex
1 constant PROT_READ
2 constant PROT_WRITE
4 constant PROT_EXEC
0 PROT_READ or PROT_WRITE or PROT_EXEC or constant PROT_rwx
decimal

: mprotect  10 syscall3 ;
: sysbrk  12 syscall1 ;

: bytes-allocated  heremax @ herestart @ - ;
: bytes-used  here @ herestart @ - ;
: bytes-free  bytes-allocated bytes-used - ;

: brk@  0 sysbrk ;
: mark-exec  PROT_rwx bytes-allocated herestart @ mprotect .errno ;
: grow ( n -- )  brk@ + sysbrk heremax ! mark-exec ; \ todo check error

: .free  bytes-free u. ." of " bytes-allocated u. ." bytes free (used " bytes-used (.) say ." )" cr ;
\ }}}

: #bye ( code -- )  60 syscall1 ;
\ maybe this would be more elegant as a table?
:>  >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 ;

\ 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 do these return the right values? (true instead of false?)
: 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 {{{
\ use cmove (not cmove>) for moving stray bytes left when refilling
variable source-id
-2 constant init-source
-1 constant string-source
init-source source-id !

\ including the console input, we can recurse input buffers
\ up to four levels. (max-include-depth <=)
0 value include-depth
3 constant max-include-depth
max-include-depth 1+ constant #buffers
8192 constant /buffer
make buffers /buffer #buffers * allot
make buffers-used #buffers cells allot
make buffers->in #buffers cells allot
make buffers-fd #buffers cells allot

: cbuffer  include-depth /buffer * buffers + ;
: cbuffer-used  include-depth cells buffers-used + ;
: cbuffer->in  include-depth cells buffers->in + ;
: cbuffer-fd  include-depth cells buffers-fd + ;
stdin buffers-fd !
: buffer-refill ( u|0 ) cbuffer /buffer cbuffer-fd @ read-file 0<> if 0 then
	0 cbuffer->in ! dup cbuffer-used ! ; \ returns zero on error or nothing read.
: buffer-empty?  cbuffer->in @ cbuffer-used @ >= ;
: buffer-key ( key|-1 )  buffer-empty? if buffer-refill 0= if -1 [ ret, ] then then
	cbuffer cbuffer->in @ + c@ cbuffer->in @ 1+ cbuffer->in ! ;

\ this is profoundly horrible and ugly
0 value (accept-n)
0 value (accept-a)
0 value (accept-real-n)
: truncate-(accept-n) ( n -- )  (accept-n) to (accept-real-n)  to (accept-n) ;
: accept ( a n -- n ? )  dup to (accept-n) to (accept-real-n) to (accept-a)
	0 begin dup (accept-n) < while buffer-key dup
	0>= if ( n c -- ) dup 10 = if drop dup truncate-(accept-n) true swap
	else over (accept-a) + c! 1+ then
	else drop truncate-(accept-n) false swap then repeat
	(accept-real-n) (accept-n) = if true else swap then ;

\ i think i'll just take the wonkiness of
\ 'if you use LOAD or something like that you lose the rest of that line'
\ i dont think that's that big a deal
2048 constant line-buffer-length
make line-buffer line-buffer-length allot
\ }}}

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

.free
\ make testb 10 allot
\ testb 10 accept .s
bye