\ Definitions for PROGRAMMING TOOLS words.
\
\ Ommisions: SEE not implemented.
\
\ This program is distributed under the terms of the 'MIT license'. The text
\ of this licence follows...
\
\ Copyright (c) 2005 J.D.Medhurst (a.k.a. Tixy)
\ 
\ Permission is hereby granted, free of charge, to any person obtaining a copy
\ of this software and associated documentation files (the "Software"), to deal
\ in the Software without restriction, including without limitation the rights
\ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
\ copies of the Software, and to permit persons to whom the Software is
\ furnished to do so, subject to the following conditions:
\ 
\ The above copyright notice and this permission notice shall be included in
\ all copies or substantial portions of the Software.
\ 
\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
\ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
\ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
\ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
\ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
\ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
\ THE SOFTWARE.


\ ----------------------------------------------------------------------------

: ?   ( a-addr -- )
	@ . ;

: .S   ( -- )
	CR
	DEPTH
	DUP 0< IF ." Stack underflow!" EXIT THEN
	32   \ Max elements to show
	2DUP U> IF ." ... " NIP ELSE DROP THEN
	BEGIN
		DUP
	WHILE
		DUP PICK .
		1-
	REPEAT
	DROP
;

\ ----------------------------------------------------------------------------
\ Implementation of DUMP

16 CONSTANT DUMP-WIDTH   \ Number of chars to dump per line

\ HERE TRUE C, C@   CONSTANT MAX-CHAR   \ Maximum value of a char

: FOR-EACH-DIGIT   ( u xt -- )
	\ Execute xt a number of times equal to the number of digits it would
	\ take to display u
	BEGIN
		2>R R@ EXECUTE 2R>
		SWAP 0 BASE @ UM/MOD NIP SWAP   \ divide u by BASE
		OVER 0=
	UNTIL
	2DROP
;

: U.PAD   ( u1 u2 -- ) \ Print u1 using same number of digits as u2 would take
	>R
	0 <# BL HOLD 
	R> ['] # FOR-EACH-DIGIT
	#> TYPE
;

: DUMP-ADDRESS   ( addr -- )
	TRUE U.PAD ;

: DUMP-MEMORY   ( c-addr u -- c-addr u )   \ Dump char values
	DUMP-WIDTH 0
	DO
		I 3 AND 0= IF SPACE THEN   \ Add a space every 4 chars
		I OVER U<
		IF
			\ Display char value...
			OVER I CHARS + C@
			MAX-CHAR U.PAD
		ELSE
			\ Padding for absent char...
			MAX-CHAR ['] SPACE FOR-EACH-DIGIT
			SPACE
		THEN
	LOOP
	SPACE
;

: DUMP-CHARS   ( c-addr u -- )   \ Dump characters
	0 ?DO
		DUP C@
		DUP BL U> 0=
		IF DROP [CHAR] . THEN   \ use dot for non-displayable characters
		EMIT
		CHAR+
	LOOP
	DROP
;

: DUMP-LINE   ( c-addr u -- )
	DUP DUMP-WIDTH U>
	IF DROP DUMP-WIDTH THEN
	OVER DUMP-ADDRESS
	DUMP-MEMORY
	DUMP-CHARS
	CR
;

: MAKE-CHAR-RANGE   ( addr1 u1 - c-addr2 u2 )
	\ Turn address range addr1 u1 into character aligned range c-addr2 u2
	OVER +                             \ Turn u into end address
	0 1 CHARS UM/MOD SWAP IF 1+ THEN   \ Make end into character index
	SWAP 0 1 CHARS UM/MOD NIP SWAP	   \ Make start address character index
	OVER -                             \ Turn end into character count u
	SWAP CHARS SWAP                    \ Turn start onto c-addr
;

: DUMP   ( addr u -- )
	MAKE-CHAR-RANGE
	BASE @ >R
	HEX
	BEGIN
		2DUP DUMP-LINE
		DUP DUMP-WIDTH U>
	WHILE
		DUMP-WIDTH -
		SWAP DUMP-WIDTH CHARS + SWAP
	REPEAT
	2DROP
	R> BASE !
;