commit 1f28be423fb7b75911a6c39e2fc37dec15cfcff4
parent d4881a048d2117880111b0e5f11a23f3601c7eb9
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Tue, 2 Aug 2022 17:32:32 -0400
Replace "unaliases" with "chain"
See doc/usage. The new chain semantics fixes an important problem: avoiding
the override of aliases as a side effect of loading modules. For example,
lib/btrace would override the "abort" alias on load, which is problematic
because we aren't ready, when we load btrace, to get off out "boot failed"
abort handler.
With "chain", we can operate chaining in initializing words, as we can see with
the replacement I've made in rdln and btrace.
Diffstat:
6 files changed, 55 insertions(+), 15 deletions(-)
diff --git a/fs/doc/usage.txt b/fs/doc/usage.txt
@@ -30,3 +30,29 @@ close to your value/alias call.
to+ sets "to" to "+!"
to' sets "to" to "noop" (returns the address)
+
+# chain
+
+It's a common pattern to want to "chain" behaviors in aliases. For example, one
+could want to set the "emit" alias to a word that calls the previous "emit"
+routine and add behavior to it.
+
+One could manually set up a variable holding the old value and then call it, but
+this gets verbose after a while.
+
+The "chain" word does so with minimal boilerplate.
+
+ chain emit myemitroutine
+
+This reads the current target of the alias "emit" and writes a new word that
+calls "myemitroutine" with this address at the top of PS. Then, it sets the
+"emit" alias' target to "myemitroutine". If, for example, you wanted to override
+"emit" so that every character emitted was preceded by 'X', you would write:
+
+ : myemitroutine ( c 'emit -- ) 'X' over execute execute ;
+ chain emit myemitroutine
+
+This word works both in compiling mode and outside of it. For example, this
+would work too:
+
+ : moduleinit chain emit myemitroutine ;
diff --git a/fs/lib/btrace.fs b/fs/lib/btrace.fs
@@ -2,5 +2,5 @@
?f<< lib/nfmt.fs
: raddr>entry ( a -- w ) current begin 2dup < while prevword repeat nip ;
: .raddr ( a -- ) dup .x raddr>entry ?dup if spc> .word then ;
-: .btrace nl> begin rcnt while r> .raddr nl> repeat unaliases abort ;
-' .btrace to abort
+: _abort ( 'oldabort -- ) nl> begin rcnt while r> .raddr nl> repeat execute ;
+: btrace$ chain abort _abort ;
diff --git a/fs/sys/rdln.fs b/fs/sys/rdln.fs
@@ -19,9 +19,8 @@ in) value in>
in> in) < if in> c@+ swap to in> else 0 then ;
: rdln< ( -- c ) rdln<? ?dup not if
rdln in( to in> SPC then ;
-: rdln$ ['] rdln< to in< in) to in> ;
-
-: _ rdln$ unaliases main ;
-' _ to main
-
-
+: rdlnreset ['] rdln< to in< in) to in> ;
+: rdlnmain ( 'oldmain -- ) rdlnreset execute ;
+: rdln$
+ ['] (abort) to abort \ we have a read loop, we can have regular abort.
+ rdlnreset chain main rdlnmain ;
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -14,3 +14,14 @@ foo 43 #eq
foo 48 #eq
to' foo @ 48 #eq
+\ alias chaining
+alias 1+ foo
+: myfoo ( n 'foo -- n ) execute << ; \ (n+1)*2
+chain foo myfoo
+42 foo 86 #eq \ (42+1)*2
+' 1+ to foo
+: fooinit chain foo myfoo ;
+42 foo 43 #eq
+fooinit
+42 foo 86 #eq \ (42+1)*2
+testend
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -99,6 +99,16 @@ alias else endof immediate
\ Return whether strings s1 and s2 are equal
: s= ( s1 s2 -- f ) over c@ 1+ []= ;
+\ Alias chaining. See doc/usage.
+: _ ( 'target 'alias -- )
+ dup to@ execute ( 'tgt 'alias 'prevtgt )
+ swap here swap to execute ( 'tgt 'prevtgt )
+ litn execute, exit, ;
+: chain
+ ' ' ( 'alias 'target ) compiling if
+ litn litn compile _ else
+ swap _ then ; immediate
+
\ Drive API
\ Anticipating lib/drive
: sectorsize ( drv -- ) @ ;
@@ -111,6 +121,3 @@ alias else endof immediate
\ doc comment placeholder
alias \ \\
-
-\ words for alias chaining
-: unaliases ' to' execute @ execute, ; immediate
diff --git a/fs/xcomp/init.fs b/fs/xcomp/init.fs
@@ -5,9 +5,6 @@ f<< lib/nfmt.fs
f<< lib/diag.fs
f<< sys/xhere.fs
f<< sys/rdln.fs
-\ TODO: redesign chaining so that this alias rebind below can happen during
-\ rdln$ without breaking the chaining done in btrace.
-' (abort) to abort
f<< lib/btrace.fs
-: init S" Dusk OS" stype nl> .free rdln$ ( unwind the boot RS ) quit ;
+: init S" Dusk OS" stype nl> .free rdln$ btrace$ ( unwind the boot RS ) quit ;
init
