From c515720e23450ee11eea1be3ca8cf84d98551783 Mon Sep 17 00:00:00 2001
From: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 11 Apr 2020 13:31:17 -0400
Subject: [PATCH] Revert "Remove link.fs"

Let's revisit the relinking approach, with LITA this time.
This reverts commit 6652125d479562c871685e6d8e1248cfd3e802a6.
---
 emul/Makefile           |   3 +-
 forth/dict.fs           |  18 ------
 forth/link.fs           | 162 ++++++++++++++++++++++++++++++++++++++++++++++++
 recipes/rc2014/Makefile |   1 -
 recipes/rc2014/pre.fs   |   2 +-
 5 files changed, 165 insertions(+), 21 deletions(-)
 delete mode 100644 forth/dict.fs
 create mode 100644 forth/link.fs

diff --git a/emul/Makefile b/emul/Makefile
index 2f4d0cb..4046335 100644
--- a/emul/Makefile
+++ b/emul/Makefile
@@ -9,7 +9,8 @@ BOOTSRCS = ./forth/conf.fs \
 	../forth/icore.fs \
 	./forth/xstop.fs
 
-FORTHSRCS = core.fs cmp.fs print.fs str.fs parse.fs readln.fs fmt.fs z80a.fs
+FORTHSRCS = core.fs cmp.fs print.fs str.fs parse.fs readln.fs fmt.fs z80a.fs \
+	link.fs
 FORTHSRC_PATHS = ${FORTHSRCS:%=../forth/%} forth/run.fs
 OBJS = emul.o libz80/libz80.o
 SLATEST = ../tools/slatest
diff --git a/forth/dict.fs b/forth/dict.fs
deleted file mode 100644
index 4b4ef59..0000000
--- a/forth/dict.fs
+++ /dev/null
@@ -1,18 +0,0 @@
-( Get word header length from wordref. That is, name length
-  + 3. a is a wordref )
-( a -- n )
-: WHLEN
-    1 - C@      ( name len field )
-    0x7f AND    ( remove IMMEDIATE flag )
-    3 +         ( fixed header len )
-;
-
-( Get word addr, starting at name's address )
-: '< ' DUP WHLEN - ;
-
-( Get word's prev offset )
-( a -- a )
-: PREV
-    3 - DUP @                   ( a o )
-    -                           ( a-o )
-;
diff --git a/forth/link.fs b/forth/link.fs
new file mode 100644
index 0000000..bdc434d
--- /dev/null
+++ b/forth/link.fs
@@ -0,0 +1,162 @@
+( depends: cmp, parse
+  Relink a dictionary by applying offsets to all word
+  references in words of the "compiled" type.
+
+  A typical usage of this unit would be to, right after a
+  bootstrap-from-icore-from-source operation, identify the
+  root word of the source part, probably "H@", and run
+  " ' thatword COMPACT ". Then, take the resulting relinked
+  binary, concatenate it to the boot binary, and write to
+  boot media.
+)
+
+( Skip atom, considering special atom types. )
+( a -- a+n )
+: ASKIP
+    DUP @       ( a n )
+    ( ?br or br or NUMBER )
+    DUP <>{ 0x70 &= 0x58 |= 0x20 |= <>}
+    IF DROP 4 + EXIT THEN
+    ( regular word )
+    0x22 = NOT IF 2 + EXIT THEN
+    ( it's a lit, skip to null char )
+    ( a )
+    1 + ( we skip by 2, but the loop below is pre-inc... )
+    BEGIN 1 + DUP C@ NOT UNTIL
+    ( skip null char )
+    1 +
+;
+
+( Get word header length from wordref. That is, name length
+  + 3. a is a wordref )
+( a -- n )
+: WHLEN
+    1 - C@      ( name len field )
+    0x7f AND    ( remove IMMEDIATE flag )
+    3 +         ( fixed header len )
+;
+
+( Get word addr, starting at name's address )
+: '< ' DUP WHLEN - ;
+
+( Relink atom at a, applying offset o with limit ol.
+  Returns a, appropriately skipped.
+)
+( a o ol -- a+n )
+: RLATOM
+    ROT             ( o ol a )
+    DUP @           ( o ol a n )
+    ROT             ( o a n ol )
+    < IF ( under limit, do nothing )
+        SWAP DROP    ( a )
+    ELSE
+        ( o a )
+        SWAP OVER @ ( a o n )
+        -^          ( a n-o )
+        OVER !      ( a )
+    THEN
+    ASKIP
+;
+
+( Relink a word with specified offset. If it's not of the type
+  "compiled word", ignore. If it is, advance in word until a2
+  is met, and for each word that is above ol, reduce that
+  reference by o.
+  Arguments: a1: wordref a2: word end addr o: offset to apply
+             ol: offset limit. don't apply on refs under it.
+)
+( ol o a1 a2 -- )
+: RLWORD
+    SWAP DUP @              ( ol o a2 a1 n )
+    ( 0e == compiledWord )
+    0x0e = NOT IF
+        ( unwind all args )
+        2DROP 2DROP
+        EXIT
+    THEN
+    ( we have a compiled word, proceed )
+    ( ol o a2 a1 )
+    2 +                         ( ol o a2 a1+2 )
+    BEGIN                       ( ol o a2 a1 )
+        2OVER                   ( ol o a2 a1 ol o )
+        SWAP                    ( ol o a2 a1 o ol )
+        RLATOM                  ( ol o a2 a+n )
+        2DUP < IF ABORT THEN    ( Something is very wrong )
+        2DUP =                  ( ol o a2 a+n f )
+        IF
+            ( unwind )
+            2DROP 2DROP
+            EXIT
+        THEN
+    AGAIN
+;
+
+( Get word's prev offset )
+( a -- a )
+: PREV
+    3 - DUP @                   ( a o )
+    -                           ( a-o )
+;
+
+( Copy dict from target wordref, including header, up to HERE.
+  We're going to compact the space between that word and its
+  prev word. To do this, we're copying this whole memory area
+  in HERE and then iterate through that copied area and call
+  RLWORD on each word. That results in a dict that can be
+  concatenated to target's prev entry in a more compact way.
+
+  This copy of data doesn't allocate anything, so H@ doesn't
+  move. Moreover, we reserve 4 bytes at H@ to write our target
+  and offset because otherwise, things get too complicated
+  with the PSP.
+
+  This word prints the top copied address, so when comes the
+  time to concat boot binary with this relinked dict, you
+  can use H@+4 to printed addr.
+)
+( target -- )
+: COMPACT
+    ( First of all, let's get our offset. It's easy, it's
+      target's prev field, which is already an offset, minus
+      its name length. We expect, in COMPACT, that a target's
+      prev word is a "hook word", that is, an empty word. )
+    ( H@ == target )
+    DUP H@ !
+    DUP 1 - C@ 0x7f AND         ( t namelen )
+    SWAP 3 - @                  ( namelen po )
+    -^                          ( o )
+    ( H@+2 == offset )
+    H@ 2 + !                    ( )
+    ( We have our offset, now let's copy our memory chunk )
+    H@ @ DUP WHLEN -            ( src )
+    DUP H@ -^                   ( src u )
+    DUP ROT SWAP                ( u src u )
+    H@ 4 +                      ( u src u dst )
+    SWAP                        ( u src dst u )
+    MOVE                        ( u )
+    ( Now, let's iterate that dict down )
+    ( wr == wordref we == word end )
+    ( To get our wr and we, we use H@ and CURRENT, which we
+      offset by u+4. +4 before, remember, we're using 4 bytes
+      as variable space. )
+    4 +                         ( u+4 )
+    DUP H@ +                    ( u we )
+    DUP .X LF
+    SWAP CURRENT @ +            ( we wr )
+    BEGIN                       ( we wr )
+        DUP ROT                 ( wr wr we )
+        ( call RLWORD. we need a sig: ol o wr we )
+        H@ @                    ( wr wr we ol )
+        H@ 2 + @                ( wr wr we ol o )
+        2SWAP                   ( wr ol o wr we )
+        RLWORD                  ( wr )
+        ( wr becomes wr's prev and we is wr-header )
+        DUP                     ( wr wr )
+        PREV                    ( oldwr newwr )
+        SWAP                    ( wr oldwr )
+        DUP WHLEN -             ( wr we )
+        SWAP                    ( we wr )
+        ( Are we finished? We're finished if wr-4 <= H@ )
+        DUP 4 - H@ <=
+    UNTIL
+;
diff --git a/recipes/rc2014/Makefile b/recipes/rc2014/Makefile
index 8c90203..bfd3d0a 100644
--- a/recipes/rc2014/Makefile
+++ b/recipes/rc2014/Makefile
@@ -6,7 +6,6 @@ STAGE2 = $(EDIR)/stage2
 EMUL = $(BASEDIR)/emul/hw/rc2014/classic
 PATHS = pre.fs \
 	$(FDIR)/core.fs \
-	$(FDIR)/cmp.fs \
 	$(FDIR)/str.fs \
 	$(FDIR)/parse.fs \
 	$(BASEDIR)/drv/acia.fs \
diff --git a/recipes/rc2014/pre.fs b/recipes/rc2014/pre.fs
index a2b807a..ce990dd 100644
--- a/recipes/rc2014/pre.fs
+++ b/recipes/rc2014/pre.fs
@@ -1 +1 @@
-112 RAM+ HERE !
+96 RAM+ HERE !