commit cf9f756395a197cbe3664ff744c0d186c176e44b
parent 5d674083b30bf2bd80268ff855714e33615f3d5c
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 12 Jun 2023 14:43:19 -0400
Add pushret, and popret, in all kernels
This allows us to use bootlo.fs directly in rpi port.
Diffstat:
6 files changed, 16 insertions(+), 490 deletions(-)
diff --git a/fs/doc/hal.txt b/fs/doc/hal.txt
@@ -208,9 +208,6 @@ This means that if you create such a word and that this word calls another word,
it needs to call "pushret," as a prelude and to call "popret," before it
returns. Leaf words don't need to do that, which makes them faster.
-NOTE: the ARM port is currently being written, so pushret, and popret, hasn't
-been added everywhere it needs to yet.
-
## Low HAL
Operand words:
diff --git a/fs/xcomp/arm/rpi/build.fs b/fs/xcomp/arm/rpi/build.fs
@@ -13,7 +13,7 @@ org value kernel
: spitBoot ( iohdl -- ) >r \ V1=iohdl
." Putting kernel in place\n"
kernel kernellen V1 IO :write
- S" /xcomp/rpiboot.fs" V1 spitfile
+ S" /xcomp/bootlo.fs" V1 spitfile
S" /drv/rpi/uart.fs" V1 spitfile
S" /xcomp/arm/rpi/glue.fs" V1 spitfile
r> IO :flush ;
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -1,4 +1,4 @@
-code : ] code ] ;
+code : pushret, ] code pushret, ] ;
code noop exit,
code dup dup, exit,
: swap, PSP) @!, ; code swap swap, exit,
@@ -91,7 +91,7 @@ Z) _ = NZ) _ <> >) _ < <) _ > >=) _ <= <=) _ >=
: \ begin in< $20 < until ; immediate
\ hello, this is a comment!
-: exit exit, ; immediate
+: exit popret, exit, ; immediate
: ( begin
word dup c@ 1 = if
1+ c@ ')' = if exit then else drop then
@@ -120,8 +120,8 @@ code neg -W, exit,
: r@ dup, RSP) @, ; immediate
: r> [compile] r@ [compile] rdrop ; immediate
: >r [compile] r! drop, ; immediate
-code scnt dup, PSP) addr, ] PSTOP -^ >> >> 1- ;
-code rcnt dup, RSP) addr, ] RSTOP -^ >> >> ;
+code scnt pushret, dup, PSP) addr, ] PSTOP -^ >> >> 1- ;
+code rcnt pushret, dup, RSP) addr, ] RSTOP -^ >> >> ;
: while [compile] if swap ; immediate
: repeat [compile] again [compile] then ; immediate
@@ -133,8 +133,8 @@ code rcnt dup, RSP) addr, ] RSTOP -^ >> >> ;
?dup if begin [compile] then ?dup not until then [compile] rdrop ; immediate
\ Local variables + beginning of compiling words
-code (cell) r> exit,
-: create code compile (cell) ;
+code (cell) pushret, r> popret, exit,
+: create code pushret, compile (cell) ;
: const code litn exit, ;
4 const CELLSZ
@@ -152,8 +152,8 @@ create toptrdef ' @ , ' _@, ,
\ Compiling words
create _ 0 ,
-code (does) r> W>A, W) @, W<>A, CELLSZ W+n, branchA,
-: doer code compile (does) HERE @ _ ! CELLSZ allot ;
+code (does) pushret, r> W>A, W) @, W<>A, CELLSZ W+n, branchA,
+: doer code pushret, compile (does) HERE @ _ ! CELLSZ allot ;
: does> r> ( exit current definition ) _ @ ! ;
: does' ( w -- 'data ) DOESSZ + ;
@@ -195,7 +195,7 @@ alias @ llnext
: metaadd ( id entry -- ) 'emeta lladd drop , ;
: realias ( 'new 'tgt -- ) to@! here swap branch, drop to here ;
-: :realias ' sysdict curword entry here swap realias ] ;
+: :realias ' sysdict curword entry here swap realias pushret, ] ;
: _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ;
: chain ( w1 w2 -- w )
_ swap _ tuck over and? if
@@ -227,7 +227,7 @@ alias execute | immediate
:iterator for ( n -- ) [
1 W+n, RSP) 4 +) !, drop, ahead
begin yield swap then -1 RSP) 4 +) [+n], NZ) branchC, drop
- unyield exit,
+ unyield popret, exit,
:iterator for2 ( lo hi -- )
to j to i i j < if begin yield to1+ i i j >= until then unyield ;
diff --git a/fs/xcomp/i386/kernel.fs b/fs/xcomp/i386/kernel.fs
@@ -140,6 +140,9 @@ xcode 32b) ( operand -- operand )
ax $100 i) or, ax $fffdffff i) and, ret,
\ Write routines
+xcode pushret, ret,
+xcode popret, ret,
+
pc to lblcallwr \ bx=abs addr
$e8 i) cwrite,
pc to lblrelwr \ bx=abs addr
diff --git a/fs/xcomp/rpiboot.fs b/fs/xcomp/rpiboot.fs
@@ -1,476 +0,0 @@
-code : pushret, ] code pushret, ] ;
-code noop exit,
-code dup dup, exit,
-: swap, PSP) @!, ; code swap swap, exit,
-: nip, 4 ps+, ; code nip nip, exit,
-: drop, PSP) @, nip, ; code drop drop, exit,
-: 2drop, PSP) 4 +) @, 8 ps+, ; code 2drop 2drop, exit,
-: rot, PSP) @!, PSP) 4 +) @!, ; code rot rot, exit,
-code rot> PSP) 4 +) @!, PSP) @!, exit,
-: over, dup, PSP) 4 +) @, ; code over over, exit,
-code tuck swap, over, exit,
-code 2dup -8 ps+, PSP) 4 +) !, PSP) 8 +) @, PSP) !, PSP) 4 +) @, exit,
-
-code @ W) @, exit,
-code16b HERE @ W) 16b) @, exit,
-code8b HERE @ W) 8b) @, exit,
-code c@ branch, drop
-code w@ branch, drop
-
-code ! W>A, PSP) @, A) !, 2drop, exit,
-code16b HERE @ W>A, PSP) @, A) 16b) !, 2drop, exit,
-code8b HERE @ W>A, PSP) @, A) 8b) !, 2drop, exit,
-code c! branch, drop
-code w! branch, drop
-
-code +! W>A, drop, A) +, A) !, drop, exit,
-code16b W>A, drop, A) 16b) +, A) 16b) !, drop, exit,
-code8b W>A, drop, A) 8b) +, A) 8b) !, drop, exit,
-code 1+! 1 W) [+n], drop, exit,
-code16b 1 W) 16b) [+n], drop, exit,
-code8b 1 W) 8b) [+n], drop, exit,
-code 1-! -1 W) [+n], drop, exit,
-code16b -1 W) 16b) [+n], drop, exit,
-code8b -1 W) 8b) [+n], drop, exit,
-code @! W>A, drop, A) @!, exit,
-code16b W>A, drop, A) 16b) @!, exit,
-code8b W>A, drop, A) 8b) @!, exit,
-code @+ W>A, A) @, W<>A, 4 W+n, dup, W<>A, exit,
-code16b W>A, A) 16b) @, W<>A, 2 W+n, dup, W<>A, exit,
-code8b HERE @ W>A, A) 8b) @, W<>A, 1 W+n, dup, W<>A, exit,
-code c@+ branch, drop
-
-code !+ W>A, drop, A) !, W<>A, 4 W+n, exit,
-code16b W>A, drop, A) 16b) !, W<>A, 2 W+n, exit,
-code8b HERE @ W>A, drop, A) 8b) !, W<>A, 1 W+n, exit,
-code c!+ branch, drop
-
-code @@+ W>A, A) [@], 4 A) [+n], exit,
-code16b W>A, A) 16b) [@], 2 A) [+n], exit,
-code8b W>A, A) 8b) [@], 1 A) [+n], exit,
-code @!+ W>A, drop, A) [!], 4 A) [+n], drop, exit,
-code16b W>A, drop, A) 16b) [!], 2 A) [+n], drop, exit,
-code8b W>A, drop, A) 8b) [!], 1 A) [+n], drop, exit,
-
-code + PSP) +, nip, exit,
-code - -W, PSP) +, nip, exit,
-: -^ swap - ;
-: e>w 4 + ;
-: e>wlen 5 - ;
-: w>e 4 - ;
-: current sysdict @ e>w ;
-code 1+ 1 W+n, exit,
-code 1- -1 W+n, exit,
-: immediate sysdict @ e>wlen dup c@ $80 or swap c! ;
-: EMETA_16B $11 ; : EMETA_8B $10 ;
-: 16b EMETA_16B MOD ! ; immediate
-: 8b EMETA_8B MOD ! ; immediate
-: :8b code8b ] ;
-: :16b code16b ] ;
-
-: , HERE @!+ ; :16b HERE 16b @!+ ; :8b HERE 8b @!+ ; : c, 8b , ;
-
-code execute W>A, drop, branchA,
-code not W=0>Z, Z) C>W, exit,
-code bool W=0>Z, NZ) C>W, exit,
-: if W>A, drop, A=0>Z, 0 Z) branchC, ; immediate
-: ahead 0 branch, ; immediate
-: then HERE @ swap branch! ; immediate
-code ?dup W=0>Z, 0 Z) branchC, dup, then exit,
-: ' word sysdict @ find dup not if (wnf) then ;
-: ['] ' litn ; immediate
-: compile ' litn ['] execute, execute, ; immediate
-: [compile] ' execute, ; immediate
-: allot HERE +! ;
-: else [compile] ahead HERE @ rot branch! ; immediate
-: begin HERE @ ; immediate
-: again branch, drop ; immediate
-: until W>A, drop, A=0>Z, Z) branchC, drop ; immediate
-: _ code PSP) compare, C>W, nip, exit, ;
-Z) _ = NZ) _ <> >) _ < <) _ > >=) _ <= <=) _ >=
-
-: \ begin in< $20 < until ; immediate
-\ hello, this is a comment!
-: exit popret, exit, ; immediate
-: ( begin
- word dup c@ 1 = if
- 1+ c@ ')' = if exit then else drop then
- again ; immediate
-( hello, another comment! )
-
-\ Arithmetic
-: 0>= $80000000 < ;
-: 0< 0>= not ;
-: / /mod nip ;
-: mod /mod drop ;
-: ?swap ( n n -- l h ) 2dup > if swap then ;
-: min ?swap drop ; : max ?swap nip ;
-: max0 ( n -- n ) dup 0< if drop 0 then ;
-: =><= ( n l h -- f ) over - rot> ( h n l ) - >= ;
-code neg -W, exit,
-: ^ -1 xor ;
-: and? bool swap bool and ;
-: or? or bool ;
-: upcase ( c -- c ) dup 'a' - 26 < if $df and then ;
-
-\ Stack
-: rdrop 4 rs+, ; immediate
-: 2rdrop 8 rs+, ; immediate
-: r! -4 rs+, RSP) !, ; immediate
-: r@ dup, RSP) @, ; immediate
-: r> [compile] r@ [compile] rdrop ; immediate
-: >r [compile] r! drop, ; immediate
-code scnt pushret, dup, PSP) addr, ] PSTOP -^ >> >> 1- ;
-code rcnt pushret, dup, RSP) addr, ] RSTOP -^ >> >> ;
-
-: while [compile] if swap ; immediate
-: repeat [compile] again [compile] then ; immediate
-
-: case ( -- then-stopgap ) 0 [compile] >r ; immediate
-: of ( -- jump-addr ) [compile] r@ word compword [compile] if ; immediate
-: endof [compile] else ; immediate
-: endcase ( then-stopgap jump1? jump2? ... jumpn? -- )
- ?dup if begin [compile] then ?dup not until then [compile] rdrop ; immediate
-
-\ Local variables + beginning of compiling words
-code (cell) pushret, r> popret, exit,
-: create code pushret, compile (cell) ;
-: const code litn exit, ;
-4 const CELLSZ
-
-\ execword param: addr
-\ compileword param: HAL operand
-create toptr 0 , \ pointer to 8b struct [execword, compileword]
-: _@, ( operand -- ) dup, @, ; :16b dup, 16b) @, ; :8b dup, 8b) @, ;
-create toptrdef ' @ , ' _@, ,
-: toptr@ ( -- w )
- 0 toptr @! ?dup not if toptrdef then
- compiling if CELLSZ + then @ findmod ;
-: var, ( off -- ) RSP) swap [rcnt] @ neg CELLSZ - -^ +) toptr@ execute ;
-: V1 0 var, ; immediate : V2 4 var, ; immediate
-: V3 8 var, ; immediate : V4 12 var, ; immediate
-
-\ Compiling words
-create _ 0 ,
-code (does) pushret, r> W>A, W) @, W<>A, CELLSZ W+n, branchA,
-: doer code pushret, compile (does) HERE @ _ ! CELLSZ allot ;
-: does> r> ( exit current definition ) _ @ ! ;
-: does' ( w -- 'data ) DOESSZ + ;
-
-: _to doer ' , ' , immediate does> toptr ! ;
-: _!, !, drop, ; :16b 16b) !, drop, ; :8b 8b) !, drop, ;
-_to to ! _!,
-: _+!, dup +, _!, ; :16b dup 16b) +, 16b _!, ; :8b dup 8b) +, 8b _!, ;
-_to to+ +! _+!,
-: _1+!, 1 swap [+n], ; :16b 1 swap 16b) [+n], ; :8b 1 swap 8b) [+n], ;
-_to to1+ 1+! _1+!,
-: _1-!, -1 swap [+n], ; :16b -1 swap 16b) [+n], ; :8b -1 swap 8b) [+n], ;
-_to to1- 1-! _1-!,
-_to to@! @! @!,
-: _@@+, dup, dup [@], 4 swap [+n], ;
-:16b dup, dup 16b) [@], 2 swap [+n], ;
-:8b dup, dup 8b) [@], 1 swap [+n], ;
-_to to@+ @@+ _@@+,
-: _@!+, dup [!], 4 swap [+n], drop, ;
-:16b dup 16b) [!], 2 swap [+n], drop, ;
-:8b dup 8b) [!], 1 swap [+n], drop, ;
-_to to!+ @!+ _@!+,
-: _addr, dup, addr, ; :16b dup, addr, ; :8b dup, addr, ;
-_to to' noop _addr,
-: _toexec ( a -- ) compiling if m) then toptr@ execute ;
-: value doer , immediate does> _toexec ;
-: here HERE _toexec ; immediate
-: alias ' code branch, drop ;
-
-alias @ llnext
-: llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ;
-: llappend ( elem ll -- ) llend ! ;
-: lladd ( ll -- newll ) here swap llappend here 0 , ;
-
-\ Entry metadata
-: &+ ( n -- ) code W+n, exit, ;
-: &+@ ( n -- ) code W+n, W) @, exit, ;
--4 &+@ emeta
--4 &+ 'emeta
-: metaadd ( id entry -- ) 'emeta lladd drop , ;
-
-: realias ( 'new 'tgt -- ) to@! here swap branch, drop to here ;
-: :realias ' sysdict curword entry here swap realias pushret, ] ;
-: _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ;
-: chain ( w1 w2 -- w )
- _ swap _ tuck over and? if
- here rot execute, swap branch, drop else ?swap nip then ;
-alias noop idle
-
-alias execute | immediate
-: bi dup, ['] swap, ; immediate
-: bi+ dup, ['] over, ; immediate
-: tri dup, ['] rot, ['] over, ; immediate
-: _ [compile] r> ;
-: dip [compile] >r ['] _ ; immediate
-
-\ Iteration
-: xtcomp [compile] ] 0 align4 begin word runword compiling not until ;
-: ivar, ( off -- ) RSP) swap +) toptr@ execute ;
-: i 4 ivar, ; immediate : j 8 ivar, ; immediate : k 12 ivar, ; immediate
-: :iterator doer immediate xtcomp does> ( w -- yieldjmp loopaddr )
- -16 rs+, RSP) !, LIT>W, RSP) @!,
- [compile] ahead \ jump to yield
- [compile] begin ( loop ) ;
-0 value _breaklbl
-: next ( yieldjmp loopaddr -- )
- swap [compile] then [compile] yield [compile] again
- 12 rs+, 4 [rcnt] +! 0 to@! _breaklbl ?dup drop ; immediate
-: unyield BRSZ RSP) [+n], ; immediate
-: break 16 rs+, [compile] ahead to _breaklbl ; immediate
-
-:iterator for ( n -- ) [
- 1 W+n, RSP) 4 +) !, drop, ahead
- begin yield swap then -1 RSP) 4 +) [+n], NZ) branchC, drop
- unyield popret, exit,
-
-:iterator for2 ( lo hi -- )
- to j to i i j < if begin yield to1+ i i j >= until then unyield ;
-
-code fill ( a u c -- )
- W>A, PSP) 4 +) @, W<>A, 1 PSP) [+n], begin \ A=a W=c P+0=u+1
- -1 PSP) [+n], 0 NZ) branchC, 8 ps+, drop, exit, then
- A) 8b) !, 1 A+n, branch, drop
-
-: allot0 ( n -- ) here over 0 fill allot ;
-: nc, ( n -- ) for word runword c, next ;
-
-code [c]? ( c a u -- i )
- W=0>Z, 0 Z) branchC,
- PSP) @!, W>A, 0 LIT>W, dup, begin \ P+8=c P+4=u P+0=i A=a
- A) 8b) @, PSP) 8 +) 8b) compare, 0 NZ) branchC, drop, 8 ps+, exit, then
- 1 A+n, 1 PSP) [+n], PSP) @, PSP) 4 +) compare, NZ) branchC, drop
- drop, then
- 8 ps+, -1 LIT>W, exit,
-
-\ Emitting
-$20 const SPC $0d const CR $0a const LF $08 const BS $1b const ESC
-alias drop emit
-: nl> LF emit ; : spc> SPC emit ;
-:realias rtype ( a u ) for c@+ emit next drop ;
-: stype ( str -- ) c@+ rtype ;
-create _escapes 3 nc, 'n' 'r' '0'
-create _repl 3 nc, LF CR 0
-: "< ( -- c )
- in< dup '"' = if drop -1 else dup '\' = if
- drop in< dup _escapes 3 [c]? dup 0>= if nip _repl + c@ else drop then
- then then ;
-: ," begin "< dup -1 <> while c, repeat drop ;
-: ,[ [compile] ahead here [compile] [ ; immediate
-: ], ( jmp a -- ) here over - rot 0 align4 [compile] then swap litn litn ] ;
-: S"
- compiling if [compile] ahead then
- here 1 allot here ," here -^ ( a len ) over c!
- compiling if swap 0 align4 [compile] then litn then ; immediate
-: ."
- compiling if [compile] S" compile stype else
- begin "< dup 0>= while emit repeat drop then ; immediate
-: abort" [compile] ." compile abort ; immediate
-: word" [compile] S" NEXTWORD litn compile ! ; immediate
-: '" [compile] word" compile ' ; immediate
-
-code []= ( a1 a2 u -- f )
- W=0>Z, 0 Z) branchC, PSP) @!, W>A, begin \ P+4=a1 P+0=u A=a2
- PSP) 4 +) 8b) [@], A) 8b) compare, 0 Z) branchC,
- 8 ps+, 0 LIT>W, exit, then
- 1 A+n, 1 PSP) 4 +) [+n], -1 PSP) [+n], NZ) branchC, drop then
- 8 ps+, 1 LIT>W, exit,
-: s= ( s1 s2 -- f ) over c@ 1+ []= ;
-: [if] not if S" [then]" begin word over s= until drop then ;
-alias noop [then]
-
-code move ( src dst u -- )
- W=0>Z, 0 Z) branchC, W>A, begin \ A=u
- PSP) 4 +) 8b) [@], PSP) 8b) [!],
- 1 PSP) 4 +) [+n], 1 PSP) [+n],
- -1 A+n, NZ) branchC, drop then
- 8 ps+, drop, exit,
-
-: move, ( src u -- ) here swap dup allot move ;
-: -move, ( src u -- ) here over - swap move ;
-
-\ Structures
-0 value _extends
-: extends ' to _extends ;
-0 value _bkp \ backup of sysdict to restore at ]struct
-0 value _cur \ current struct entry
-0 value _curroot \ root entry of the current struct hierarchy
-: structsz' ( struct -- a ) does' CELLSZ + ;
-: structsz ( struct -- sz ) structsz' @ ;
-: structdict' does' ;
-: structlastfield' structsz' CELLSZ + ;
-: _structfind ( 'struct "name" -- 'word )
- @ ( 'dict ) word swap ( str 'dict ) find ( 'word )
- ?dup not if curword stype abort" not in namespace!" then ;
-: structfind ( "struct" "name" -- 'word ) ' does' _structfind ;
-
-: _curroot! ( struct -- )
- \ Make root word of struct temporarily point to sysdict
- structdict' llend dup to _curroot ( struct root ) sysdict @ swap ! ;
-: struct+[
- sysdict @ to _bkp ' dup w>e to _cur dup _curroot! ( struct )
- structdict' @ sysdict ! ;
-
-: struct[
- doer immediate 0 ,
- _extends dup if structsz' CELLSZ 2 * move, else ( 0 ) , 0 , then
- sysdict @ dup to _cur to _bkp
- _extends ?dup if
- _curroot! 0 to@! _extends structdict' sysdict !
- else
- word" :self" code exit, \ :self is our root
- sysdict @ to _curroot then
- word" SZ" code _cur e>w structsz' litn W) @, exit,
-does> ( 'struct )
- _structfind
- dup w>e e>wlen c@ $80 and not compiling and \ compile only if not immediate
- if execute, else execute then ;
-: ]struct
- \ break the chain at the root of the struct
- 0 _curroot !
- \ Rewind the sysdict to our struct
- _bkp sysdict @! _cur e>w structdict' ! ;
-
-0 const STRUCTFIELD_REGULAR
-1 const STRUCTFIELD_REFERENCE
-2 const STRUCTFIELD_CONST
-3 const STRUCTFIELD_METHOD
-4 const STRUCTFIELD_STATICMETHOD
-
-: sallot ( n -- ) _cur e>w structsz' +! ;
-create _ 0 , EMETA_8B , EMETA_16B ,
-: _szmeta dup 3 < if CELLSZ * _ + @ else drop 0 then ;
-: _sfield ( sz type -- )
- current _cur e>w structlastfield' @! ( next ) ,
- _cur e>w structsz , ( sz type ) over , , ( sz ) sallot ;
-: _svalue ( sz -- ) doer immediate STRUCTFIELD_REGULAR _sfield
- does> CELLSZ + @+ dip @ | ( a? sz off )
- compiling if ( sz off )
- W>A, drop, A) swap +) swap
- else ( a sz off ) rot + swap then ( a-or-operand sz )
- _szmeta MOD ! toptr@ execute ;
-: sfield CELLSZ _svalue ;
-: sfieldw 2 _svalue ;
-: sfieldb 1 _svalue ;
-: sfield' ( sz -- ) doer STRUCTFIELD_REFERENCE _sfield
- does> CELLSZ + @ ( a off ) + ;
-: sconst doer CELLSZ STRUCTFIELD_CONST _sfield
- does> CELLSZ + @ ( a off ) + @ ;
-: smethod doer CELLSZ STRUCTFIELD_METHOD _sfield
- does> CELLSZ + @ over + @ execute ;
-: ssmethod doer CELLSZ STRUCTFIELD_STATICMETHOD _sfield
- does> CELLSZ + @ swap + @ execute ;
-: nabort, ( n -- ) ['] abort swap for dup , next drop ;
-
-\ 4b link to struct
-\ 4b link to data
-: structbind ( 'data -- ) ' doer , , immediate does> ( 'bind -- *to* )
- @+ swap compiling if dup, m) @, else @ swap then execute ;
-: rebind ( 'data 'bind -- ) does' CELLSZ + ! ;
-
-struct[ Drive
- sfield secsz
- sfield seccnt
- smethod :sec@ ( sec dst drv -- )
- smethod :sec! ( sec src drv -- )
- : :new ( secsz seccnt -- drv ) here rot , swap , ;
- : :[methods] '" sec@" , '" sec!" , ;
-]struct
-
-struct[ IO
- sfield putback
- SZ &+ :methods(
- smethod :readbuf ( n hdl -- a? read-n )
- smethod :writebuf ( a n hdl -- written-n )
- smethod :flush ( hdl -- )
- smethod :close ( hdl -- )
- : :getc ( hdl -- c )
- dup putback ?dup if ( hdl c ) 0 rot to putback else ( hdl )
- 1 swap :readbuf if c@ else -1 ( EOF ) then then ;
- : :new here 0 ( putback ) , 4 nabort, ;
- alias drop close
- alias drop flush
- : :[methods] '" readbuf" , '" writebuf" , '" flush" , '" close" , ;
-]struct
-
-extends IO struct[ Pipe
- sfield readio
- sfield writeio
-
- : readbuf readio :readbuf ;
- : writebuf writeio :writebuf ;
- : flush writeio :flush ;
- : :new ( readio writeio -- pipe )
- IO :new ,[ :[methods] ], -move, rot ( readio ) , swap ( writeio ) , ;
- : _chain! ( w1 'w2 -- ) dup @ rot swap chain swap ! ;
- : :addrfilter ( w self -- ) CELLSZ + _chain! ;
- : :addwfilter ( w self -- ) CELLSZ << + _chain! ;
- : :filters$ ( self -- ) ['] readbuf swap CELLSZ + !+ ['] writebuf swap ! ;
-]struct
-
-: _ioerr abort" Invalid I/O" ;
-\ key and boot< never yield EOF
-create _buf 1 allot
-: _readbuf ( n hdl -- a? read-n ) 2drop boot< _buf c! _buf 1 ;
-create BootIn 0 , ' _readbuf , ' _ioerr , ' _ioerr , ' _ioerr ,
-: _writebuf 2drop drop 0 ;
-create IONullOut 0 , ' _ioerr , ' _writebuf , ' _ioerr , ' _ioerr ,
-
-BootIn IONullOut Pipe :new structbind Pipe console
-0 value consoleecho
-: consolein console :getc consoleecho if dup emit then ;
-current ' in< realias
-console :self console :self Pipe :new structbind Pipe stdio
-
-struct+[ IO
- : :interpret ( self -- self )
- to@! console readio >r
- begin maybeword ?dup while runword repeat
- r> to@! console readio ;
-]struct
-
-struct[ Filesystem
- sfield drv
- sfield flags
- smethod :child
- smethod :info
- smethod :open
- smethod :iter
- smethod :newfile
- smethod :newdir
- smethod :remove
- : :drv [compile] drv [compile] Drive ; immediate
- : :writeable? flags 1 and ;
- : :new ( drv -- fs ) here swap ( drv ) , 0 ( flags ) , 7 nabort, ;
- : :[methods]
- '" child" , '" info" , '" open" , '" iter" ,
- '" newfile" , '" newdir" , '" remove" , ;
-]struct
-extends IO struct[ File
- sfield pos
- sfield size
- smethod :seek ( n hdl -- )
- smethod :resize ( sz hdl -- )
- : :new ( -- hdl )
- IO :new 0 ( pos ) , 0 ( size ) , 2 nabort, ;
- : seek ( pos hdl -- ) to pos ;
- alias 2drop resize
- : :[methods] '" seek" , '" resize" , ;
-]struct
-
-\ File loading
-\ TODO: support loading from multiple FSes.
-0 value floaded \ head of the LL
-: floaded? ( id -- f )
- floaded begin ( id ll )
- ?dup while 2dup CELLSZ + @ <> while llnext repeat
- 2drop 1 else drop 0 then ;
-: floaded, ( id -- ) dup floaded? if drop else here to@! floaded , , then ;
-: \s console readio IO :close ;
-: fload ( fs id -- )
- dup floaded, swap Filesystem :open IO :interpret File :close ;
diff --git a/posix/vm.c b/posix/vm.c
@@ -979,6 +979,8 @@ static void buildsysdict() {
if (opnames[i]) wentry(opnames[i], i+0x28);
}
wentry("[", 0x3d); makeimm();
+ entry("pushret,"); retwr();
+ entry("popret,"); retwr();
entry("ps+,"); compileop(0x08); writewr(); retwr();
entry("LIT>W,"); compileop(0x0a); writewr(); retwr();
entry("LIT>A,"); compileop(0x0b); writewr(); retwr();
