Hiding more words.
This commit is contained in:
@ -1,14 +1,21 @@
|
|||||||
( Block Files )
|
( 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
|
-1 value block-fid variable scr -1 value block-id 0 value block-dirty
|
||||||
create block-data 1024 allot
|
create block-data 1024 allot
|
||||||
: open-blocks ( a n -- )
|
: open-blocks ( a n -- )
|
||||||
block-fid 0< 0= if block-fid close-file throw -1 to block-fid then
|
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 ;
|
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 ;
|
: use ( "name" -- ) bl parse open-blocks ;
|
||||||
|
internals definitions
|
||||||
: common-default-use s" blocks.fb" open-blocks ;
|
: common-default-use s" blocks.fb" open-blocks ;
|
||||||
defer default-use ' common-default-use is default-use
|
defer default-use ' common-default-use is default-use
|
||||||
: use?! block-fid 0< if default-use then ;
|
: use?! block-fid 0< if default-use then ;
|
||||||
: grow-blocks ( n -- ) 1024 * block-fid file-size throw max block-fid resize-file throw ;
|
: grow-blocks ( n -- ) 1024 * block-fid file-size throw max block-fid resize-file throw ;
|
||||||
|
forth definitions internals
|
||||||
: save-buffers
|
: save-buffers
|
||||||
block-dirty if
|
block-dirty if
|
||||||
block-id grow-blocks block-id 1024 * block-fid reposition-file throw
|
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
|
block-fid flush-file throw
|
||||||
0 to block-dirty
|
0 to block-dirty
|
||||||
then ;
|
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
|
: block ( n -- a ) use?! dup block-id = if drop block-data exit then
|
||||||
save-buffers dup grow-blocks
|
save-buffers dup grow-blocks
|
||||||
dup 1024 * block-fid reposition-file throw
|
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
|
: list ( n -- ) scr ! ." Block " scr @ . cr scr @ block
|
||||||
15 for dup 63 type [char] | emit space 15 r@ - . cr 64 + next drop ;
|
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 ;
|
: l scr @ list ; : n 1 scr +! l ; : p -1 scr +! l ;
|
||||||
|
internals definitions
|
||||||
: @line ( n -- ) 64 * scr @ block + ;
|
: @line ( n -- ) 64 * scr @ block + ;
|
||||||
: e' ( n -- ) @line clobber-line drop update ;
|
: e' ( n -- ) @line clobber-line drop update ;
|
||||||
: wipe 15 for r@ e' next l ; : e e' l ;
|
: 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 ;
|
: 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 ;
|
: 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 ;
|
: a ( n "line" -- ) dup @line over 1+ @line 16 @line over - cmove> r ;
|
||||||
|
forth definitions
|
||||||
|
|||||||
@ -1,5 +1,7 @@
|
|||||||
( Byte Stream / Ring Buffer )
|
( Byte Stream / Ring Buffer )
|
||||||
|
|
||||||
|
vocabulary streams streams definitions
|
||||||
|
|
||||||
: stream ( n "name" ) create 1+ dup , 0 , 0 , allot align ;
|
: stream ( n "name" ) create 1+ dup , 0 , 0 , allot align ;
|
||||||
: >write ( st -- wr ) cell+ ; : >read ( st -- rd ) 2 cells + ;
|
: >write ( st -- wr ) cell+ ; : >read ( st -- rd ) 2 cells + ;
|
||||||
: >offset ( n st -- a ) 3 cells + + ;
|
: >offset ( n st -- a ) 3 cells + + ;
|
||||||
@ -21,3 +23,5 @@
|
|||||||
: stream> ( a n st -- )
|
: stream> ( a n st -- )
|
||||||
begin over 1 > over empty? 0= and while
|
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! ;
|
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 )
|
( Cooperative Tasks )
|
||||||
|
|
||||||
|
vocabulary tasks tasks definitions
|
||||||
|
|
||||||
|
variable task-list
|
||||||
|
|
||||||
|
forth definitions tasks
|
||||||
|
|
||||||
: task ( xt rsz dsz "name" )
|
: task ( xt rsz dsz "name" )
|
||||||
create here >r 0 , 0 , 0 ,
|
create here >r 0 , 0 , 0 ,
|
||||||
here cell+ r@ cell+ ! cells allot
|
here cell+ r@ cell+ ! cells allot
|
||||||
here r@ 2 cells + ! cells allot
|
here r@ 2 cells + ! cells allot
|
||||||
dup 0= if drop else >body r@ 2 cells + @ ! then rdrop ;
|
dup 0= if drop else >body r@ 2 cells + @ ! then rdrop ;
|
||||||
|
|
||||||
variable task-list
|
|
||||||
|
|
||||||
: start-task ( t -- )
|
: start-task ( t -- )
|
||||||
task-list @ if
|
task-list @ if
|
||||||
task-list @ @ over !
|
task-list @ @ over !
|
||||||
@ -26,4 +30,6 @@ variable task-list
|
|||||||
task-list @ 2 cells + @ rp!
|
task-list @ 2 cells + @ rp!
|
||||||
;
|
;
|
||||||
|
|
||||||
|
tasks definitions
|
||||||
0 0 0 task main-task main-task start-task
|
0 0 0 task main-task main-task start-task
|
||||||
|
forth definitions
|
||||||
|
|||||||
@ -31,4 +31,8 @@ transfer digit
|
|||||||
transfer $@
|
transfer $@
|
||||||
transfer see.
|
transfer see.
|
||||||
transfer see-loop
|
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
|
forth definitions
|
||||||
|
|||||||
@ -1,3 +1,6 @@
|
|||||||
( Include first argument if any )
|
( Include first argument if any )
|
||||||
|
internals definitions
|
||||||
: optional-args argc 2 < if exit then 1 argv included ;
|
: 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
|
1 constant RTLD_LAZY
|
||||||
2 constant RTLD_NOW
|
2 constant RTLD_NOW
|
||||||
0 z" dlopen" dlsym constant 'dlopen
|
0 z" dlopen" dlsym constant 'dlopen
|
||||||
: dlopen ( z n -- a ) 'dlopen call2 ;
|
: dlopen ( z n -- a ) 'dlopen [ internals ] call2 [ posix ] ;
|
||||||
create calls
|
create calls
|
||||||
|
internals
|
||||||
' call0 , ' call1 , ' call2 , ' call3 , ' call4 , ' call5 ,
|
' call0 , ' call1 , ' call2 , ' call3 , ' call4 , ' call5 ,
|
||||||
' call6 , ' call7 , ' call8 , ' call9 , ' call10 ,
|
' call6 , ' call7 , ' call8 , ' call9 , ' call10 ,
|
||||||
|
posix
|
||||||
: sofunc ( z n a "name" -- )
|
: sofunc ( z n a "name" -- )
|
||||||
swap >r swap dlsym dup 0= throw create , r> cells calls + @ ,
|
swap >r swap dlsym dup 0= throw create , r> cells calls + @ ,
|
||||||
does> dup @ swap cell+ @ execute ;
|
does> dup @ swap cell+ @ execute ;
|
||||||
|
|||||||
@ -1,10 +1,11 @@
|
|||||||
( Arguments )
|
( Arguments )
|
||||||
internals
|
internals definitions
|
||||||
: 'argc ( -- a ) 'sys 9 cells + ;
|
: 'argc ( -- a ) 'sys 9 cells + ;
|
||||||
: 'argv ( -- a ) 'sys 10 cells + ;
|
: 'argv ( -- a ) 'sys 10 cells + ;
|
||||||
forth
|
forth definitions internals
|
||||||
: argc ( -- n ) 'argc @ ;
|
: argc ( -- n ) 'argc @ ;
|
||||||
: argv ( n -- a n ) cells 'argv @ + @ z>s ;
|
: argv ( n -- a n ) cells 'argv @ + @ z>s ;
|
||||||
|
|
||||||
( Load Libraries )
|
( Load Libraries )
|
||||||
: xlib s" posix/xlib_test.fs" included ;
|
: xlib s" posix/xlib_test.fs" included ;
|
||||||
|
forth
|
||||||
|
|||||||
@ -2,8 +2,10 @@ vocabulary windows windows definitions
|
|||||||
|
|
||||||
( DLL Handling )
|
( DLL Handling )
|
||||||
create calls
|
create calls
|
||||||
|
internals
|
||||||
' call0 , ' call1 , ' call2 , ' call3 , ' call4 , ' call5 ,
|
' call0 , ' call1 , ' call2 , ' call3 , ' call4 , ' call5 ,
|
||||||
' call6 , ' call7 , ' call8 , ' call9 , ' call10 ,
|
' call6 , ' call7 , ' call8 , ' call9 , ' call10 ,
|
||||||
|
windows
|
||||||
: sofunc ( z n a "name" -- )
|
: sofunc ( z n a "name" -- )
|
||||||
swap >r swap GetProcAddress dup 0= throw create , r> cells calls + @ ,
|
swap >r swap GetProcAddress dup 0= throw create , r> cells calls + @ ,
|
||||||
does> dup @ swap cell+ @ execute ;
|
does> dup @ swap cell+ @ execute ;
|
||||||
|
|||||||
Reference in New Issue
Block a user