path: root/jefs.fs

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

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

: binary  2 base ! ;
: 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

: s>z ( a u -- zstr )  here @ -rot cmove, 0 c, ;
: strlen ( zstr -- len )  dup begin dup c@ 0<> while 1+ repeat swap - ;

\ 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 else drop then ;
: words  latest @ begin ?dup 0<> while dup (words) @ repeat cr ;

: depth ( -- n )  s0 @ sp @ - 16 - ;

\ 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

: 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)

2048 constant line-buffer-length
make line-buffer line-buffer-length allot

: 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 ! ;

\ for now, if you include a file the rest of the line is discarded
: ?inc-depth  include-depth max-include-depth > if 0 to include-depth 5 fuck then ;
: include-file ( fd -- )  source-id >r to source-id 1 +to include-depth
	?inc-depth 0 cbuffer-used ! 0 cbuffer->in ! source-id cbuffer-fd !
	begin refill while interpret repeat
	1 -to include-depth r> to source-id ;
: included ( a u -- )  s>z r/o swap open-file ?dup 0= if include-file else .errno quit then ;
: include ( "path" -- )  parse included ;
\ }}}

\ ARGS {{{
: argc  rs0 @ @ ;
: argv ( n -- a u )  1+ cells rs0 @ + @ dup strlen ; \ segfaults if n>=argc
: environ  argc 2 + cells rs0 @ + ;
\ }}}

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

19 constant NCCS
: termios.c_iflag ;
: termios.c_oflag  4 + ;
: termios.c_cflag  8 + ;
: termios.c_lflag  12 + ;
: termios.c_line   16 + ;
: termios.c_cc     17 + ;

\ CONSTANTS {{{
hex
5401 constant TCGETS
5402 constant TCSETS
5403 constant TCSETSW
5404 constant TCSETSF

1 constant IGNBRK   2 constant BRKINT        4 constant IGNPAR
8 constant PARMRK   10 constant INPCK       20 constant ISTRIP
40 constant INLCR   80 constant IGNCR      100 constant ICRNL
200 constant IUCLC  400 constant IXON      800 constant IXANY
1000 constant IXOFF 2000 constant IMAXBEL 4000 constant IUTF8

1 constant OPOST

1 constant ISIG    2 constant ICANON  8 constant ECHO
40 constant ECHONL 8000 constant IEXTEN

30 constant CSIZE  30 constant CS8  100 constant PARENB
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 ." [" ;

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

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

: at-xy ( x y -- )  CSI 1+ (.) say ." ;" 1+ (.) say ." H" ;
: page  CSI ." 2J"  0 0 at-xy ;

60 constant old-termios#
make old-termios old-termios# allot

: restore-termios  old-termios TCSETSF stdin ioctl ;
: backup-termios  old-termios TCGETS stdin ioctl ;
: cooked  restore-termios ;
\ SETTING RAW MODE FLAGS {{{
\ see termios(3)
: raw-iflag ( tios -- )  termios.c_iflag dup @
	IGNBRK BRKINT or PARMRK or ISTRIP or INLCR or IGNCR or ICRNL or IXON or
	negate and swap ! ;
: raw-oflag ( tios -- )  termios.c_oflag dup @ OPOST negate and swap ! ;
: raw-lflag ( tios -- )  termios.c_lflag dup @
	ECHO ECHONL or ICANON or ISIG or IEXTEN or negate and swap ! ;
: raw-cflag ( tios -- )  termios.c_cflag dup @
	CSIZE PARENB or negate and CS8 or swap ! ;
\ }}}
: raw  backup-termios termios dup raw-iflag dup raw-oflag dup raw-lflag
	dup raw-cflag TCSETSF stdin ioctl ;
\ }}}

\ TIME {{{
: nanosleep  35 syscall2 ;

16 constant timespec#
make timespec timespec# allot

: timespec.tv_sec  timespec ;
: timespec.tv_nsec  timespec 8 + ;

: ms>ns ( u -- u' )  1000000 * ;
: ns>ms ( u -- u' )  1000000 / ;
: ms>sec ( u -- ms sec )  1000 /mod ;

: ms ( u -- )  ms>sec timespec.tv_sec ! ms>ns timespec.tv_nsec ! 0 timespec nanosleep errno .errno ;
\ }}}

\ 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