\ Definitions for ANS Core Extension words.
\
\ Version 2005-12-27:
\    * Fixed a bug in C" which manifested when the size of a CHAR was not
\      one address unit.
\
\ 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.

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