\ i think something is going on with the stack. i dunno

: 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

: 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
: make  create here @ 18 + [compile] lit ret, ;

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
: +to  parse find drop >cfa 6 + state @ if
	[compile] lit ' +! compile, else +! then ; immediate
: -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

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

\ 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 ! ; asm$

: 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,  modrm @ c, disp @ ?dup 0<> if c, then ;

: mod0  modrm @ 3f and modrm ! ;
: d)  dup disp ! mod0 0<> if modrm @ 40 or modrm ! then ; \ disp8 or 0 only for now.
: disp,  disp @ ?dup 0<> if c, then ;

: mov,  rex, 8b c, modrm @ c, disp, asm$ ;
: lea,  rex, 8d c, modrm @ c, disp, asm$ ;
: call,  rex, ff c, /2 modrm @ c, disp, asm$ ;
decimal
\ }}}

\ could be inlined?
: execute  [ rex.w r11, r14 0 d) mov,
	rex.w r14, r14 8 d) lea,
	r11 call, ] ;

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

hex
: >word  ffff and ;
: >byte  ff and ;
decimal

: not  0= ;
: /  /mod swap drop ;
: mod  /mod drop ;
: negate  0 swap - ;
: abs  dup 0< if negate then ;
: */  */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 @ .qword cell+ repeat drop cr ;
: .rs  rp cell+ ( skip rsp itself ) begin dup rs0 @ < while dup @ .qword 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 .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 ;
\ }}}

6 constant #error-msgs
make error-msgs #error-msgs cells allot
: set-error ( xt -- )  cells error-msgs + ! ;
: write-error  cells error-msgs + @ execute ;
:>  ." no error" ; 0 set-error
:>  ." stack underflow" ; 1 set-error
:>  ." word not found" ; 2 set-error
:>  ." compile mode only" ; 3 set-error
:>  ." interpret mode only" ; 4 set-error
:>  ." includes too recursed" ; 5 set-error \ awful description

: #bye ( code -- )  60 syscall1 ;
\ maybe this would be more elegant as a table?
:>  >s0 error @ dup write-error cr #bye ; to handler
: fuck ( n -- )  error ! handler execute ;

: >ffa ( lfa -- ffa )  8 + ;
: >nfa ( lfa -- nfa )  9 + ;
: (hide) ( lfa -- )  >ffa dup c@ 1 or swap c! ;
: hide  parse find drop (hide) ; \ todo error handling

: hidden? ( lfa -- ? )  >ffa c@ 1 and 0<> ;
: (words) ( lfa -- )  dup hidden? not if >nfa dup w@ swap 2 + swap say 2 spaces then ;
: 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
-2 constant init-source
-1 constant string-source
init-source value 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 truncate-(accept-n) false swap then repeat
	(accept-real-n) (accept-n) = if true else swap then ;
hide (accept-n) hide (accept-a) hide (accept-real-n)
hide truncate-(accept-n)

\ 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

\ maybe fill the old space with zeroes?
\ seem to be having issues with old words being interpreted
: refill ( -- ? )  source-id 0< if false [ ret, ] then
	0 >in ! line-buffer tib ! line-buffer line-buffer-length accept
	0= if dup 0= if #tib ! false [ ret, ] then then #tib ! true ;

\ todo?: reset retstack
: quit  0 to source-id [compile] [ begin refill while interpret ."  ok" cr repeat ;
:>  >s0 error @ write-error cr quit ; to handler

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

: ?inc-depth  include-depth max-include-depth > if 0 to include-depth 5 fuck then ;
: include-file  tib @ >r #tib @ >r >in @ >r source-id >r 1 +to include-depth
	?inc-depth
	1 -to include-depth >r >in ! >r #tib ! >r tib ! r> to source-id ;
: included ;
: include ;
\ }}}

\ TERMINAL CONTROL {{{
60 constant termios#
make termios termios# allot

hex
5401 constant TCGETS
decimal

: ioctl  16 syscall3 ;

:>  0<> if false else true then ;
termios TCGETS stdin ioctl ( noname ) swap execute value tty

\ emits are relatively slow (one syscall per char: not good)
: ESC  27 emit ;
: CSI  ESC [ char [ ] literal emit ;

\ each change uses a different one, which is not too efficient
\ Pm sequences allow multiple with ;
: CSIm ( n -- )  CSI (.) say [ char m ] literal emit ;

: foreground  30 + CSIm ;
: background  40 + CSIm ;

0 constant black  1 constant red  2 constant green
3 constant yellow  4 constant blue  5 constant magenta
6 constant cyan  7 constant white  9 constant default

: bold  1 CSIm ; : normal  0 CSIm ;
\ }}}

\ DUMP {{{
\ it's designed to look like xxd. i like xxd's hex dumps.
hex
: dump-colour ( c -- n )  dup 0= if white else
	dup 0a = if yellow else
	dup 20 < if red else
	dup 7f < if green else
	dup ff < if red else blue
	then then then then then nip ;

: dump-char ( c -- c' )  dup 20 < if drop [ char . ] literal else
	dup 7e >= if drop [ char . ] literal then then ;
decimal

: (dumpchar) ( a -- a+1 )  dup @ >byte dup dump-colour foreground dump-char emit 1+ ;
: (dumpascii) ( a -- )  16 begin ?dup 0> while swap (dumpchar) swap 1- repeat default foreground drop ;

: (dumploc) ( a -- )  (.dword) say ." : " ;

: (d+) ( a -- a+1 )  dup @ >byte dup dump-colour foreground (.byte) say default foreground 1+ ;
: (dw+) ( a -- a+2 )  (d+) (d+) space ;
: (dumphex) ( a -- ) (dw+) (dw+) (dw+) (dw+) (dw+) (dw+) (dw+) (dw+) drop ;

: (dump) ( a -- )  dup (dumploc) bold dup (dumphex) 2 spaces (dumpascii) normal cr ; \ dump cell of memory at a
: dump ( n a -- ) swap begin ?dup 0> while swap dup (dump) 16 + swap 1- repeat drop ; \ dump n lines (of 16 bytes each) of memory starting at a
\ }}}

0 constant version
: welcome  ." welcome to Jewelforth, version " version u. cr .free ;

welcome quit bye