commit 1414b9cb2c0c446a65f27b6c2302097705f9a88d
parent b705d776f5315785fbdef0d74ff71f2bbd118078
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 12 Jun 2023 11:54:50 -0400
rpi: structures!
Diffstat:
2 files changed, 153 insertions(+), 14 deletions(-)
diff --git a/fs/xcomp/arm/rpi/kernel.fs b/fs/xcomp/arm/rpi/kernel.fs
@@ -34,10 +34,10 @@
: setrn0) ( -- operand ) bic) $f0000 i) ;
: values ( n -- ) for 0 value next ;
-18 values lblcurword lblsysdict lblhere lblnextmeta lblcompiling lblbootptr
- lblhbank lblmod lbl[rcnt]
+20 values lblcurword lblsysdict lblhere lblnextmeta lblcompiling lblbootptr
+ lblhbank lblmod lbl[rcnt] lblnextword
lblimmsplit lbladdnwr lbllitwr lblmemwr
- lblcwrite lbldwrite lblwriterange
+ lblcwrite lbldwrite lblmoverange lblwriterange
lblerrmsg lblmain
$8000 to binstart
binstart const RSTOP
@@ -213,8 +213,32 @@ xcode in< wjmp, boot<
pc to lblcurword $20 allot0
lblcurword xaddr curword
-xcode word pushret, ( -- str )
+pc to lblnextword 0 le,
+lblnextword xaddr NEXTWORD
+
+pc to lblmoverange \ r0=src r1=len r2=dst. out: r0=src+len r2=dst+len Saves r3
+ ldr) r4 rd) r0 rn) 8b) 1 +i) post) ,)
+ str) r4 rd) r2 rn) 8b) 1 +i) post) ,)
+ sub) r1 rdn) 1 i) f) ,)
+ lblmoverange abs>rel b) ne) ,)
+ exit,
+
+pc \ we have a nonzero lblnextword. r0=src
+ lblnextword r1 pc>reg,
+ mov) r2 rd) 0 i) ,)
+ str) r2 rd) r1 rn) ,)
+ ldr) r1 rd) r0 rn) 8b) ,) \ len
+ add) r1 rdn) 1 i) ,)
+ lblcurword r2 pc>reg, \ dst
+ mov) rTOP rd) r2 rm) ,)
+ lblmoverange abs>rel b) ,)
+
+xcode word ( -- str )
xdup,
+ lblnextword r0 pc@>reg,
+ cmp) r0 rn) 0 i) ,)
+ ( pc ) abs>rel b) ne) ,)
+ pushret,
pc
wcall, in<
xnip,
@@ -299,14 +323,10 @@ pc to lbldwrite \ r0=n. Destroys r1 and r2, preserves rest and flags
exit,
pc to lblwriterange \ r0=addr r1=len
- lblhere r2 pc>reg,
- ldr) r3 rd) r2 rn) ,)
- pc
- ldr) r4 rd) r0 rn) 8b) 1 +i) post) ,)
- str) r4 rd) r3 rn) 8b) 1 +i) post) ,)
- sub) r1 rdn) 1 i) f) ,)
- ( pc ) abs>rel b) ne) ,)
- str) r3 rd) r2 rn) ,)
+ lblhere r3 pc>reg,
+ ldr) r2 rd) r3 rn) ,)
+ pushret, lblmoverange abs>rel bl) ,) popret,
+ str) r2 rd) r3 rn) ,)
exit,
xcode align4 ( n -- )
@@ -421,9 +441,11 @@ pc to L1 ( operand -- ) \ r0=base instr. Preserves r3
lbldwrite abs>rel b) ,)
\ Extract 12b rotate+imm from n. Preserves r0
-pc to lblimmsplit \ In: rTOP=n Out: rTOP=rotate+imm r1=rest of n. Z set if 0
+pc to lblimmsplit \ In: rTOP=n Out: rTOP=rotate+imm r1=rest of n.
mov) r2 rd) 0 i) ,) \ r2=rotate
mov) r1 rd) 0 i) ,)
+ cmp) rTOP rn) $100 i) ,)
+ return) lo) ,)
pc
mov) r3 rd) rTOP rm) r2 rlsr) f) ,)
return) z) ,) \ rTOP is zero, nothing to do
@@ -747,6 +769,11 @@ xcode rshift ( n u -- n )
mov) rTOP rd) r0 rm) rTOP rlsr) ,)
exit,
+xcode * ( a b -- n )
+ r0 ppop,
+ mul) rTOP rd) rTOP rs) r0 rm) ,)
+ exit,
+
pc ," divide by zero" 0 align4
xcode /mod ( a b -- r q )
( pc ) r0 pc>reg,
diff --git a/fs/xcomp/rpiboot.fs b/fs/xcomp/rpiboot.fs
@@ -210,7 +210,7 @@ alias execute | immediate
: dip [compile] >r ['] _ ; immediate
\ Iteration
-: xtcomp [compile] ] begin word runword compiling not until ;
+: 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 )
@@ -308,8 +308,120 @@ create _repl 3 nc, LF CR 0
: ."
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[ Foo
+ sfield bar
+ sfield baz
+]struct
+
+create data 'A' , 'X' ,
+
+: hey data Foo baz emit ;
: foo ." foo!" ;
: bar ." bar!" ;
: prompt ." Hello World!" ;
+
uartinit prompt ' key ' in< realias
