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

\ todo doc
: case  0 ; immediate
: of  postpone over postpone = postpone if postpone drop ; immediate
: endof  postpone else ; immediate
: endcase  postpone drop  begin ?dup while postpone then repeat ; immediate

\ todo doc
: recurse latest @ >body compile, ; immediate

: cells  8 * ;
: cell+  8 + ;
: cell-  8 - ;
\ todo doc
: chars  ;
: char+  1+ ;
: char-  1- ;

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

\ todo doc
: depth  sp0 @ sp - cell- 8 / ;

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

\ todo doc
: source ( -- a u )  cline cline-used @ ;

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
		cbuffer-used @ 0= if false else true then
	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 drop
	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
\ }}}

\ 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

hex b16b0065cafebabe constant empty-voc-magic decimal
: empty-wordlist? ( wid -- ? )  @ cell- @ empty-voc-magic = ;

: wordlist  empty-voc-magic , here 0 , ;

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

\ Bad Thing: using one of these words on their own
\ will make it the only vocabulary which breaks things
\ maybe vocabulary should perform `also`?
: (vocabulary)  create , does>
	>r get-order swap drop r> swap set-order ;
: vocabulary  wordlist (vocabulary) ;

vocabulary forth
' forth 21 + constant forth-wordlist \ hack; depends on create
:noname  forth-wordlist 1 ; is default-wordlist

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

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

-1 set-order

: visible? ( ht -- ? )  >ffa c@ 1 and 0= ;

: search-wordlist ( a u wid -- 0 | ht -1 )
	dup empty-wordlist? if drop 2drop 0 exit then
	( 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
			r@ visible? if
				2drop ( drop backup )
				r> -1 exit
			then
		then
		r> @ ?dup 0=
	until
	2drop 0 ;

private{
: (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 ; )
	\ prevent having Nothing in the dictionary
	\ should do something in `vocabulary` to fix this really
	2dup forth-wordlist search-wordlist dup 0<> if
		>r >r 2drop r> r> exit
	then ;

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

: place-latest  get-current empty-wordlist? if 0 else latest @ then , ;

: ((header))  here >r
	place-latest
	0 c, dup c,
	cmove,
	r> ;

: (:)  parse-name (header)  latest !  smudge  postpone ] ;

: (latest) ( -- a )  get-current ;
}private
\ 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
privatise
\ }}}

\ TEST SUITE {{{
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ modified tho:
\ - put into lowercase
\ - { } → t{ }t

hex

\ set the following flag to true for more verbose output; this may
\ allow you to tell which test caused your system to hang.
variable verbose
   false verbose !

: empty-stack	\ ( ... -- ) empty stack: handles underflowed stack too.
   depth ?dup if dup 0< if negate 0 do 0 loop else 0 do drop loop then then ;

: error		\ ( c-addr u -- ) display an error message followed by
		\ the line that had the error.
   type source type cr			\ display line corresponding to error
   empty-stack				\ throw away every thing else
;

variable actual-depth			\ stack record
create actual-results 20 cells allot

: t{		\ ( -- ) syntactic sugar.
   ;

: ->		\ ( ... -- ) record depth and content of stack.
   depth dup actual-depth !		\ record depth
   ?dup if				\ if there is something on stack
      0 do actual-results i cells + ! loop \ save them
   then ;

: }t		\ ( ... -- ) compare stack (expected) contents with saved
		\ (actual) contents.
   depth actual-depth @ = if		\ if depths match
      depth ?dup if			\ if there is something on the stack
         0 do				\ for each stack item
	    actual-results i cells + @	\ compare actual with expected
	    <> if s" incorrect result: " error leave then
	 loop
      then
   else					\ depth mismatch
      s" wrong number of results: " error
   then ;

: testing	\ ( -- ) talking comment.
   source verbose @
   if dup >r type cr r> >in !
   else >in ! drop
   then ;

decimal
\ }}}

\ TOOLS {{{
\ write top of stack on right (as stack notation does)
: .s  sp >r
	sp0 @ cell-  begin
		dup r@ >=
	while
		dup @ .
		cell-
	repeat
	rdrop drop ;

: vlist ( wid -- ) dup empty-wordlist? if drop exit then
	@  begin ( ht )
		dup visible? if
			dup >nfa count type space
		then @ ?dup 0=
	until cr ;
\ doesn't work when there are multiple vocabularies,
\ for some reason the header of the last word is printed
: words  get-order 0 ?do vlist loop ;

: bytes-allocated  dp$ @ dp0 @ - ;
: bytes-used  here dp0 @ - ;
: bytes-free  bytes-allocated bytes-used - ;

\ }}}

\ TERMINAL CONTROL {{{
\ todo doc
vocabulary terminal
also terminal definitions

60 constant termios#
create termios termios# allot
create old-termios termios# allot

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

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

: ESC  27 emit ;
: CSI  ESC ." [" ;

: CSIm ( n -- )  CSI (.) type ." 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+ (.) type ." ;" 1+ (.) type ." H" ;
: page  CSI ." 2J"  0 0 at-xy ;

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

: altscr  CSI ." ?1049h" ;
: normscr  CSI ." ?1049l" ;

previous definitions
\ }}}

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

:noname  quit ; handler !
welcome quit bye