path: root/sanctuary.fs

: \  10 parse 2drop ; immediate \ test \ causes issues if there isn't actually any comment following
: (  [ char ) ] literal parse 2drop ; immediate ( test )

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

: nip  swap drop ;
: tuck  swap over ;

\ todo doc
: 2swap  rot >r rot r> ;

: not  0= ;
\ todo doc
: /  /mod nip ;
: mod  /mod drop ;
: */  */mod nip ;
: negate  0 swap - ;

: <mark  here ;
: <resolve  here 4 + - d, ;
: >mark  here 0 d, ;
: >resolve  dup here swap - 4 - swap d! ;

: begin  <mark ; immediate compile-only
: again  branch <resolve ; immediate compile-only
: until  ?branch <resolve ; immediate compile-only
: if  ?branch >mark ; immediate compile-only
: else  branch >mark swap >resolve ; immediate compile-only
: then  >resolve ; immediate compile-only
: while  ?branch >mark ; immediate compile-only
: repeat  branch swap <resolve >resolve ; immediate compile-only

: ?dup  dup 0<> if dup then ;
: exit  [ hex ] c3 c, [ decimal ] ; immediate compile-only

\ todo doc
: abs  dup 0< if negate then ;

: allot  dp +! ;

: ?find  ?dup if find 0= if 2drop abort then else abort then ;
: 'h  parse-name ?find ;
: '  'h >body ;
: [compile]  ' ( word ) compile, ; immediate compile-only
: [']  ' ( word ) [compile] literal ; immediate compile-only
: ['h]  'h ( word ) [compile] literal ; immediate compile-only \ todo doc
: postpone  'h ( word ) dup immediate? if >body compile,
	else >body [compile] literal ['] compile, compile, then ; immediate compile-only

: cells  8 * ;
: cell+  8 + ;
: cell-  8 - ;
: create  parse-name (header) latest ! ['] (create) compile, 0 , ;
: does>  latest @ >body 2 + ['] (does>) over ! \ replace call loc
	( replace destination ) 11 + r> swap ! ;
	( the lone r> means we don't execute the rest of the word now, )
	( but it is actually compiled into the definition and is jumped to )
	( by a create does> made word )
: constant  create , does> @ ;
: variable  create 1 cells allot ;

: value  parse-name (header) latest ! postpone literal
	[ hex ] c3 c, [ decimal ] ; \ c3 = RET
: to  ' ( word ) 6 +  state @ if postpone literal postpone ! else ! then ; immediate
: +to  ' ( word ) 6 +  state @ if postpone literal postpone +! else +! then ; immediate
: -to  ' ( word ) 6 +  state @ if postpone literal postpone -! else -! then ; immediate

0 constant false
-1 constant true

\ todo doc
: >ffa  ( ht -- a )  cell+ ;
: >nfa  ( ht -- a )  cell+ 1+ ;
: count ( a -- a' u )  dup c@ swap 1+ swap ;

hex
: hijacks  ' ( word ) here >r dp ! ( temporarily set dp so we can use , )
	49 c, bb c, ( xt ) , \ mov r11, xt
	41 c, ff c, e3 c, \ jmp r11
	r> dp ! ;
decimal

: cmove,  dup >r  here swap cmove  r> allot ;
: s"  [ char " ] literal parse ( a u )
	branch >mark >r 2dup cmove, nip  ( u ) ( R: mark )
	r> dup >resolve 4 + ( u a )
	postpone literal ( a ) postpone literal ( u ) ; immediate compile-only
: z"  [ char " ] literal parse ( a u )
	branch >mark >r 2dup cmove, 0 c, nip  ( u ) ( R: mark )
	r> dup >resolve 4 + ( u a )
	postpone literal ( a ) drop ; immediate compile-only
: zstrlen  dup begin dup c@ 0<> while 1+ repeat swap - ;

: s>z,  here -rot cmove, 0 c, ;
\ todo doc
: /string ( a1 u1 n -- a2 u2 )  tuck - >r + r> ;

\ DEFER {{{
\ todo ['] abort → ['] ?defer or something (where ?defer yields an appropriate error)
: defer  parse-name (header) latest !
	['] (defer) compile, ['] abort , ( sic ) ;
: >defer ( ht -- a )  13 + ;
: defer@  >defer @ ;
: defer!  >defer ! ;
: is  state @ if postpone ['] postpone defer! else ' defer! then ; immediate
\ }}}

\ PRIVATISATION AND HIDING {{{
\ maybe i add locals later, implementation may be complex though. this isn't.
\ privatise just loops through words from the start of privatisation
\ to the end and activates the smudge bit on all of them.
\ privatisation yoinked from pforth

: (hide)  cell+ dup c@ 1 or swap c! ;
: (unhide)  cell+ dup c@ 1 invert and swap c! ;
: hide  parse-name ?find (hide) ;

variable private0  variable private$

: private{  latest @ private0 ! ;
: }private  latest @ private$ ! ;
: privatise  private0 @ 0= private$ @ 0= or if abort then
	private$ @
	begin dup private0 @ u> while
	dup (hide) @ ( → next ht ) repeat drop
	0 private0 ! 0 private$ ! ;
\ }}}

\ ERRNO {{{
\ CONSTANTS {{{
-11 constant EAGAIN  -12 constant ENOMEM  -13 constant EACCES
-22 constant EINVAL  -25 constant ENOTTY
\ }}}
\ transform syscall result into [RESULT] IOR output,
\ where IOR is zero on no error and negative on an error (RESULT then being 0)
: >errno  dup 0< if 0 swap else 0 then ;
\ }}}

\ DYNAMIC ALLOCATION (MMAP) {{{
\ MMAP CONSTANTS {{{
hex
\ prot
0 constant PROT_NONE  1 constant PROT_READ  2 constant PROT_WRITE  4 constant PROT_EXEC
\ flags
1 constant MAP_SHARED  2 constant MAP_PRIVATE  3 constant MAP_SHARED_VALIDATE
10 constant MAP_FIXED  20 constant MAP_ANONYMOUS  100 constant MAP_GROWSDOWN
decimal
\ }}}

: mmap  9 syscall6 ;
: munmap  11 syscall2 ;

: allocate ( u -- a e )  >r 0 -1 ( offset fd , unused here )
	MAP_PRIVATE MAP_ANONYMOUS or ( flags )
	PROT_READ PROT_WRITE or ( prot )
	r> 0 ( length addr )
	mmap >errno ;
: free ( a u -- e )  swap munmap ;
: ?allocate  allocate 0< if abort then ;
\ }}}

\ NUMERIC OUTPUT {{{
\ this buffer is also used as a temporary string buffer.
255 constant #pad
create pad 256 cells allot \ 256 because pad is also used by `s>z` which can be at most 255 w/o the null byte
: pad$  pad #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 - ;
\ }}}

\ NONAME {{{
\ will maybe(?) be modified later in the vocabulary section.
false value nonaming

: :noname  here  true to nonaming  postpone ] ;
: ;  [ hex ] c3 c, [ decimal ]
	nonaming not if
		latest @ (unhide)
	then  false to nonaming  postpone [ ; immediate
\ }}}

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

: sys-read  0 syscall3 ;
: sys-write  1 syscall3 ;
: sys-open  2 syscall3 ;
: sys-close  3 syscall1 ;

: type  swap stdout sys-write drop ;
: warn  swap stderr sys-write drop ;
: emit  sp 1 type drop ;
: eemit  sp 1 warn drop ; \ todo doc

: cr  10 emit ;
: ecr  10 eemit ; \ todo doc

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

: open-file  swap >r 0 r> sys-open >errno ;
: close-file  sys-close ;
: read-file  >r swap r> sys-read >errno ;
: write-file  >r swap r> sys-write >errno ;

\ all of this is super ugly
\ probably just redo this all and use a static number of buffers

-2 constant init-source
-1 constant string-source
init-source value source-id

\ syntax highlighting cannot handle this. oops,,
: ."  postpone s" postpone type ; immediate compile-only \ "

: e."  postpone s" postpone warn ; immediate compile-only \ "
: (abort") ( a u -- )   warn ecr abort ;
: abort"  postpone s" postpone (abort") ; immediate compile-only

\ ERROR MESSAGES {{{
\ stk under/overflow ones need to clear the stack first
\ feels wrong but i think its correct
:noname  e." word not found" ecr abort ; is ?notfound?
:noname  e." compile-only word used in interpret mode" ecr abort ; is ?componly?
:noname  sp-reset e." stack overflow" ecr abort ; is ?overflow?
:noname  sp-reset e." stack underflow" ecr abort ; is ?underflow?
\ }}}

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

\ NUMERIC OUTPUT {{{
\ todo doc
: (u.)  <# #s #> ;
: u.  (u.) type space ;
: u.r  >r (u.) r> over - spaces type ;

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

\ if you need more than 16 layers of included files: go away™
\ todo doc
16 constant #buffers
0 value include-depth
8192 constant /buffer
2048 constant /line-buffer

\ this bit is so large that i may increase the default brk
create buffers		/buffer #buffers * allot
create buffers-used	#buffers cells allot
create buffers->in	#buffers cells allot
create buffers-fd	#buffers cells allot

create line-buffers		/line-buffer #buffers * allot
create line-buffers-used	#buffers cells allot
create line-buffers->in		#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 + ;

: cline  include-depth /line-buffer * line-buffers + ;
: cline-used  include-depth cells line-buffers-used + ;
: cline->in  include-depth cells line-buffers->in + ;

: refill-buffer ( -- u | 0 )  cbuffer /buffer cbuffer-fd @ read-file
	0<> if drop 0 then
	0 cbuffer->in !  dup cbuffer-used ! ;
: cbuffer-empty?  cbuffer->in @ cbuffer-used @ >= ;
: bufkey ( -- c | -1 )
	cbuffer-empty? if
		refill-buffer 0= if -1 exit then
	then
	cbuffer cbuffer->in @ + c@
	cbuffer->in @ 1+ cbuffer->in ! ;

private{
0 value #read
0 value #read-limit
0 value destination-base
: finish-accept ( -- u )  #read ;
}private
\ uses memory for readability, maybe too slow?
\ need to test to see.
: accept ( a u -- u )  0 to #read  to #read-limit  to destination-base
	begin
		#read #read-limit <
	while
		bufkey dup 0>=  over 10 <>  and if
			destination-base #read + c!
			1 +to #read
		else
			drop finish-accept exit
		then
	repeat
	finish-accept ( only reached when buffer limit reached ) ;
privatise

\ note: these are completely different from ans forth's words of the same name
\ todo check source-id
: save-input  #tib @ cline-used !  >in @ cline->in ! ;
: restore-input  cline-used @ #tib !  cline->in @ >in !  cline tib ! ;

: refill ( -- ? )  source-id 0< if false exit then
	0 >in !  cline tib !
	cline /line-buffer accept
	dup cline-used !
	dup #tib !
	0<> if true else false then ;

\ todo reset RSP
: quit  0 to source-id  postpone [
	begin refill while interpret ."  ok" cr repeat ;

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

: s>z  dup #pad >= if abort" string too large for pad" then
	>r pad r@ ( a pad u ) cmove
	r> ( u ) pad + 0 swap c! pad ;

: ?include-depth  include-depth #buffers >= if
		0 to include-depth  abort" too many input buffers" then ;
: include-file ( fd -- )  source-id >r  ( fd ) dup to source-id
	1 +to include-depth ?include-depth
	0 cbuffer-used !  0 cbuffer->in !  ( fd ) cbuffer-fd !
	begin refill while interpret repeat
	1 -to include-depth  r> to source-id ;
: included ( a u -- )  s>z r/o open-file 0= if
		dup >r include-file
		r> close-file
	else
		drop abort" file open for include failed"
	then ;
: include ( "path" -- )  parse-name included ;
\ }}}

\ DO LOOP {{{
\ todo doc
: do ( comp: -- mark f )
	postpone swap postpone >r postpone >r  <mark false ; immediate compile-only
: ?do ( comp: ?domark mark t ) postpone 2dup postpone <> ?branch >mark
	postpone swap postpone >r postpone >r  <mark true ; immediate compile-only
: +loop  ( ? ) >r
	postpone r> postpone + postpone r@
	postpone over postpone >r ( n+i lim , R: lim n+i )
	postpone >=
	?branch <resolve
	postpone rdrop postpone rdrop
	r> ( ?domark t | f -- ) true = if
		>resolve
	then ; immediate compile-only
\ todo -loop
: loop  ( ? ) >r
	postpone r> postpone 1+ postpone r@
	postpone over postpone >r ( n+i lim , R: lim n+i )
	postpone >=
	?branch <resolve
	postpone rdrop postpone rdrop
	r> ( ?domark t | f -- ) true = if
		>resolve
	then ; immediate compile-only
: i  rp cell+ @ ;
: leave  postpone rdrop postpone r@ postpone >r ; immediate compile-only
: unloop  postpone rdrop postpone rdrop ; immediate compile-only
\ }}}

\ todo doc
\ VOCABULARY {{{
\ todo doc
\ based on the forth standard word list reference implementations
\ words in asm that use latest directly:
\ the easiest (altho kind of ugly) way i'll probably do this
\ is to just redefine all of these here
\ we don't need to redo ; because we already did it above
32 constant #vocs \ #context better name ?
variable #order
create context #vocs cells allot
variable current

: wordlist  here 0 , ;
wordlist constant forth-wordlist

defer default-wordlist
:noname  forth-wordlist 1 ; is default-wordlist

\ the most recent is stored toward high memory
: get-order ( -- widn ... wid1 n )
	#order @ 0 ?do
		#order @ i -
		1- cells
		context + @
	loop
	#order @ ;
: set-order ( widn ... wid1 n -- )
	dup 1 < if
		drop default-wordlist
	then
	dup #order !
	0 ?do
		i cells context + !
	loop ;

: (vocabulary)  create , does>
	>r get-order swap drop r> swap set-order ;
: vocabulary  wordlist (vocabulary) ;

: get-current ( -- wid )  current @ ;
: set-current ( wid -- )  current ! ;

: discard ( x1 xn u -- )  0 ?do drop loop ;
: definitions  get-order swap set-current discard ;
: previous  get-order nip 1- set-order ;
: only  -1 set-order ;
: also  get-order over swap 1+ set-order ;

forth-wordlist (vocabulary) forth
-1 set-order

: search-wordlist ( a u wid -- 0 | ht -1 )
	( wid ) @  begin ( a u ht )
		>r 2dup r@ ( a u a u ht ; backup str for next loop )
		>nfa count ( a1 u1 a2 u2 )
		compare 0= if
			2drop ( drop backup )
			r> -1 exit
		then
		r> @ ?dup 0=
	until
	2drop 0 ;

\ find (header) : ; smudge immediate compile-only

: (find) ( a u -- a u 0 | ht -1 )
	#order @ 0 ?do
		2dup i cells context + @ ( a u a u wid )
		search-wordlist ( a u 0 | a u ht -1 )
		?dup if
			>r >r 2drop r> r> ( ht -1 )
			unloop exit
		then
	loop 0 ;

: (smudge)  latest @ >ffa dup c@ [ hex ] 01 [ decimal ] xor swap c! ;
: (immediate)  latest @ >ffa dup c@ [ hex ] 02 [ decimal ] or swap c! ;
: (compile-only)  latest @ >ffa dup c@ [ hex ] 04 [ decimal ] or swap c! ;

: ((header))  here >r
	latest @ ,
	0 c, dup c,
	cmove,
	r> ;
: (:)  parse-name (header)  latest !  smudge  postpone ] ;

: (latest) ( -- a )  get-current ;
\ the actual setup is in a compiled word to prevent
\ the system from shitfucking itself when its only halfway done setting up
:noname  [ latest @ ] literal forth-wordlist !
	forth-wordlist set-current
	['] (find) is find
	['] (smudge) is smudge
	['] (immediate) is immediate
	['] (compile-only) is compile-only
	['] ((header)) is (header)
	['] (:) is :
	['] (latest) is latest ;
execute
\ drop
\ }}}

\ PROGRAMMING TOOLS {{{
\ should write top of stack on right
\ : .s  ;
\ gonna need to be rewritten when/if i add vocabulary/wordlist support
\ : words  ;
\ }}}

\ todo doc
0 constant version
: welcome  ." sanctuary: a 64 bit forth for linux, version " version u. cr ;

:noname  quit ; handler !
welcome quit bye