Hiding more words.

This commit is contained in:
Brad Nelson
2021-02-06 16:29:16 -08:00
parent f28d0a4c0c
commit 1921f3c736
8 changed files with 38 additions and 8 deletions

View File

@ -1,14 +1,21 @@
( Block Files )
internals definitions
: clobber-line ( a -- a' ) dup 63 bl fill 63 + nl over c! 1+ ;
: clobber ( a -- ) 15 for clobber-line next drop ;
forth definitions internals
-1 value block-fid variable scr -1 value block-id 0 value block-dirty
create block-data 1024 allot
: open-blocks ( a n -- )
block-fid 0< 0= if block-fid close-file throw -1 to block-fid then
2dup r/w open-file if drop r/w create-file throw else nip nip then to block-fid ;
: use ( "name" -- ) bl parse open-blocks ;
internals definitions
: common-default-use s" blocks.fb" open-blocks ;
defer default-use ' common-default-use is default-use
: use?! block-fid 0< if default-use then ;
: grow-blocks ( n -- ) 1024 * block-fid file-size throw max block-fid resize-file throw ;
forth definitions internals
: save-buffers
block-dirty if
block-id grow-blocks block-id 1024 * block-fid reposition-file throw
@ -16,8 +23,6 @@ defer default-use ' common-default-use is default-use
block-fid flush-file throw
0 to block-dirty
then ;
: clobber-line ( a -- a' ) dup 63 bl fill 63 + nl over c! 1+ ;
: clobber ( a -- ) 15 for clobber-line next drop ;
: block ( n -- a ) use?! dup block-id = if drop block-data exit then
save-buffers dup grow-blocks
dup 1024 * block-fid reposition-file throw
@ -38,9 +43,12 @@ defer default-use ' common-default-use is default-use
: list ( n -- ) scr ! ." Block " scr @ . cr scr @ block
15 for dup 63 type [char] | emit space 15 r@ - . cr 64 + next drop ;
: l scr @ list ; : n 1 scr +! l ; : p -1 scr +! l ;
internals definitions
: @line ( n -- ) 64 * scr @ block + ;
: e' ( n -- ) @line clobber-line drop update ;
: wipe 15 for r@ e' next l ; : e e' l ;
forth definitions internals
: d ( n -- ) dup 1+ @line swap @line 15 @line over - cmove 15 e ;
: r ( n "line" -- ) 0 parse 64 min rot dup e @line swap cmove l ;
: a ( n "line" -- ) dup @line over 1+ @line 16 @line over - cmove> r ;
forth definitions

View File

@ -1,5 +1,7 @@
( Byte Stream / Ring Buffer )
vocabulary streams streams definitions
: stream ( n "name" ) create 1+ dup , 0 , 0 , allot align ;
: >write ( st -- wr ) cell+ ; : >read ( st -- rd ) 2 cells + ;
: >offset ( n st -- a ) 3 cells + + ;
@ -21,3 +23,5 @@
: stream> ( a n st -- )
begin over 1 > over empty? 0= and while
dup stream>ch >r rot dup r> swap c! 1+ rot 1- rot repeat 2drop 0 swap c! ;
forth definitions

View File

@ -1,13 +1,17 @@
( Cooperative Tasks )
vocabulary tasks tasks definitions
variable task-list
forth definitions tasks
: task ( xt rsz dsz "name" )
create here >r 0 , 0 , 0 ,
here cell+ r@ cell+ ! cells allot
here r@ 2 cells + ! cells allot
dup 0= if drop else >body r@ 2 cells + @ ! then rdrop ;
variable task-list
: start-task ( t -- )
task-list @ if
task-list @ @ over !
@ -26,4 +30,6 @@ variable task-list
task-list @ 2 cells + @ rp!
;
tasks definitions
0 0 0 task main-task main-task start-task
forth definitions

View File

@ -31,4 +31,8 @@ transfer digit
transfer $@
transfer see.
transfer see-loop
transfer >name-length
transfer call0 transfer call1 transfer call2 transfer call3 transfer call4
transfer call5 transfer call6 transfer call7 transfer call8 transfer call9
transfer call10
forth definitions

View File

@ -1,3 +1,6 @@
( Include first argument if any )
internals definitions
: optional-args argc 2 < if exit then 1 argv included ;
optional-args
' optional-args
forth definitions
execute

View File

@ -4,10 +4,12 @@ vocabulary posix posix definitions
1 constant RTLD_LAZY
2 constant RTLD_NOW
0 z" dlopen" dlsym constant 'dlopen
: dlopen ( z n -- a ) 'dlopen call2 ;
: dlopen ( z n -- a ) 'dlopen [ internals ] call2 [ posix ] ;
create calls
internals
' call0 , ' call1 , ' call2 , ' call3 , ' call4 , ' call5 ,
' call6 , ' call7 , ' call8 , ' call9 , ' call10 ,
posix
: sofunc ( z n a "name" -- )
swap >r swap dlsym dup 0= throw create , r> cells calls + @ ,
does> dup @ swap cell+ @ execute ;

View File

@ -1,10 +1,11 @@
( Arguments )
internals
internals definitions
: 'argc ( -- a ) 'sys 9 cells + ;
: 'argv ( -- a ) 'sys 10 cells + ;
forth
forth definitions internals
: argc ( -- n ) 'argc @ ;
: argv ( n -- a n ) cells 'argv @ + @ z>s ;
( Load Libraries )
: xlib s" posix/xlib_test.fs" included ;
forth

View File

@ -2,8 +2,10 @@ vocabulary windows windows definitions
( DLL Handling )
create calls
internals
' call0 , ' call1 , ' call2 , ' call3 , ' call4 , ' call5 ,
' call6 , ' call7 , ' call8 , ' call9 , ' call10 ,
windows
: sofunc ( z n a "name" -- )
swap >r swap GetProcAddress dup 0= throw create , r> cells calls + @ ,
does> dup @ swap cell+ @ execute ;