Hiding more words.
This commit is contained in:
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ;
|
||||
|
||||
Reference in New Issue
Block a user