GH-40 Move DUMP from C to Forth.

SirWumpus · Sep 26, 2024 · c094e5a · c094e5a
1 parent 745b5ea
commit c094e5a
Show file tree

Hide file tree

Showing 2 changed files with 58 additions and 51 deletions.
diff --git a/src/post4.c b/src/post4.c
@@ -473,48 +473,6 @@ p4StackDump(FILE *fp, P4_Cell *base, P4_Uint length)
 	}
 }
 
-void
-p4MemDump(FILE *fp, const char *addr, P4_Size length)
-{
-	const char *s;
-	unsigned count;
-
-	s = addr;
-	for (count = 0; count < length; addr++) {
-		if ((count & 0xF) == 0) {
-			/* Format with fixed width hex string, instead
-			 * of as pointer to maintain the dump layout.
-			 */
-			(void) fprintf(fp, P4_H0X_FMT"  ", (long)addr);
-			s = addr;
-		}
-		(void) fprintf(fp, "%.2x", (unsigned char) *addr);
-		if ((++count & 0x1) == 0) {
-			(void) fputc(' ', fp);
-		}
-		if ((count & 0xF) == 0) {
-			(void) fputc(' ', fp);
-			for ( ; s <= addr; s++) {
-				(void) fputc(isprint(*s) ? *s : '.', fp);
-			}
-			(void) fprintf(fp, crlf);
-		}
-	}
-	if ((count & 0xF) != 0) {
-		do {
-			(void) fprintf(fp, "  ");
-			if ((++count & 0x1) == 0) {
-				(void) fputc(' ', fp);
-			}
-		} while ((count & 0xF) != 0);
-		(void) fputc(' ', fp);
-		for ( ; s < addr; s++) {
-			(void) fputc(isprint(*s) ? *s : '.', fp);
-		}
-		(void) fprintf(fp, crlf);
-	}
-}
-
 /***********************************************************************
  *** Double Cell Math
  ***********************************************************************/
@@ -1387,7 +1345,6 @@ p4Repl(P4_Ctx *ctx, int thrown)
 		/* I/O */
 		P4_WORD(">IN",		&&_input_offset,0, 0x01),
 		P4_WORD("ACCEPT",	&&_accept,	0, 0x21),
-		P4_WORD("DUMP",		&&_dump,	0, 0x20),
 		P4_WORD("TYPE",		&&_type,	0, 0x20),
 		P4_WORD("epoch-seconds", &&_epoch_seconds, 0, 0x01),	// p4
 		P4_WORD("FIND-NAME-IN",	&&_find_name_in, 0, 0x31),
@@ -2302,12 +2259,6 @@ _stack_dump:	x = P4_POP(ctx->ds);
 		p4StackDump(stdout, w.p, x.u);
 		NEXT;
 
-		// ( addr u -- )
-_dump:		x = P4_POP(ctx->ds);
-		w = P4_POP(ctx->ds);
-		p4MemDump(stdout, w.s, x.u);
-		NEXT;
-
 		FILE *fp;
 		struct stat sb;
 

diff --git a/src/post4.p4 b/src/post4.p4
@@ -1230,8 +1230,6 @@ DEFER fsp!
 
 VARIABLE _>pic
 
-: _dumppic _pic /HOLD dump ;
-
 \ ( char -- )
 : HOLD _pic _>pic @ + C! 1 _>pic +! ;
 
@@ -2211,6 +2209,21 @@ VARIABLE SCR
 	R> POSTPONE LITERAL	\ C:
 ; IMMEDIATE compile-only
 
+\ (S: char -- bool )
+: isblank DUP '\s' = SWAP '\t' = OR ;
+: iscntrl DUP 0 '\s' WITHIN SWAP $7F = OR ;
+: isprint 32 127 WITHIN ;
+: isspace
+	FALSE
+	OVER '\f' = OR
+	OVER '\n' = OR
+	OVER '\r' = OR
+	OVER '\s' = OR
+	OVER '\t' = OR
+	OVER '\v' = OR
+	SWAP DROP
+;
+
 : stack_new ( u <spaces>name -- ) CREATE 1+ CELLS reserve DUP CELL+ SWAP ! ;
 : stack_tmp ( u -- stack ) 1+ CELLS ALLOCATE THROW DUP DUP CELL+ SWAP ! ;
 : stack_push ( n stack -- ) TUCK @ ! /CELL SWAP +! ;
@@ -2437,6 +2450,49 @@ _fs CONSTANT floating-stack DROP DROP
 \ (S: addr u -- )
 : .cells OVER + SWAP BEGIN 2DUP > WHILE DUP @ $#. CELL+ REPEAT 2DROP ; $20 _pp!
 
+\ (S: end beg -- )
+: _dump_chars
+	BEGIN 2DUP U> WHILE
+	  DUP C@ DUP isprint 0= IF
+	    DROP '.'
+	  THEN EMIT
+	  1 CHARS +
+	REPEAT 2DROP
+; $20 _pp!
+
+\ (S: end beg -- )
+: _dump_pad
+	16 CHARS + SWAP			\ S: e b'
+	BEGIN 2DUP U> WHILE
+	  S\" \s\s\s" TYPE
+	  1 CHARS +
+	REPEAT 2DROP
+; $20 _pp!
+
+\ (S: end beg -- )
+: _dump_row
+	DUP >R 16 CHARS +		\ S: e b"		R: b
+	2DUP U> IF NIP ELSE DROP THEN	\ S: e'			R: b
+	R> 2DUP 2>R			\ S: e' b		R: e' b
+	DUP $. BL EMIT
+	BEGIN 2DUP U> WHILE		\ S: e' b		R: e' b
+	  DUP C@ .			\ S: e' b		R: e' b
+	  1 CHARS +			\ S: e' b'		R: e' b
+	REPEAT 2DROP
+	2R@ _dump_pad 2R> BL EMIT _dump_chars CR
+; $20 _pp!
+
+\ (S: addr u -- )
+: DUMP
+	CHARS OVER + SWAP		\ S: a' a
+	BASE @ >R HEX
+	BEGIN 2DUP U> WHILE
+	  2DUP _dump_row
+	  16 CHARS +
+	REPEAT
+	2DROP R> BASE !
+; $20 _pp!
+
 \ (S: xt -- bool )
 : xt?
    _ctx ctx.words @