core-ext.f

这个是关于G.726算法的源程序

\ Definitions for ANS Core Extension words.
\
\ This code has been placed in the Public Domain by J.D.Medhurst (aka Tixy)
\
\ Version 2005-12-27:
\    * Fixed a bug in C" which manifested when the size of a CHAR was not
\      one address unit.

\ ----------------------------------------------------------------------------
\ Number output

: D.R   ( d n -- )   \ DOUBLE wordset
	>R TUCK DABS <# #S ROT SIGN #> R> OVER - SPACES TYPE ;

: .R   ( n1 n2 -- )
	>R S>D R> D.R ;

: U.R   ( u n -- )
	>R 0 R> D.R ;

\ ----------------------------------------------------------------------------
\ Counted string

: (c")   ( -- c-addr )   \ Run-time code for C"
	R> DUP COUNT + ALIGNED >R ;

: CLITERAL   ( c-addr u -- )   \ Implementation factor fo C"
	POSTPONE (c") /COUNTED-STRING MIN
	DUP C, HERE SWAP DUP CHARS ALLOT ALIGN CMOVE
; IMMEDIATE

: C"   ( "ccc<quote>" -- )
	[CHAR] " PARSE POSTPONE CLITERAL ; IMMEDIATE

\ ----------------------------------------------------------------------------
\ CASE-OF

12341 CONSTANT ORIG-MAGIC

12343 CONSTANT CASE-MAGIC

: CASE-CHECK   ( x-- )
	CASE-MAGIC = INVERT -22 AND THROW ;

: CASE   ( C: -- case-sys )
	0 CASE-MAGIC ; IMMEDIATE

: OF   ( C: -- of-sys )
	POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; IMMEDIATE

: ENDOF   ( C: case-sys1 of-sys -- case-sys2 )
	HERE >R
	POSTPONE ELSE 2SWAP CASE-CHECK
	R> CELL+ !
	DROP CASE-MAGIC
; IMMEDIATE

: ENDCASE   ( C: case-sys -- )
	POSTPONE DROP CASE-CHECK
	BEGIN DUP 
	WHILE DUP @ SWAP ORIG-MAGIC POSTPONE THEN 
	REPEAT 
	DROP 
; IMMEDIATE

: WITHIN   ( n1|u1 n2|u2 n3|u3 -- flag )
	OVER - >R - R> U< ;

\ ----------------------------------------------------------------------------
\ VALUE (Not ANS compliant because it is 'state smart')

: VALUE   ( x "<spaces>name" -- )
	CONSTANT ;

: TO   ( x "<spaces>name" -- )   \ NOT STANDARD BECAUSE OF THE USE OF STATE!
	' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; IMMEDIATE

\ ----------------------------------------------------------------------------
\ Source manipulation

: SOURCE-ID   ( -- 0 | -1 )
	>IN CELL+ @ ;

: SAVE-INPUT   ( -- xn ... x1 n )
	SOURCE >IN 2@ 4 ;

: RESTORE-INPUT   ( xn ... x1 n -- flag )
	DROP >IN 2! (source) 2! FALSE ;

: REFILL   ( -- flag )
	FALSE ;

\ ----------------------------------------------------------------------------
\ MARKER

CREATE WORDLISTS FORTH-WORDLIST ,

: PRUNE-WORDLIST   ( addr1 addr2 wid -- addr1 addr2 wid )
	DUP >R @ BEGIN DUP 2OVER WITHIN WHILE DUP @ + REPEAT R@ ! R> ;

: PRUNE-WORDLISTS   ( addr1 addr2 -- )
	WORDLISTS BEGIN @ DUP WHILE PRUNE-WORDLIST CELL+ REPEAT DROP 2DROP ;

: MARKER   ( "<spaces>name" -- )
	LATEST @ HERE CREATE , ,
	CURRENT @ ,
	CONTEXT HERE OVER @ 1+ CELLS DUP ALLOT MOVE
	DOES> HERE >R
	DUP @ HERE - ALLOT
	CELL+ DUP @ LATEST !
	CELL+ DUP @ CURRENT !
	CELL+ CONTEXT OVER @ 1+ CELLS MOVE
	HERE R> PRUNE-WORDLISTS ;

\ ----------------------------------------------------------------------------
\ Miscelaneous

: [COMPILE]   ( "<spaces>name" -- )
	' , ; IMMEDIATE

: .(   ( "ccc<paren>" -- )
	[CHAR] ) PARSE TYPE ; IMMEDIATE