dumpHEADmain

1 files changed, 58 insertions, 0 deletions

diff --git a/sanctuary.fs b/sanctuary.fs
index 6e54b81..d4d8134 100644
--- a/sanctuary.fs
+++ b/sanctuary.fs
@@ -12,6 +12,12 @@
 \ todo doc
 : 2swap  rot >r rot r> ;
 
+\ todo doc
+hex
+: >byte  ff and ;
+: >word  ffff and ;
+decimal
+
 : not  0= ;
 \ todo doc
 : /  /mod nip ;
@@ -192,6 +198,12 @@ variable hld
 : #  base @ /mod swap 9 over < if 7 + then [ char 0 ] literal + hold ;
 : #s  begin # dup 0= until ;
 : #>  drop hld @ pad$ over - ;
+
+\ todo doc
+: byte  hex  <# # # #> decimal ;
+: word  hex  <# # # # # #> decimal ;
+: dword  hex <# # # # # # # # # #> decimal ;
+: qword  hex <# # # # # # # # # # # # # # # # # #> decimal ;
 \ }}}
 
 \ NONAME {{{
@@ -693,6 +705,52 @@ decimal
 previous definitions
 \ }}}
 
+\ DUMP {{{
+\ todo doc
+also terminal
+
+private{
+
+hex
+\ this should probably be a case block
+: dump-colour ( c -- n )  dup 0= if white else
+	dup 0a = if yellow else
+	dup 0d = if yellow else
+	dup 20 < if red else
+	dup 7f < if green else
+	dup ff < if red else blue
+	then then then then then then nip ;
+
+: dump-char ( c -- c' )  dup 20 < if drop [ char . ] literal else
+	dup 7e >= if drop [ char . ] literal then then ;
+decimal
+
+: a>c  ( a -- a c ; switch fg colour )  dup c@  dup dump-colour foreground ;
+
+: .address  dword type  ." : " ;
+
+: .byte ( a -- a+1 )  a>c byte type  default foreground  1+ ;
+: .word  .byte .byte space ;
+: .hexdump  8 0 do .word loop drop ;
+
+: .char ( a -- a+1 )  a>c dump-char emit  default foreground 1+ ;
+: .asciidump  16 0 do .char loop drop ;
+
+\ it's probably Bad that this word exists
+\ idk what a generalised version of this should be called
+: round-16  16 + 1-  -16 and ;
+
+}private
+
+: dump-line ( a -- )  dup .address  bold  dup .hexdump
+	space  .asciidump  normal cr ;
+\ u is rounded up to the next multiple of 16 (for symmetry reasons)
+: dump ( a u -- )  round-16 16 / 0 ?do dup dump-line 16 + loop drop ;
+privatise
+
+only forth definitions
+\ }}}
+
 \ todo doc
 : .free  bytes-used u. ." of " bytes-allocated u. ." bytes used (" bytes-free (.) type ."  free)" cr ;