Refactor helper word for left and right justification - %EXECUTE-JL a…

…nd %EXECUTE-JR - #29
ikysil · Sep 24, 2017 · b4c126e · b4c126e
1 parent 3ae9d98
commit b4c126e
Show file tree

Hide file tree

Showing 2 changed files with 33 additions and 26 deletions.
diff --git a/lib/~ik/float-output.4th b/lib/~ik/float-output.4th
@@ -58,25 +58,14 @@ ONLY FORTH DEFINITIONS ALSO FLOAT-OUTPUT-PRIVATE
 : %FSL (S uw -- ) (F r -- )
    \G Append string representation of floating point number r to the current formatted string.
    \G The string representation is left justified in the field of minimum width uw.
-   %CURR NIP + >R
-   %FS
-   %CURR NIP R> SWAP - 0 MAX %SPACES
+   ['] %FS %EXECUTE-JL
 ;
 
 
 : %FSR (S uw -- ) (F r -- )
    \G Append string representation of floating point number r to the current formatted string.
    \G The string representation is right justified in the field of minimum width uw.
-   %CURR CHARS + >R          \ S: uw                 R: c-addr1
-   %FS
-   %CURR CHARS +             \ S: uw c-addr2         R: c-addr1
-   DUP R@ - DUP >R           \ S: uw c-addr2 uf      R: c-addr1 uf
-   ROT CHARS SWAP - 0 MAX    \ S: c-addr2 usp        R: c-addr1
-   NIP DUP %SPACES           \ S: usp                R: c-addr1 uf
-   R> R@ ROT                 \ S: uf c-addr1 usp     R: c-addr1
-   DUP >R                    \ S: uf c-addr1 usp     R: c-addr1 usp
-   OVER + ROT MOVE           \ S:                    R: c-addr1 usp
-   R> R> SWAP BL FILL
+   ['] %FS %EXECUTE-JR
 ;
 
 
@@ -140,25 +129,14 @@ ONLY FORTH DEFINITIONS ALSO FLOAT-OUTPUT-PRIVATE
 : %FEL (S uw -- ) (F r -- )
    \G Append string representation of floating point number r using engineering notation to the current formatted string.
    \G The string representation is left justified in the field of minimum width uw.
-   %CURR NIP + >R
-   %FE
-   %CURR NIP R> SWAP - 0 MAX %SPACES
+   ['] %FE %EXECUTE-JL
 ;
 
 
 : %FER (S uw -- ) (F r -- )
    \G Append string representation of floating point number r using engineering notation to the current formatted string.
    \G The string representation is right justified in the field of minimum width uw.
-   %CURR CHARS + >R          \ S: uw                 R: c-addr1
-   %FE
-   %CURR CHARS +             \ S: uw c-addr2         R: c-addr1
-   DUP R@ - DUP >R           \ S: uw c-addr2 uf      R: c-addr1 uf
-   ROT CHARS SWAP - 0 MAX    \ S: c-addr2 usp        R: c-addr1
-   NIP DUP %SPACES           \ S: usp                R: c-addr1 uf
-   R> R@ ROT                 \ S: uf c-addr1 usp     R: c-addr1
-   DUP >R                    \ S: uf c-addr1 usp     R: c-addr1 usp
-   OVER + ROT MOVE           \ S:                    R: c-addr1 usp
-   R> R> SWAP BL FILL
+   ['] %FE %EXECUTE-JR
 ;
 
 
@@ -188,6 +166,7 @@ REPORT-NEW-NAME !
 
 \EOF
 
+123.e       <% %CR '|' %c %fs  '|' %c %> type
 123.e    25 <% %CR '|' %c %fsl '|' %c %> type
 123.e    25 <% %CR '|' %c %fsl '|' %c %> type
 -123.e   25 <% %CR '|' %c %fsr '|' %c %> type

diff --git a/lib/~ik/sformat.4th b/lib/~ik/sformat.4th
@@ -132,6 +132,34 @@ INT/COMP: %S" (S chars" -- )
 ;
 
 
+: %EXECUTE-JL (S uw xt -- )
+   \G Execute xt and append string representation produced by the execution of xt to the current formatted string.
+   \G xt is expected to produce the output to the current formatted string.
+   \G The string representation is left justified in the field of minimum width uw.
+   SWAP
+   %CURR NIP + >R
+   EXECUTE
+   %CURR NIP R> SWAP - 0 MAX %SPACES
+;
+
+
+: %EXECUTE-JR (S uw xt -- )
+   \G Execute xt and append string representation produced by the execution of xt to the current formatted string.
+   \G xt is expected to produce the output to the current formatted string.
+   \G The string representation is right justified in the field of minimum width uw.
+   %CURR CHARS + >R          \ S: uw xt              R: c-addr1
+   EXECUTE
+   %CURR CHARS +             \ S: uw c-addr2         R: c-addr1
+   DUP R@ - DUP >R           \ S: uw c-addr2 uf      R: c-addr1 uf
+   ROT CHARS SWAP - 0 MAX    \ S: c-addr2 usp        R: c-addr1
+   NIP DUP %SPACES           \ S: usp                R: c-addr1 uf
+   R> R@ ROT                 \ S: uf c-addr1 usp     R: c-addr1
+   DUP >R                    \ S: uf c-addr1 usp     R: c-addr1 usp
+   OVER + ROT MOVE           \ S:                    R: c-addr1 usp
+   R> R> SWAP BL FILL
+;
+
+
 : %SIGN (S n -- )
    \G Append character '-' (minus) to the current formatted string if n is negative.
    0<  IF  [CHAR] - %C  THEN