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 ;

: not  0= ;

: <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 \ todo doc

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

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 - ;
\ todo s>z becomes s>z, s>z writes to pad (will then need to be moved below pno)
: s>z  here -rot cmove, 0 c, ;

\ DEFER {{{
\ todo doc
\ : defer  create ['] abort , does> @ execute ;
\ : create  parse-name (header) latest ! ['] (create) compile, 0 , ;
\ : does>  latest @ >body 2 + ['] (does>) over ! \ replace call loc
\ 	( replace destination ) 11 + r> swap ! ;
\ 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! ; \ todo doc
: 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 ;

\ todo doc
: 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 255 cells allot
: 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.
\ todo doc
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-write  0 syscall3 ;
: sys-read  1 syscall3 ;
: sys-open  2 syscall3 ;
: sys-close  3 syscall1 ;

: type  swap stdout sys-read drop ;
: emit  sp 1 type drop ;

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

: ."  ; \ todo doc

\ OLD VERSION I GAVE UP ON BECAUSE IT'S TOO COMPLICATED AND SUCKS SHIT {{{
\ 8192 constant /buffer
\ 5 constant /buffer-header
\ /buffer /buffer-header - constant /buffer-buffer
\ create base-buffer /buffer allot \ stdin input buffer
\ variable latest-buffer
\
\ \ format: LINK LINEBUF-PTR >IN USED FD [BUFFER (8152B)]
\ : buf>line  cell+ ;
\ : buf>in  2 cells + ;
\ : buf>used  3 cells + ;
\ : buf>fd  4 cells + ;
\ : buf>buf  5 cells + ;
\
\ 4096 constant /linebuf
\ 2 constant /linebuf-header
\ /linebuf /linebuf-header - constant /linebuf-buffer
\ create base-linebuffer /linebuf allot
\ \ format  >IN USED
\ : linebuf>used  cell+ ;
\ : linebuf>buf  2 cells + ;
\
\ base-linebuffer  base-buffer buf>line  !
\ base-buffer latest-buffer !
\
\ \ todo doc
\ : create-linebuffer ( buf-a -- )  dup /linebuf ?allocate swap buf>line ! ;
\
\ \ SEGFAULT HERE
\ : refill-buffer ( a -- u | 0 )  dup >r dup buf>fd @ swap ( fd a )
\ 	dup buf>in 0 swap !  dup buf>used 0 swap !
\ 	buf>buf swap >r /buffer-buffer r> read-file ( u e ) drop
\ 	r> ( u a ) buf>used ! ;
\ : create-buffer ( fd -- something? )  /buffer ?allocate ( fd a )
\ 	dup latest-buffer @ swap !  dup buf>fd rot swap !
\ 	dup refill-buffer 0= if abort then
\ 	dup create-linebuffer
\ 	latest-buffer ! ;
\ : free-buffer ( a -- )  dup @ >r
\ 	dup buf>line @ free free
\ 	r> latest-buffer ! ;
\
\ : cbuffer->in  latest-buffer @ buf>in ;
\ : cbuffer-used  latest-buffer @ buf>used ;
\ : cbuffer-fd  latest-buffer @ buf>fd ;
\ : cbuffer-line  latest-buffer @ buf>line ;
\ : cbuffer-linebuf  latest-buffer @ buf>line @ linebuf>buf ;
\
\ : cbuffer-empty?  cbuffer->in @ cbuffer-used @ >= ;
\
\ : bufkey ( -- c | -1 )
\ 	cbuffer-empty? if
\ 		latest-buffer @ refill-buffer 0= if -1 exit then
\ 	then
\ 	latest-buffer @ 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 <>  or if
\ 			destination-base #read + c!
\ 			1 +to #read
\ 		else
\ 			drop finish-accept exit
\ 		then
\ 	repeat
\ 	finish-accept ( only reached when buffer limit reached ) ;
\ privatise
\
\ \ : _  s" stack underflow" type abort ; ' _ is !underflow
\ \ : _  s" stack overflow"  type abort ; ' _ is !overflow
\ \ : _  s" word not found"  type abort ; ' _ is !notfound
\
\ : refill  source-id 0< if false exit then
\ 	0 >in !  cbuffer-linebuf tib !  cbuffer-linebuf /linebuf-buffer accept
\ 	dup #tib ! dup 0= if true else false then ;
\
\ : quit  0 to source-id  [compile] [  begin refill while interpret repeat ;
\ }}}
\ }}}

\ \ VOCABULARY {{{
\ do this after user input and stuff is Working
\ 32 constant #vocs
\ variable #order
\ create context #vocs cells allot
\ \ }}}

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