programming-tools.f

来自「这个是关于G.726算法的源程序」· F 代码 · 共 117 行

\ Definitions for PROGRAMMING TOOLS words.
\
\ Ommisions: SEE not implemented.
\
\ This code has been placed in the Public Domain by J.D.Medhurst (aka Tixy)

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

: ?   ( 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 charavters
		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 !
;