core-ext.f

Tixys source code, include G.711, G.726, IMA-ADPCM etc.

\ Definitions for ANS Core Extension words.
\
\ This code has been placed in the Public Domain by J.D.Medhurst (a.k.a. Tixy)

\ -------------------------------------------------------------------------
\ 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 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