duskos

commit 8e1a457e3438c84ef6b547a47bce241e4694a270
parent 0cd5ad61c390d591635b4141882ccc6b3e1e6be4
Author: Virgil Dupras <hsoft@hardcoded.net>
Date:   Mon, 30 Jan 2023 15:45:56 -0500

xcomp/bootlo: refactoring

Diffstat:
M
fs/xcomp/bootlo.fs
 | 
40
++++++++++++++--------------------------

1 file changed, 14 insertions(+), 26 deletions(-)
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -72,9 +72,8 @@ code 2drop 8 p+, exit,
 : const code litn exit, ;
 4 const CELLSZ
 create toptr 0 ,
-: var, ( off -- )
-  [rcnt] @ neg CELLSZ - -^ r',
-  0 toptr @! ?dup not if ['] @ then findmod execute, ;
+: _toptr@ ( -- w ) 0 toptr @! ?dup not if ['] @ then findmod ;
+: var, ( off -- ) [rcnt] @ neg CELLSZ - -^ r', _toptr@ execute, ;
 : V1 0 var, ; immediate : V2 4 var, ; immediate
 : V3 8 var, ; immediate : V4 12 var, ; immediate
 
@@ -99,17 +98,13 @@ create _ 0 ,
 : doer code compile (does) HERE @ _ ! CELLSZ allot ;
 : does> r> ( exit current definition ) _ @ ! ;
 : does' ( w -- 'data ) CALLSZ + CELLSZ + ;
-: to ['] ! toptr ! ; immediate
-: to+ ['] +! toptr ! ; immediate
-: to' ['] noop toptr ! ; immediate
-: to@! ['] @! toptr ! ; immediate
-: to@+ ['] @@+ toptr ! ; immediate
-: to!+ ['] @!+ toptr ! ; immediate
-: toexec ( a w -- ) compiling if
-    swap litn 0 toptr @! ?dup if nip findmod then execute, else
-    0 toptr @! ?dup if nip findmod then execute then ;
-: value doer , immediate does> ['] @ toexec ;
-: here HERE ['] @ toexec ; immediate
+: _to doer ' , immediate does> @ toptr ! ;
+_to to !           _to to+ +!          _to to' noop        _to to@! @!
+_to to@+ @@+       _to to!+ @!+
+: _toexec ( a -- )
+  compiling if litn _toptr@ execute, else _toptr@ execute then ;
+: value doer , immediate does> _toexec ;
+: here HERE _toexec ; immediate
 : alias ' code alias, ;
 : realias ( 'new 'tgt -- ) to@! here swap alias, to here ;
 : _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ;
@@ -154,12 +149,10 @@ current ' rtype realias
 : abort" [compile] ." compile abort ; immediate
 : word" [compile] S" NEXTWORD litn compile ! ; immediate
 
-\ Return whether strings s1 and s2 are equal
 : s= ( s1 s2 -- f ) over c@ 1+ []= ;
 : [if] not if S" [then]" begin word over s= until drop then ;
 alias noop [then]
 
-\ Linked lists. See doc/usage.
 alias @ llnext
 : llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ;
 : llprev ( tgt ll -- prev )
@@ -184,7 +177,6 @@ $01 const EMETA_DOCLINE \ a doc strings that ends with LF
 : \\ nextmeta lladd drop EMETA_DOCLINE , begin in< dup c, LF = until ;
 
 \ Structures
-
 0 value _extends
 : extends ' to _extends ;
 0 value _bkp \ backup of sysdict to restore at ]struct
@@ -200,8 +192,8 @@ $01 const EMETA_DOCLINE \ a doc strings that ends with LF
 : 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 ! ;
+  \ 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 ! ;
@@ -240,11 +232,8 @@ create _ 0 , EMETA_8B , EMETA_16B ,
   _cur e>w structsz , ( sz type ) over , , ( sz ) sallot ;
 : _svalue ( sz -- ) doer immediate STRUCTFIELD_REGULAR _sfield
   does> CELLSZ + @+ swap @ swap ( a? sz off )
-    0 toptr @! ?dup not if ['] @ then ( a? sz off w )
-    compiling if ( sz off w )
-      swap litn compile + swap _szmeta MOD ! findmod execute,
-    else ( a sz off w )
-      >r rot + ( sz a R:w ) swap _szmeta MOD ! r> findmod execute then ;
+    compiling if ( sz off ) litn compile + _szmeta MOD ! _toptr@ execute,
+    else ( a sz off ) rot + ( sz a ) swap _szmeta MOD ! _toptr@ execute then ;
 : sfield CELLSZ _svalue ;
 : sfieldw 2 _svalue ;
 : sfieldb 1 _svalue ;
@@ -260,8 +249,7 @@ create _ 0 , EMETA_8B , EMETA_16B ,
 \ 4b link to struct
 \ 4b link to data
 : structbind ( 'data -- ) ' doer , , immediate does> ( 'bind -- *to* )
-  dup @ swap CELLSZ + ( 'struct ''data )
-  compiling if litn compile @ else @ swap then execute ;
+  @+ swap compiling if litn compile @ else @ swap then execute ;
 : rebind ( 'data 'bind -- ) does' CELLSZ + ! ;
 
 \ Drive API