	Glossary of "", ver 1-0-6+16  -  Don Mr 28 12:47:22 GMT 2002
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


 <hda6-x/usr/src/forth/lib4th/src/lib4th.asm>
--------------------------------------------------------------------------

 %define __ANS	; assemble ANS-std defaults & initiation, else (fig-)forth
 %undef  __ANS	; preferrably, set switch in Makefile - ANS is default

 %include "lib4words.asm"
 to programming with "lib4th" is what "..h" headerfiles inclusion
 is to "C"-ish source programming. It should be included prior to
 any code writen in an application program, prior to .text section.

================================================================
  kernel code
  basic, initial references

 Y						(k)
	1st address in .text, <kref> local to lib4th
	this address stores lib4th kernel+headers size, <Y> until <YE>.

================================================================
 -- debugging

 -- debugging ends
================================================================
 -- text, cc4th, see decoding

================================================================================
 -- host definitions source file names :

================================================================================
 -- ctrlchars, ctrlbits, stty sane :

================================================================
 -- syscall names
	src/sys_{os-name}.inc
 -- vt ctrl stg-s
	src/l4vtseq.inc
	! do not change names and sequence labels/data !

================================================================
 -- signals constants and error messages, jumptables
    by macros <ertstg>, <ertdsp>, <sigstg>, <sigdsp>
	src/l4ersigt.inc

================================================================
 -- signal handlers & setup
	src/l4sighnd.inc

================================================================
 -- initial memory setup, yet all preliminary and highly experimental!
 -- program initialization, jobs setup & control

 <nimp>

 getrefb	( -- )				(k)				system
	restore kernel library reference register (KR=ebx)
	subroutines, 4th-words, all data refer to this address;
	for direct 4th/asm programming, single one non-relative reference.

 -- end of initial lo-level routines
================================================================
 -- basic memory allocation in .ss and .bss

================================================================

 -- error handling, messages.

================================================================
 -- memory

================================================================
 -- m-tasking

================================================================
 -- i/o port access

================================================================
 -- system time

================================================================
 -- constants

----------------------------------------------------------------
 -- save/restore input
 -- file/devices i/o support, operations refer to {work} channel
 -- i/o channels & redirection, tests

	re man(2) fcntl, ioctl, open, close
	(Vorsicht: einige "man de"-Seiten enthalten fehler!)
	error code is any -ve value, non-error results dependent on opr.
	

----------------------------------------------------------------
 -- i/o source, block, screenfile support
 -- the f.i.g. line editor (n.i.)

----------------------------------------------------------------
 -- vt... and ctrl sequences
	

----------------------------------------------------------------
 -- standard i/o (more or less...)

================================================================
-- basic data-stack opr

--------------------------------------------------------------------
--  returnstack
	push/pop to returnstack adds/subtracts <kref> value
	2>r, r> r> cannot be used to swap cells! re {rswap}.

================================================================
--  memory access
	false data may result if F8 stacks accessed directly!
	explicit addresses shall be passed as ptr's wrt kref.
	fetched data items not sign extended, unless mentioned.

================================================================
--  arithmetic logic opr

================================================================
-- arithmetic opr

	

----------------------------------------------------------------
-- mixed quad and double
	
	

================================================================
-- multi praecision opr

----------------------------------------------------------------
-- number conversion

---------------------------------------------------------------------------------
-- assembler cons

================================================================
-- kernel and user vari/cons

================================================================
-- search order
	unless mentioned all vocabularies belong to {root},
	{root} vocabulary is sub-vocabulary of itself.
	lib4th supplied vocabularies are set "immediate".
	

----------------------------------
--  tools
	

================================================================
-- text acquisition, strings, search & substitution

	

================================================================
-- interpreter, word headers structure
	conversion words all but {idx>lfa} & {>body} in {hidden}.

------------------------------------------------------------------------
-- interpreter, forget, find
	

------------------------------------------------------------------------
	

----------------------------------------------------------------
 -- local memory
	<top> @s0[ data-stack ... tos]			- no locals
	<top> ..locals.. @s0[ data-stack ... tos]	- locals allocated
	most recent local data allocated @s0, stack content moved "up".
	ptr to <top> is absolute low limit for @s0 and locals and, can be
	used to control error situations if stack-ptrs became un-certain.
	

----------------------------------------------------------------
 -- word header, defining words ---
	

----------------------------------------------------------------
 -- control structures
	
----------------------------------------------------------------

================================================================

-- initial wordlist

================================================================
	library system memory, not accessible, i.e. no .data, no .bss! 
	256-alignment required, <YE> is final label 

================================================================
 lib4th.asm <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/f8ed.asm>
--------------------------------------------------------------------------

================================================================

 section .text	; kernel code & constant data

================================================================
 debugging

 dbg		beginning of debugging routines

 debugging routines end
================================================================

================================================================
 (ref's to) signals constants and error messages, jumptables
 by macros <ertstg>, <ertdsp>, <sigstg>, <sigdsp>

================================================================
 execution entry

 zero in <START4TH> or, optional structure w. initial memory setup and entry:

================================================================
 end of program area
	initated data and (local) .bss may follow

================================================================
 f8.asm <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/f8.asm>
--------------------------------------------------------------------------

================================================================

 section .text	; kernel code & constant data

================================================================
 debugging

 dbg		beginning of debugging routines

 debugging routines end
================================================================

================================================================
 (ref's to) signals constants and error messages, jumptables
 by macros <ertstg>, <ertdsp>, <sigstg>, <sigdsp>

================================================================
 execution entry

 zero in <START4TH> or, optional structure w. initial memory setup and entry:

================================================================
 end of program area
	initated data and (local) .bss may follow

================================================================
 f8.asm <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/calc4th.asm>
--------------------------------------------------------------------------

	using any of the supplied lib4th macroes this 
	mustn't be defined unless in library source!

================================================================
 calc4th.asm <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4alogic.inc>
--------------------------------------------------------------------------


================================================================
--  arithmetic logic opr
	

 <>		( u1 u2 -- flg )		(a:cx)		'nequal'	ans
	tf if u1 not equal to u2

 =/=		( u1 u2 -- flg )		(m,11)		'nequal'	forth
	tf if u1 not equal to u2

 0<>		( u1 -- flg )			(a)		'zneq'		ans

 0=/=		( u1 -- flg )			(m,9)		'zneq'		forth
	tf if u1 non-zero

 -0=		( u1 -- flg )			(m,11)		'mzeq'		forth
	tf if only sign bit (m.s.bit) set of u1

 true=  	( flg -- flg )			(m,9)		'tequ'		fig
	test f.i.g. true flag = 1

 true=  	( flg -- flg )			(m,9)		'tequ'		forth
	test ans-4th true flag = -1

 0and		( n -- 0 )			(m,5)		'dng'		hidden
	{ drop 0 }

 =		( u1 u2 -- flg )		(m,12)		'equal'		forth
	tf if u1 = u2

 0=		( u1 -- flg )			(m,8)		'zeq'		forth
	tf if u1 =  0

 [0=]		( u1 -- flg )			(i)		'zeq'		ans
	"immediate"ly execute {0=}

 0>		( u1 -- flg )			(m,5)		'zgreat'	forth
	tf if u1 +ve and non-zero

 0<		( u1 -- flg )			(m,3)		'zless'		forth
	tf if u1 -ve

 <		( n1 n2 -- flg )		(m,15)		'less'		forth
	tf if signed n1 < n2

 within? 	( x1 x2 x3 -- x4 f )						forth
	x4 := x2 and tf if  x2 <= x1 < x3, whether signed or unsigned,
	if out of range ret x4 signed adjusted to the nearest bound and ff.

 uwithin? 	( x1 x2 x3 -- x4 f )						forth
      x2 <= x1 < x3, signed or unsigned, x4:=x1 anf tf if in range
	if out of range ret x4 unsigned adjusted to the nearest bound.

 within 	( x1 x2 x3 -- flg )		(a:c)				forth
		( test low high -- flag )
	tf if x2 <= x1 < x3, signed or unsigned. - ANS-word

 u<		( u1 u2 -- flg )		(m,13)		'uless'		forth
	tf if unsigned u1 < u2

 >		( n1 n2 -- flg )		(m,17)		'greater'	forth
	tf if signed n1 < n2

 u>		( u1 u2 -- flg )		(m,13)		'ugreater'	forth
	tf if unsigned u1 > u2

 sgn		( n1 -- -1|0|1 )		(m,11)				forth
	signum of n1

 parity  	( n1 -- flg )			(m,12)				forth
	ff if n1 w/ odd number of set bits

 l-and  	( n1 n2 -- flg )				'land'		forth
	logic AND, tf only if n1 =/= 0 and n2 =/= 0.

 l-or   	( n1 n2 -- flg )				'lor'		forth
	logic OR, ff only if n1 = 0 and n2 = 0.

-- 

 ?udcmp	( d1 d2 -- d1 d2 f )		(e)		'qudcmp'	forth
	flag f from unsigned comparison, f=1 if d2 u< d1, f=-1 if d1 u< d2.
	{ d1 d2 -- ) 2over 2over du> if 1 else 2over 2over d= 0= endif ( -- d1 d2 f }

 dsgn		( d1 -- -1|0|1 )						forth
	signum of d1

 d>		( d1 d2 -- flg )		(m,17)(e)	'dgreat'	forth
	tf if signed d1 greater than d2
	(e: NZ*S if d1>d2, else Z*NS, flg is S from d2-d1

 d<		( d1 d2 -- flg )		(a:d)(e)	'dless'		forth
	tf if signed d1 smaller than d2
	(e: NZ*S if d1<d2, else Z*NS, flg is S from d1-d2

 du>		( d1 d2 -- flg )		(m,14)(e)	'dugreat'	forth
	tf if unsigned d1 greater than d2
	(e: NZ*S if d1 u> d2, else Z*NS, flg is C from d2-d1

 du<		( d1 d2 -- flg )		(a:dx)(m,14)(e)	'duless'	forth
	tf if unsigned d1 smaller than d2
	(e: NZ*S if d1 u< d2, else Z*NS, flg is C from d1-d2

 d0>		( d1 -- flg )			(e)		'dzgt'		forth
	tf if d1 non-zero +ve
	(e: eflags from <test m.s.cell>

 d0<		( d1 -- flg )			(a:d)(m,6)(e)	'dzless'	forth
	tf if d1 -ve
	(e: NZ*S if d1 < 0, else NS+Z

 ?d0=		( d1 -- d1 flg )		(e)		'qdzeq'		forth
	leave d1 unchanged, ret tf if d1 equal to zero
	(e: Z if d1 = 0

 d0=		( d1 -- flg )			(a:d)(m,14)(e)	'dzeq'		forth
	tf if d1 equal to 0
	(e: Z if d1 = 0

 D0<>		( d1 -- flg )			(a)		'dzneq'		ans

 d0=/=  	( d1 -- flg )			(m,13)(e)	'dzneq'		forth
	tf if double, dx1 is non-zero
	(e: NZ if d1 =/= 0

 d=		( d1 d2 -- flg )		(79)(a:d)(e)	'deq'		forth
	tf if d1 equal to d2
	(e: Z if d1=d2

 D<>		( d1 d2 -- flg )				'dneq'		ans
	tf if d1 not equal to d2

 d=/=		( d1 d2 -- flg )				'dneq'		forth
	tf if d1 not equal to d2

 dparity	( d1 -- flg )							forth
	ff if d1 w/ odd number of set bits

================================================================
-- binary logic opr

 1abs		( n -- +n )			(f6)(m,6)	'abs1'		forth
	absolute value wrt one-s complement - {invert} if -ve

 not		( u1 -- u2 )					'invert'	fig
	return u2 1-s complement to u1

 invert  	( u1 -- u2 )			(a:c)(m,2)	'invert'	forth
	return u2 1-s complement to u1

 d1abs  	( d1 -- +d1 )			(m,9)				forth
	ret one-s complement of double if -ve

 2not		( ud1 -- ud2 )			(f6)(m,5)	'dnot'		fig
	return ud2 1-s complement of ud1

 2invert	( ud1 -- ud2 )			(f6)(m,5)	'dnot'		forth
	return ud2 1-s complement of ud1

 and		( u1 u2 -- u3 )			(m,6)		'aand'		forth
	bitwise <and> u1 w/ u2

 2and		( d1 d2 -- d3 )			(f6)		'twoand'	forth
	bitwise <and> d1 w/ d2

 or		( u1 u2 -- u3 )			(m,6)		'oor'		forth
	bitwise <or> u1 w/ u2

 2or		( d1 d2 -- d3 )			(f6)		'twoor'		forth
	bitwise <or> d1 w/ d2

 xor		( u1 u2 -- u3 )			(m,6)		'xxor'		forth
	bitwise <xor> u1 w/ u2

 2xor		( d1 d2 -- d3 )			(f6)		'twoxor'	forth
	bitwise <xor> d1 w/ d2

 andx	( n1 n2 n3 -- n4 )					'andx'		forth
	n4 := (( n1 AND n2 ) XOR n3 )

 toggle  	( p c -- )			(fg)				fig
	xor byte at ptr p with byte c
	(fig-4th opr w. inverse operands order: byte c @tos, ptr @nos)

 and!		( n p -- )			(f6)		'ands'		forth
	<and> n to cell at p in memory

 or!		( n p -- )			(f6)		'ors'		forth
	<or> n to cell at p in memory

 xor!		( n p -- )			(f6)		'xors'		forth
	<xor> n to cell at p in memory

 on		( p -- ) 			(83)(m,)			forth
	store -1 to cell at p

 off		( p -- ) 			(83)(m,)			forth
	store 0 to cell at p

 @0=		( p -- flg )			(m,)		'zeqf'		forth
	tf if cell @ptr p is zero

=====================================================================;
 l4alogic.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4assembler.inc>
--------------------------------------------------------------------------

-- assembler cons

 <call>  	( -- n )			(m,6)		'lcallg'	assembler
	<call pc-rel> processor code, 
	use{ ( ptr -- ) <call> 1, c-here 4+ - 4, } 
	cpl call by uot index w/ -re- {[,]}

 <nop>  	( -- n )			(m,6)		'lnopg'		assembler
	<nop> processor code

 <ret>  	( -- n )			(m,6)		'lretg'		assembler
	<ret> processor code
	

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4bignum.inc>
--------------------------------------------------------------------------


----------------------------------------------------------------
-- memory

 n@+		( p1 -- p2 .xx. N )				'nfetchp'	bignum
	fetch counted int from memory w/ count at l.s.cell
	ret p2 as p1 advanced by size of N+1 cells.

 n@		( p -- .xx. N )					'nfetch'	bignum
	fetch counted int from memory w/ count at l.s.cell

 n!+		( .x. N p1 -- p2 )				'nstorep'	bignum
	store counted int w/ count at l.s.cell to memory
	ret p2 as p1 advanced by size of N+1 cells.

 n!		( .x. N p -- )					'nstore'	bignum
	store counted int w/ count at l.s.cell to memory

 s>m		( n1..nn p n -- )				'stom'		forth
	store n bytes from tos to memory location p
	beginning w. cell aligned n1

 nn>r		( n1..nn N -- )(R: -- nn..n1 N M )		'ntor'		bignum
	transfer counted cells group from tos to tor, additioanlly store items count M
	does{ dup 1+ dup minus roll dup 2 + n>r }

 n>r		( n1..nn n -- )(R: -- nn..n1 )			'ntor'		forth
	transfer n cells from tos to tor, ready to fetching back w. {r>}, etc.

 nnr>		( -- n1..nn N )(R: n1..nn N M -- )		'nnrfrom'	bignum
	transfer counted cells group from tor to tos, as stored w. {nn>r}.
	does{ r> nr> }

 nr>		( n -- n1..nn )(R: nn..n1 -- )			'nrfrom'	forth
	transfer n cells from tor to tos

 nr@		( n -- n1..nn )(R: nn..n1 -- )			'nrfetch'	forth
	copy n cells from tor to tos

 n@sp		( .n.N ... .m.M n(n) -- .n.N ... .m.M n2 )	'nnposn'	bignum hidden
	find disp n2 to <pick> the multi-cell item no. n(n)

 nnsdrop	( .n.N .m.M -- .m.M )						bignum
	drop next @tos counted int item

 n2dup  	( .nn.N .mm.M -- .nn.N .mm.M .nn.N .mm.M )	'nn2dup'	bignum
	duplicate top two multi-cell integers (4th, by { nnover nnover })

 nnover 	( .nn.N .mm.M -- .nn.N .mm.M .nn.N )				bignum
	copy next on tos counted int to tos

 nnpick 	( .xX .mM .. .nn.N m -- .xX .mM .. .nn.N .mm.M )		bignum
	m > 0: copy indexed counted int to tos, { 0 nnpick } == { nndup }.
	m < 0: replace indexed item by counted int @tos.

 nn-rot 	( .n.N .m.M .o.O -- .o.O .n.N .m.M .o.O )	'nnmrot'	bignum
	roll counted int @tos to 3rd, by { -2 nnroll }.

 nnrot  	( .n.N .m.M .o.O -- .m.M .o.O .n.N )				bignum
	roll 3rd counted int to tos, by { 2 nnroll }.

 nnswap 	 ( .nn.N .mm.M -- .mm.M .nn.N )					bignum
	exchange top two counted ints at tos, by { 1 nnroll }.

 nnroll 	( .nn.N .xx.N-1 ... .mm.M n -- .xx.N-1 ... .mm.M .nn.N )	bignum
	n > 0: roll indexed counted int to tos, { 1 nnroll } == { nnswap }.
	n < 0: roll counted int @tos into indexed stack posn

 nndup  	( nn..n0 +N -- nn..n0 +N nn..n0 +N )		(f6)		bignum
	duplicate +N cells sized multi-cell integer, 0 < N < 32768 cells.

 ndup		( nn..n0 m -- nn..n0 nm..n0 )	(f6)				forth
	duplicate group of 0 < n < 32768 cells,
	else drop group of 0 > n > -32768 cells

----------------------------------------------------------------
-- (signed) numbers, counted 'multi-cell integers'

 nndrop 	( .xx. N ... .xx. M n -- )					bignum
	drop n counted int-s

 n->q		( .n.N -- qn )					'n2q'		bignum
	signed extend/truncate bignum to un-counted quad

 q->n		( qn -- .n.N )			(m,6)		'q2n'		bignum
	convert un-counted quad to bignum

 2q->2n 	( q1 q2 -- .n1.N .n2.M )			'q22n'		bignum
	convert a pair of un-counted quads to bignum

 2q->2un 	( q1 q2 -- .n1.N .n2.M )			'q22un'		bignum
	convert a pair of un-counted quads to unsigned bignum

 2n->2q 	( .n1.N .n2.M -- q1 q2 )			'n22q'		bignum
	signed extend/truncate two bignums to un-counted quad

 2n->2uq 	( .n1.N .n2.M -- q1 q2 )			'n22uq'		bignum
	unsigned extend/truncate two bignums to un-counted quad

 nn->dd 	( .nn.N .mm.M -- .nn .mm )			'n22d'		bignum
	convert two bignums to un-counted data

 n->un  	( .n.N -- .un.M )				'n2un'		bignum
	convert signed to unsigned bignum: if .n.N < 0 push top cell := 0, M := N+1

 n->n		( .nn1. N M -- .nn2. M )			'nton'		bignum
	truncate/signed extend from +N cells to +M cells size

 un->un 	( .un1. N M -- .un2. M )			'untoun'	bignum
	unsigned extend/truncate from +N cells to +M cells size

 n->		( .nn1. N -- .nn2. N2 )				'ntoq'		bignum
	reduce multi-cell signed integer to smallest size w/o. loss of precision

 nminus  	( n1..nn n -- m1..mn n )	(4)				bignum
	2-s cpl of group of n cells on tos

 ninvert	( n1..nn n -- m1..mn n )	(4)				bignum
	1-s cpl of group of n cells on tos

 nabs		( n1..nn n -- n1'..nn' n )	(4)				bignum
	negate counted integer if -ve

 n+-		( n1..nn n m -- n1'..nn' n )	(4)		'npm'		bignum
	apply sign of sing m to counted integer

 n0=		( n1..nn N -- flg )				'nzeq'		bignum
	test group of n cells on tos for all zero

 ?n0=		( .n.N -- .n.N f )				'qnzeq'		bignum
	non-destructively test group of n cells on tos for all zero

 n=		( n1..nn N m1..mn M -- flg )	(e)		'neq'		bignum
	compare two groups of n=m cells ea, on tos.
	normalizing for signed multi-cell integers if n=/=m.
	(e: Z if n.N = m.M

 n0>		( n1..nn n -- flg )				'nzgt'		bignum
	test group of n cells on tos for +ve non-zero bignum

 n0<		( n1..nn n -- flg )				'nzlt'		bignum
	test group of n cells on tos for -ve bignum

 ?ncmp  	( .n.N .m.M -- .n.N .m.M flg )	(4)(e)		'qncmp'		bignum
	normalize and non-destructively signed compare two counted integers, on tos.
	ret flg according to sgn(subtraction)
	(e: eflags reflect sgn(flg)

 ncmp		( n1..nn n m1..mn m -- flg )	(4)(e)				bignum
	normalize and signed compare two counted integers, on tos.
	ret flg according to sgn(subtraction)
	(e: eflags reflect sgn(flg)

 nsgn		( n1..nn n -- f )		(e)				bignum
	ret signum of counted int, .n.N <0: f:=-1, =0:f:=0, >0: f:=1.
	(e: eflags reflect sgn(flg)

 nnorm  	( n1..nn N m1..mn M -- n1..nn N m1..mn N )			bignum
	adjust two counted integers to minimal, equal size w/o loss of precision.

 n1+		( n1..nn N -- m1..mn N )			'nonep'		bignum
	increment multi precision integer of n cells on tos by one

 n1-		( n1..nn N -- m1..mn N )			'nonem'		bignum
	increment multi precision integer of n cells on tos by one

 n-		( n1..nn N m1..mn M -- k1..kn N )		'nsub'		bignum
	subtract normalize multi precision integers of N cells ea, on tos.

 n+		( n1..nn N m1..mn M -- k1..kn N )		'nadd'		bignum
	add normalized multi precision integers of N cells ea, on tos.

 lg(nn) 	( n1..nn N nm -- nk )		(4)		'lgnn'		bignum
	ret nk := numerus lg(.n.N) to the base of nm,
	i.e nk := count of digits the rsp number would be converted to at radix of nm.
	only conventionally named "lg" after "logarithm" - which this opr yields not!

 s>nfactorial	( u -- .ux. n )					's2nfac'	bignum
	factorial of n,
	u*(u-1)*...(u-(u-1)) counted integer .ux. n from sing integer u.

 uns/mod	( n0..nn N m -- q0..qn N rm )			'unsbym'	bignum
	unsigned divide multi-cell dividend by sing divisor, 
	leave sing rmd & N-sized quot.
	ret +ve or -ve max if m=0; rm:=0 if N=0; trivial case div-1

 uns*		( n0..nn N m -- p0..pn ov P )			'unsmul'	bignum
	unsigned multiply counted int by sing, 
	leave P:=(N+1) sized prod; P:=0 if N=0; trivial cases mul 1, mul 0

 nshift 	( nm .. n0 M -s -- ov n0' .. nm' M+1 )				bignum
	 	( nm .. n0 M +s -- n0' .. nm' ov M+1 )
	n > 0: -re- {nlshift}
	n < 0: -re- {nrshift}

 nrshift 	( nm .. n0 M +n -- ov n0' .. nm' +(M+1) )			bignum
	right shift block of M cells by unlimited +ve no. n bits, leave ovf bits in ov.
	NOTE: this is a bit-wise op which might be used for but, is not "arithmetic".

 nlshift 	( nm .. n0 M +n -- n0' .. nm' ov +(M+1) )			bignum
	left shift block of m cells by unlimited +ve no. n bits, leave ovf bits in ov.
	NOTE: this is a bit-wise op which might be used for but, is not "arithmetic".

 n2*		( .nn. n -- .mm. m )				'nn2mul'	bignum
	multiply counted int by 2

 n2/		( .nn. n -- .mm. m )				'nn2div'	bignum
	unsigned divide counted int by 2

 n/2^32 	( .n.N -- .m.N-1 )				'nd32'		bignum
	n:=n/(2^32), divide counted int by cell-size (2^32)
	does{ dup roll drop 1- }, ret n={0,1} if N u< 2

 n*2^32  	( .n.N -- 0.n.N+1 )				'nm32'		bignum
	n:=n*(2^32), multiply counted int by cell-size (2^32)
	does{ 0 over not roll 1+ }

 n*		( .nn. N .mm. M -- .xx. X )	(4)		'nmul'		bignum
	signed multiply two counted integers

 n^		( n.N m -- x.X )		(4)		'npow'		bignum
		raise counted int n.N to the power of sing m.

 n/	  	( .d.D .s.S -- .q.Q )		(4)		'nby'		bignum
	signed division of dividend .d.D by divisor .s.S, leaves quot .q.Q.

 n/mod  	( .dD .sS -- .rR .qQ )		(4)		'nbym'		bignum
	signed division of dividend .dD by divisor .sS, floored rounding mode
	leaves quot .qQ, remainder .rR
	fast trivial cases div +/- 1 and, if .sS>.dD ret sgn(.s)*.dD).
	div 0: 0/0 ret 0,1; non-zero/0 ret 0,sgn(.d)*.max(D+S).

 ngcd		( n.N m.M -- o.O )			(4)		'ngcd'		bignum
	returns the greatest common denominator o.O of the absolute value of two signed 
	bignums. If either number is zero, returns the absolute value of the other one.

 nsqrt  	( .n.N -- .r.R j )		(4)				bignum
	+ve square root .r.R of signed counted integer .n.N and j=0,-1 if x<0.
	.m.M is nearest integer the sqare of which is lower or equal |.x.X|*(2j-1).

 --
 counted integer stg/numeric conversion
	

 n#max  	( -- n )					'nhmax'		bignum
	max cells the size of which a counted integer can be converted
	to numeric string, at current {base} and memory setup.
	range can be extended after {allocate} and storeing new data-top
	to vari {n-top}, e.g.
		20000 allocate 
		0= if dup heaphead-size - @ dup d-top +! n-top +! endif drop

 n#size 	( N -- N n )					'nhsize'	bignum
	no. of address units (bytes) required for stg conversion
	of N cells counted integer

 n#?		( N -- N p flg )				'nhq'		bignum
	check whether counted int of size N can be converted to stg.
	flg=0 if unsufficient space for conversion at current radix
	else p = base (top down) address for multi-cell numeric stg.
	all of {pad}, {pad2} and {here}/{hld} storage protected.

 n<#		( .nn. N -- .nn. N | abort-2 )			'nlth'		bignum
	check and set-up buf. on top of {pad} area, 
	use cells count adjusted to minimal size. 
	abort if unsufficient space for current conversion radix. 

 n#  		( .n1. N -- .n2. N )		(4)		'nh'		bignum
	append l.s. digit to number stg output storage

 n#s		( .n1. N -- .n2. N )		(4)		'nhs'		bignum
	convert all significant digits of a multi-cell integer 
	to stg, leave .n2. = 0
 (un.)  	( .n1. N -- p u )		(4)		'pundotp'	bignum
	convert unsigned multi-cell integer to numeric stg

 (n.)		( .n1. N -- p u )		(4)		'pndotp'	bignum
	convert signed multi-cell integer to numeric stg

 n#>		( .n1. N -- p u )		(4)		'nhgt'		bignum
	terminate multi-cell number conversion, leave resultant stg (p,u)

 n.		( .n1. N -- )			(4)		'ndot'		bignum
	display signed multi-cell integer as numeric stg

 n.r		( .n1. N n2 -- )		(4)		'ndotr'		bignum
	right aligned to field w. n2 chars of width 
	display signed multi-cell integer as numeric stg
 un.		( .n1. N -- )			(4)		'undot'		bignum
	display unsigned multi-cell integer as numeric stg

 un.r		( .n1. N n2 -- )		(4)		'undotr'	bignum
	right aligned to field w. n2 chars of width 
	display unsigned multi-cell integer as numeric stg

 n>number	( nx1 N1 p1 u1 -- nx2 N2 p2 u2 )		'ntonumber'	bignum
	basic multi-cell string to number conversion routine:
	accumulate to (nx1,N1) from numeric chars at stg(p1,u1)
	until 1st non-numeric char encountered or, at most u1 chars.
	u2 = 0 if successful, else p2 ptr to 1st invalid char code.
	cells count N2 adjusted to fit.

 nnumber	( ptr +u -- .nn. N flg )					bignum
	convert string (ptr,+u) to multi-cell number w/ as much 
	cells as required to fully represent the string value.
	store last dp posn OR-ed w. 0xff800000 to dpl,
	leading number radix chars valid as w/ standard words.
	valid chars for fractional part marker are ',.'.
	leaves flg = 0 after success, else any number =/= 0.
	input cannot be a '-ve zero'.

 ninteger	ccc(C: .nn. N -- )(X: -- .nn. N )				bignum
	counted integer alterable cons; {to}, {+to} NOT applicable.
	can be modified, e.g. with { ( .nn. N -- ) ' name >body n! }.
	data @body: [ N ][ .nn. ]

 nliteral	(C: .x. N -- )(X: -- .x. N )		(i)			bignum
	cpl: compile bignum (counted integer) as a literal, interp: noop

================================================================
 l4bignum.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4block.inc>
--------------------------------------------------------------------------


----------------------------------------------------------------
 -- blockfile (screenfile) support

 -- cons

 b/b		( -- u )			(c)		'bbyb'		system
	bits per byte, "address unit" (8, max 32)

 b/c		( -- u )			(c)		'bbyc'		editor
	bytes per character (1, max 4 bytes and max 32 bits)

 c/l		( -- u )			(fg)		'cbyl'		fig
	characters per editor/load line (64)

 b/scr  	( -- u )			(c)(fg)		'bbyscr'	fig
	blocks per editor/load screen (1)

 b/buf  	( -- u )			(c)		'bbybuf'	forth
	bytes per block-buffer (1024 per ANS)

 c/scr  	( -- u )			(kv)		'cbys'		editor
	chars per blockfile-editor screen (1024).

 -- block access

 prev		( -- p )			(fg)				fig
	most recently used block buf, i.e. block which contains latest data 
	of at time of last access valid owner, -re- {scr-chan}, {use}, {block}.
	if unset (zero) defaults to 1st unused, new block if none exists.
	can forcedly be re-fetched w/ { 0 to [prev] }.

 use		( -- p )			(fg)				fig
	least recently used block buffer, i.e. block buf. to be used next.
	if {[use]} unset (zero), defaults to last buffer in chain of blocks.
	actual {use} represents a block of scr-chan valid immediatly before 
	{prev} assignment, used by {block} only if owner channel un-changed.
	can forcedly be re-fetched w/ { 0 to [use] }.

 first  	( -- p )			(fg)				fig
	bottom address of 1st block buffer in buffer-block of -re- {prev}, 
	defaults to 1st buffer in chain of buffer-blocks if [prev] unset (zero).
	can forcedly be re-fetched w/ { 0 to [first] }.
	NOTE: different value if {prev} moved to a different block of buffers.
	provided for minimal compatibility wrt f.i.g.-4th blockfile access, 
	pointing to the 1st byte of the 1st, currently used block buffer.
	{first} is NOT necessarily THE BEGINNING of assigned chained buffer 
	blocks, the base address of which can be found with { block-lk @  }.
	-re- {ibbuf} in {blkfile} voc.

 limit  	( -- p )			(fg)				fig
	next to top address of last block buffer in buffer-block of -re- {prev}.
	can forcedly be re-fetched w/ { 0 to [limit] }.
	NOTE: different value if {prev} moved to a different block of buffers.
	provided for minimal compatibility wrt f.i.g.-4th blockfile access, 
	pointing to the next after last byte of currently used block buffer.
	{limit} is most probably NOT THE LIMIT of assigned chained buffer blocks 
	which, at any time may be extended to any convenient amount and, cannot 
	be assumed to represent a contiguous data-space, wrt eachother.
	-re- {ibbuf} in {blkfile} voc.

 block-lk	( -- p )			(kv)				blkfile
	block buffer link base, ptr to header of 1st block of buffers

 blk>lnk	( n -- p )					'blk2lnk'	blkfile
	buffer-block link-address p of block-buffer of block no. n.

 buf>lnk	( p1 -- p2 )					'buf2lnk'	blkfile
	buffer-block link-address p2 of block-buffer at p1.
	can be used to checking whether a page-aligned ptr belongs to a 
	block of screenfile buffers, p2 := 0 if not.

 lnk>num	( p -- n )			(m,)		'lnk2num'	blkfile
	ret count n of buffers by buffer block link-ptr p -re- {blk>lnk>}, {buf>lnk}.

 lnk>chn	( p -- n )			(m,)		'lnk2chn'	blkfile
	ret owner channel n of buffer block by link-ptr p -re- {blk>lnk>}, {buf>lnk}.

 blk>buf	( n -- p )					'blk2buf'	blkfile
	buffer address p of block no. n.
	p := 0 if block n not buffered.

 head>buf	( p1 -- p2 )			(m,)		'head2buf'	blkfile
	convert ptr p1 to header to ptr to the rsp screenfile buffer. 
	if p1=0 ret p2 := 0, if word not compiled as a macro.

 buf>blk	( p -- n )					'buf2blk'	blkfile
	block no. n. by ptr p to buffer. n := -1 if buffer not used.

 head>blk	( p -- n )			(m,)		'head2blk'	blkfile
	convert ptr p to buffer header to block no. assigned to the rsp screenfile buffer. 
	n := -1 if buffer not used, if word not compiled as a macro.

 blk>head	( n -- p )					'blk2head'	blkfile
	ptr p to header of screenfile buffer to which file-block no. n is assigned.
	ret 0 if p1 not a screenfile buffer.

 buf>head	( p1 -- p2 )					'buf2head'	blkfile
	ret ptr p2 to header of screenfile buffer at p1.
	ret 0 if p1 not a screenfile buffer.

 +buf		( p1 -- p2 tf|ff )		(fg)(e)		'plusbuf'	fig
	find next buffer in chain of buffer-blocks, regardless of the resp owner.
	ff := 0 if p2 = prev, else any no-zero value for tf (flg := prev - p2 ).
	(e: Z if p2=prev)

 [upd]  	( -- )						'bupdb'		hidden
	mark most recently changed block, -re- {prev}, to saveing before re-useing.
	default opr of deferred {update}.

 update  	( -- )				(a:b)(d)	'bupdb'		forth
	mark most recently changed block, -re- {prev}, to saveing before re-useing.
	default opr -re- {[updt]}.

 update-off  	( -- )				(a:b)		'updateoff'	blkfile
	clear -re- {update} flag of most recently changed block.

 update?  	( p -- f )					'updateq'	blkfile
	ret tf if screenfile buffer at p is in use and {update}d.

 ro?		( p -- f )			n.i.		'roq'		blkfile
	ret tf if at p buffered screenfile is write-protected.

 nextbuf	( p1 -- p2 )							blkfile
	find next unused or by {scr-chan} owned buffer =/= p1 or, install new block.
	always succeeds, otherwise fatal error: system out of memory

 rw@		( p -- )					'rwf'		blkfile
	fetch assigned block to buffer p from file by buffer owner or {scr-chan}.

 rw!		( p -- )			(s)		'rws'		blkfile
	clr {update} flag, save block from ptr p to owner file or, {scr-chan}.
	defaults to {scr-chan}, stored into block header if no channel assigned.
	syscall write, llseek -re- man (2), restricted to file size less than 4G.

 scr-chan	( -- n )			(kv)		'scrn'		forth
	kernel value which holds the current screenfile channel no.

 [buffer]	( +u -- p )			(k)(83)		'bbufb'		hidden
	assign buffer at ptr p to block no. u of owner {scr-chan}; dft for {buffer} 
	beginning w/ {use}, find next buffer =/= {prev} to useing next, set new {use}; 
	ret previous {use} as new {prev}, content stored back to file if {update}ed.

 [block]	( n -- p )			(k)(83)		'bblockb'	hidden
	ret ptr p =: {prev} to buffer for block n, assigned to current {scr-chan}.
	no. of fetched bytes or file access error can be read by { scr-chan ch-rnum }.
	either, finds already present block u of {scr-chan} or, assigns and fetches 
	block no. u into p = {use} or, new buffer of rsp scr-chan, re-setting {use}. 
	dft for -re- {block}.
	

 [source]	( -- p +u )			(k)(83)		'bsourceb'	hidden
	dft for {source}, ret input buffer(p,u). does not modify {in}, {span} &c.
	dpans A.6.1.2216 : { BLK @  IF BLK @ BLOCK 1024  ELSE TIB #TIB @ THEN } modified 
	such that -ve {BLK}@ is 1-s cpl of file ptr and notifies input from 'stream'-file 
	and, initial state of commandline args at program invocation by -ve @{SOURCE-ID}.

 --
	

 dr0		( -- )						'dr0c'		forth
	activate 1st screenfile channel, -re- {dr1}, {dr?}

 dr1		( -- )						'dr1c'		forth
	activate 2nd screenfile channel, -re- {dr0}, {dr?}

 dr?		( -- n )					'schq'		blkfile
	ret +ve {dr0}-channel, -ve {dr1}-chanel 
	or, zero if neither one is {scr-chan}.

 empty-blk	( n -- )			(fg)		'emblk'		blkfile
	in-validate buffer of blk# n, set {use} to it's buffer, don't save.
	forces re-fetching blk# n from {scr-chan} file.

 empty-buffers ( -- )				(fg)		'embufs'	forth
	don't save, make all buffers of {scr-chan} available, 
	force re-fetching of buffered blocks from file.

 CLEAR	( n -- )							editor
	fill screen no. n (=block) with blanks.
	can extend beyond <eof>, itermediate scr-s filled w/ <nul>-bytes.

 flush	( -- )								forth
	write all updated blocks back to the rsp. screenfile, 
	un-assign. sync file w/ cached content.
 save-buffers	( -- )				(a:b)		'sbufs'		forth
	write all updated blocks back to the rsp. screenfile, fig-4th "flush".
	(useless, same as -re- {flush} but, required for ANS-Forth)

 reading	( -- )				(4)		'rding'		blkfile
	re-open {scr-chan} for non-blocking, read-only access at un-changed file ptr.
	rsp {block} cleared to be refetched; -re- {editting} for r/w mode.

 editting	( -- )				(4)		'eding'		blkfile
	re-open {scr-chan} for non-blocking, read/write access at un-changed file ptr.
	rsp {block} cleared to be refetched; -re- {reading} for r/o mode.

 using	( p u -- )							forth
	pass screenfile name to use w/ subsequent {load} and editting opr.
	open {scr-chan} in non-blocking, read-only mode. -re- {editting}.

 load		( n -- )			(d)				forth
	make file by {scr-chan} current input, beginning at screen no. n.

 [load]	( n -- )							hidden
	make file by {scr-chan} current input, beginning at screen no. n.
	dft for deferred -re- {load}.

 -->		( -- )				(d)		'nxld'		root
	-re- {load} next screen. deferred, dft -re- {[-->]}.
	e.g. within a word defn, use {[-->]} for immediate execution.

 [-->]	( -- )				(i)		'bnxldb'	forth
	cpl from next screen. dft for deferred -re- {-->}
	using initial, {load}ing block-buffer for tib.

 thru		( n1 n2 -- ) 			(4)(a:b)(n.i.)			forth
	-re- {load} screens n1 till n2 (inclusive, dpans 7.6.2.2280).
	NOTE: n.i, pse, use nestable -re- {load} and {-->}, instead.

 buffer  	( +u -- p )			(v)(fg)				forth
	leave ptr to useable screenfile buf.,
	flush oldest buf. and re-assign if none free,
	else leave ptr to next free in list of #buf-s.
	execute true address uot vector (buffer), dft is {[buffer]}.

 block  	( +u -- p )			(v)(fg)				forth
	ptr to block for sreenfile i/o
	execute true address uot vector (block), dft is {[block]}.

----------------------------------------------------------------
 -- the f.i.g. line editor, -re- {editor} voc.
	
 
 

 r#@		( -- n )			(m,7)		'rnf'		editor
	content of uvari {r#}, the editor screen disp from top to cursor.

 scr@		( -- n )			(m,7)		'scrf'		editor
	content of uvari {scr}, the current editor screen no.

 scr!		( n -- )			(m,11)		'scrs'		editor
	sto n to uvari {scr}, the current editor screen no.

 (line)  	( n1 n2 -- p u )				'plinep'	editor
	ret ptr to and characters count of line no. n1 in screen n2.

 .LINE  	( n -- )					'dotline'	editor

 LINE   	( n -- p | abort )		(4)				editor
	relative to scr. leave address of line

 where  	( cur blk -- )			n.i.				editor
	while {load}ing, print screen # and image of error, sto
	@blk to uvari {scr}, make {editor}-voc current and quit.

 #locate	( -- n1 n2 )			(4)		'hlocate'	editor
	leave cursor offset n2, line n1

 #lead  	( -- p n )			(4)		'hlead'		editor
	line address p, offset n from beginning to cursor.

 #lag		( -- p u )					'hlag'		editor
	cursor address p, count u after cursor till eol.

 TRUNCATE	( n -- )							editor
	truncate current screenfile at or, extend & <nul>-fill till block # n.

 L+		( -- )						'relip'		editor
	display next screen, from {scr}.

 L-		( -- )						'relim'		editor
	display previous screen, from {scr}.

 L		( -- )						'relist'	editor
	re-display latest screen, from {scr}.

 list		( n -- )			(a:b)		'elist'		forth
	display screen n, store max(0,n) to uvari -re- {scr}.

 I		( n -- )			(4)		'eI'		editor
	insert text from pad onto line # n.
	spread (S) and replace empty line n from pad (R)

 P		( n -- )ccc			(4)		'eP'		editor
	put following text to line n

 R		( n -- )			(4)		'eR'		editor
	replace (overwrite) line no. ( n ) with text from pad

 -move  	( p n -- )					'mmove'		editor
	move c/l chars of text from ptr p to line n of current screen.

 H		( n -- )			(4)		'eH'		editor
	hold numbered line at pad. copy to pad

 S		( n -- )			(4)		'eSe'		editor
	spread making line n blank

 E		( n -- )			(4)		'eE'		editor
	erase line n with blanks

 D		( n -- )			(4)		'eD'		editor
	delete line n, but hold in pad

 TOP		( -- )				(4)		'etop'		editor
	home cursor to top left of screen

 F		( -- )ccc			(4)		'eF'		editor
	find occurence of following text

 N		( -- )				(4)		'eN'		editor
	find next occurence of previous text

 T		( n -- )			(4)		'eT'		editor
	type line by # n, save also in pad

 M		( n -- )			(4)		'eM'		editor
	move cursor by signed amount n, print its line

 [0m]		( -- )				(d)		'bm0b'		hidden
	terminal cursor line re-listing. default for deferred {0m}.

 B		( -- )				(4)		'eB'		editor
	backup cursor by text in pad

 text		( c -- )			(4)				editor
	accept following text to pad, w/ blanks filled up to c/l chars,
	until <eol> or char-code c received.

 C		( -- )ccc			(4)		'eC'		editor
	insert following text at cursor.

 Y		( p u -- )			(4)		'eY'		editor
	insert stg(p,u) at cursor.

 DELETE	( n -- )			(4)				editor
	backwards at cursor by count n, spanning full screen.

 -text	( p1 u1 p2 -- f )		(4)		'mtext'		editor
	compare stg(p1,u1) whith data at p2, ret f =/= 0 if matching.
	letter case dependency as set w/ {lc-depend}/{lc-ignore}.

 match	( p1 u1 p2 u2 -- f u3 )		(4)				editor
	search memory(p1,u1) for stg(p2,u2),
	ret tf and disp u3 wrt p1 if stg found, else ff and u3 := u1
	letter case dependency as set w/ {lc-depend}/{lc-ignore}.

 1line	( -- f )			(4)		'e1line'	editor
	scan line with cursor for match to pad text, update cursor, return boolean

 scrfpos	( -- dn )							blkfile
	ret file-ptr at current screenfile cursor posn, from {scr} and {r#}.

 FIND		( -- )				(4)(e)		'efind'		editor
	string at pad over full screenfile range, else error message.
	(e: Z if found)

 COPY		( n1 n2 -- )			(4)				editor
	duplicate screen n1, onto screen n2. 
	can extend beyond <eof>, itermediate scr-s filled w/ <nul>-bytes.

 TILL		ccc( -- )			(4)		'till'		editor
	delete on cursor line, from cursor till text beginning.

 X		( -- )ccc			(4)		'eX'		editor
	delete following text, spanning full screenfile range.
	-re- {TILL} for del on cursor line, only

 [edit]	( -- )				(4)		'beditb'	editor
	initial runtime of deferred {edit}, loading the screenfile editor.
	message ENOENT if file <edit.f8> not found, else {edit} set to {noop}.

 edit		( -- )				(d)		'edit'		root
	loading/executing the screenfile editor. deferred to -re- {[edit]}.

 [f]		(X: -- p f )			(i)		'bfb'		editor
		(C: -- )
	-re- {-find} and ret flg & lfa = p if in interpreting state, 
	else compile/execute next word w/ forth voc. preferrence.

=====================================================================;
 l4block.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4consio.inc>
--------------------------------------------------------------------------

----------------------------------------------------------------
 -- standard i/o (more or less...)

	

 beep		( n1 n2 -- )			(s)				forth
	sound generation, pitch n1[84s], duration n2[ms]
	(standard console ^G sound is n2:=125, n1:=1591)
	syscall ioctl -re- man 2 ...

 space  	( -- )								forth
	send a blank space to @{stdout}

 cr		( -- )								forth
	send new-line command to @{stdout}

 emit		( c -- )			(e)(v)		'vemit'		forth
	send single char to @{stdout}
	initially vectored to {[emit]}

 ?cr		( n -- )					'qcr'		forth
	new-line if (@out + n) not less than main window width

 -cr		( flg -- )			(f6)		'dcr'		forth
	{cr} if flg =/= 0

 o-cr		( -- )						'odcr'		forth
	{cr} if output device is a console.

 ?eol		( -- flg )					'qeol'		forth
	true flag if max-x not larger than @out

 cbytes 	( c -- c u )					'cbytes4'	hidden
	ret count u of significant characters in cell-sized (32-bit) c.

 [emit]  	( c -- )			(e)		'bemitb'	hidden
	send single char to @{stdout}, update {out} accordingly.
	"single char" may be up to four non-zero bytes of cell c
	on tos, which will be sent lsb 1st, until rmng @cell = 0
	(this is in preparation for unicode capabilities)

 [ctype] 	( p +n -- )			(s)		'bctypeb'	hidden
	send string (p,u) to stdout, alternate vector for -re- {type}.
	silently return if -ve, zero or > 64K stg length.
	error code stored to cdt -re- {ch-rnum}, and {(oerr)}.
	syscall write -re- man 2 ...

 [etype] 	( p +u -- )			(l)		'btypeb'	hidden
	{[type]} string(p,u) to stdout w/ by -re- {e\stg} converted escaped tokens.
	silently return if -ve, zero or > 64K stg length.
	error code readable immediately after, from -re- {ch-rnum}, {(oerr)}.
	numeric token:
		\nnn	character code, numeric sequence as valid for a forth single 
			integer at octal radix, any other w/ the appropriate praefix.
			for instance
				s" hick\46"	displays	hick!
				s" hick\#33"	does the same
	special symbols, letter case dependent:
		\a	<bel>
		\b	<bs>
		\c	w/o trailing <lf> - suppressed, not applicable
		\e	<esc>
		\f	<ff>
		\n	<new line>, Linux: <lf>
		\r	<cr>
		\t	<ht>
		\v	<vt>
		\\	double escape symbol, sending the escape symbol as a char.
		\other	character following the escape symbol will be sent.

 [ok]		( -- )				(79)		'bokb'		hidden
	kbd input prompt: ">" while interpreting, "=" compiling.
	true xec address by dft stored to (ok).

 print  	( p -- )			(f6)				forth
	display asciz or counted string

 type		( p +n -- )			(kd)				forth
	send string (p,+n) to stdout. uvari vector {(type)}, which defaults to 
	deferred {[type]}, initially set to xec {[etype]} and is-dft {[ctype]}.
	{out} updated according to printing chars, <nl> and <tab>.
	NOTE wrt windowing: NO orderly means to finding out about 'pending newline'! 
	     neither by console routines not by vt-sequences, only feasible solution 
	     would be useing {emit} an doing the accounting, within an apllication.

 zprint  	( p -- )							forth
	display <nul> terminated string

 bl.r		( p u n -- p u )		(f6)		'bldotr'	forth
	output as many blanks as required to right justified {type}ing 
	stg(p,u) in a field of n chars. no extra chars if n <= u.
	-re- {+blanks}, which builds a blank string at -re- {here}

 spaces  	( +u -- )							forth
	-re- {type} +u blank spaces.

 emit-m  	( +u c -- )			(f6)		'emitm'		forth
	{emit} +u characters c, 0 < +u < 32768, no-op if > 32767
	char c may be up to 4 bytes, full size of a sing.

 edlin   	( p1 u1 -- p2 u2 )		(4)				forth
	accept to buf(p1,u1), edit expanded default <nul>-terminated text at p1. 
	cursor posn at dft text 2nd column, expand to eol w/ <end> or curs-down.
	passing buffer(p1,u1), ret stg(p2,u2) with received len u2 < u1.

 [accept]	( p +u1 -- +u2 )	(e)			'osaccept'	hidden
	default for accept - preliminary, until terminfo implemented.
	fetch at most u1 chars input from stdin, or until <eol>, to buf. at p.
	required space is 0 < u1 < u1+(len-of-<eol>-sequence).
	overwriting kbd input, termination after <eol>, <cr> or <nul> received,
	buf. protected to not writing beyond bounds 0 < #chars < +u1.
	trailing <eol> zeroed, +u2 not including length of <eol> sequence.
	input echo can be dis/enabled w/ {echo-off}/{echo-on}.
	ctrl actions for minimal editting capabilities w/ Linux console and "rxvt":
		<bs>	^H	back-space, not overwriting, moves cursor left.
		<e>[D	cur.lft	ditto (vt102 type terminal).
		<e>[C	cur.rgt	non-overwriting space, moves cursor right.
		<tab>	^I	non-overwriting space, moves cursor right, 
				enabling "last line recall" if 1st keystroke.
		<e>[1~	pos1	cursor back to line beginning.
		<e>[4~	end	expands till (previous) end of line.
		<del>	'<='	backup and delete char under cursor.
		<lf>	^J	line feed, exec <cr/lf>
		<cr>	^M	carriage return, exec <cr/lf>
		<ff>	^L	clear screen
		<bel>	^G	noise
	NOTE:	xterm-4.xx vt control broken! others in-consistent; though, almost 
		orderly w/ "rxvt" but, <tab> and <del> work for cursor positioning, 
		<enter> cuts off at cursor posn, <del-left> ok, and delete w/ <^H>.

 accept 	( p +u1 -- +u2 )		(GA)		'vaccept'	forth
	fetch at most u1 chars input from stdin, or until <nl>
	execute true address uot vector (accept), dft -re- {[accept]}.

 query  	( -- )								forth
	fetch at most {#tib}-1 chars, or until <nl>, from stdin to {tib}.
	returns if either of eol <nl> or {#tib 1-} chars received.
	store no. of received chars in user vari {span}. store 0 to #in and >in

 expect  	( p +u1 -- )							forth
	fetch at most u1 chars input from stdin, or until <nl>
	store no. of received chars in user vari {span}.

 ---

 -- keyboard input

	{uc-map}, {uc-unmap}
		emulated hardware mapping if input from stdin is console.
	{lc-ignore}, {lc-depend}
		sofware evaluation of any input source case ignoring or not.

 uc-map 	( -- )				(e)(s)		'uclm'		linux
	map upper case to lower case chars of input to (work) channel.
	re {uc-unmap}

 uc-unmap	( -- )				(e)(s)		'uclu'		linux
	separate upper and lower case chars mapping of input to (work) channel
	store true error code to (oerr). -re- {uc-map}
	syscall ioctl -re- man 2 ...

 lcase@  	( -- n )					'lcasef'	forth
 LCASE@  	( -- n )					'LCASEF'	forth
	fetch letter-case flag, zero if case-dependency set. -re- {caps?}
	e.g, use{ lcase@ lc-ignore ..words.. lcase@ 0= if lc-depend endif }

 lc-ignore	( -- )				(m,7)		'lcignore'	root
 LC-IGNORE	( -- )				(m,7)		'LCIGNORE'	root
	force case in-dependent search and string comparison. -re- {lc-depend}.

 lc-depend	( -- )				(m,7)		'lcdepend'	forth
	case dependent search and string comparison mode - default state.
	If case independent search mode enabled	1st match takes precedence,
	which for L4 kernel applies to lower case version. -re- {lc-ignore}.

 caps?  	( -- flg )					'capsq'		forth
 CAPS?  	( -- flg )					'capsq'		forth
	tf if text comparison is case dependently, for {find}, {compare}, etc
	

================================================================
 -- i/o selectable timeout
 -- raw/single characters intput
	

 wait4' 	ccc( n1 -- n2 n3 )		(i)		'wait4t'	linux
	xec any i/o related word ccc w/ the {(stimo)} uvari set to n1 no. of 
	seconds for specific time-out. restores previous setting, after return.
	effective for all words which call a {wait4..} word, e.g. {key}, etc.
	ret n2 := n3 := -1 if xt was not an executeable item.

 wait4x 	( n1 xt -- n2 n3 )				'wait4x'	linux
	xec any i/o related word w/ the {(stimo)} uvari set to n1 no. of seconds
	for specific time-out. restores previous setting, after return.
	effective for all words which call a {wait4..} word, e.g. {key}, etc.
	ret n2 = n3 := -1 if xt was not an executeable item.

 wait4ti	( ch n1 -- n2 n3 )		((s))				linux
	wait for n1 seconds until input pending to channel ch, -re- {wait4ch} 

 wait4ch	( ch -- n1 n2 )			((s))				linux
	wait for @(stimo) seconds until input pending to (any type) channel ch, 
	ret n1=n2=0 after timeout, else remaining seconds(n2) and nanosec(n1).
	limited to channel identifiers (fd-s) in range [0,31].
	syscall -re- man 2 select, remaining time is a feature specific to linux.

 wait4kbd	( -- )				(s)				linux
	wait until keyboard (console channel) input pending

 wait4in	( -- )				(s)				linux
	wait until input pending if stdin is console
	limited to stdin channel identifiers (fd-s) in range [0,31].
	actual FILE_MAX can be read from /proc/sys/fs/file-max

 wait4fd	( fd -- )			(s)				linux
	wait until input pending to channel's fd. limited to fd-s in range [0,31].
	time-out from uvari {(stimo)} [s] and {(stimo) 4-} [s]. max ea $7fffffff.
	executes the (pause) vector if idle and, if an(y) alternate uot exists.
	syscall select -re- man 2 ...

 ?input 	( ch -- flg )			(s)(fg)		'qinput'	forth
	input from supplied channel, otherwise identical -re- {?terminal}

 ?terminal	( -- flg )			(s)(fg)		'qterminal'	forth
	tf if char available from stdin channel, else ff
	pre-fetches avail char to stdin <cdt.ibuf>, if not already in buf.
	syscall read -re- man 2 ...
	stores ernum to uv.ierr and cdt.rnum:
		 >0:(no of) char(s) received
		  0:no input (VMIN=0), <eof>
		 -9:invalid file descriptor (ebadf)
		-11:no input (VMIN>0) - (eagain)
	{?terminal} is default to vectored {ekey?}

 ekey		( -- c )							forth
	return any char, wait until received (from stdin)
	re DPANS 10.4.1.1: char encoding as set for the rsp terminal/linux console.

 cc4th  	( c -- c flg )			(83)				forth
	vectored action on input ctrl chars in range of [0,31],127.
	checking whether char is ctrl code and corresponding vector set;
	ret char and tf if not ascii ctrl or if no vector defined, else
	ctrl-code and ff w. other stack results depending on ctrl action.
	leave <nul> w.o. action, transpose @tos <del> to vector for <nul>
	vector ( .yy. c c' -- .yy. .xx. c n )
		must preserve char code @nos, @tos may be overwritten.
		can be de-activated by kref(zero) ptrs at either posn.

 ekey?  	( -- flg )			(GA:fax)(v)	'ekeyq'		forth
	test pending input, don't wait. 
	xec uot vector (ekey?); by default vectored to {?terminal}:
	buf. 1st available char to stdin <cdt.ibuf> & return tf, else ff.

 ?ekey  	( -- c flg )					'qekey'		forth
	return any char c1 and tf, else invalid c1 and ff, don't wait
	tests pending input & copies currently available char to tos.
	does{ ekey? IF ibuf c@ ELSE false ENDIF dup 0=/= }

 key?	  	( -- flg )			(GA:fa)		'keyq'		forth
	test pending input, don't wait
	tf if pending ascii char in terminal/standard input

 ?key   	( -- c1 flg )			(83)		'qkey'		forth
	ascii range char c1 and tf, else invalid c1 and ff
	remove char from input queue

 key		( -- c )							forth
	ascii range char, wait until received (from stdin)
	open console if <eof> -?-

 kbd?key   	( -- c1 flg )					'kbdqkey'	forth
	forcedly query the keyboard channel, -re- {?key}

 kbd-key	( -- c )					'kbdkey'	forth
	{key} forcedly from keyboard channel, -re- {key}

 ekey>asci	( u -- u ff | c1 tf )				'ekey2asci'	forth
	{ekey>char} with lower low bound := 0, bounds from uvari (pchr).

 ekey>char	( u -- u ff | c1 tf )		(GA:fcx)	'ekey2char'	forth
	return tf if u is in range of printing chars, bounds from uvari (pchr).

 kbd!		( n -- )					'kbdsto'	forth
	non-overwriting store char n back to keyboard channel charbuf,
	if input buf. empty, for later retrieval w. {kbd-key} etc.

 key!		( n -- )					'keysto'	forth
	non-overwriting store char n back to std input charbuf,
	if input buf. empty, for later retrieval w. {key} etc.

 can?		( -- flg )					'canq'		forth
	tf if consecutive w@(uv.ucan+2) times the char w@uv.ucan received
	defaults to four times <ctrl>Y = ascii 25.
	NOTE: false flag if stdin is not a console channel.

 esc?		( -- flg )			(e)		'escq'		forth
	tf if <esc> char input, if <bl> wait until other char
	NOTE: false flag if {kbd} is not a readable console channel.
	(e:flags reflect result)

 kbd'		ccc( -- )			(i)		'kbdt'		forth
	cpl/interpret next word to executing w. stdin from console (keyboard).
	immediate words <ccc> will be rejected.

 kb]		(R: ch -- )			(k)		'kbdtb'		novoc
	restore from console input

 [kb		(R: -- ch )			(k)		'bkbdt'		novoc
	enter console input, leave new-chan on t.o.r.

----------------------------------------------------------------
 -- i/o channels tests
	

 out-pty?	( -- flg )			(4)		'outptyq'	linux
	tf if STDOUT is to a pty-device, 

 pty?		( c -- flg )			(4)		'ptyq'		linux
	query channel c by file-name, ret tf if c is a pty device
	set cdt.iofl in chp accordingly.

 iomode  	( -- )				(s)				linux
	setting stdin to non-blocking r/o, stdout to sync. w/o
	syscall fcntl -re- man 2 ...

 emit?  	( -- flg )			(a:fx)((s))	'emitq'		forth
	return tf if non-blocking output available,
	by syscall <access>, ret true if stdout is writable.

 stdin?  	( -- flg )			(e)((s))	'stdinq'	forth
	test whether stdin readable, @tos := error code.
	does not affect stdin channel's handling state.
	(e: Z if stdin readable)

 io-cons	( -- )				((s))		'siocons'	forth
	determine stdin and stdout handling state flags.
	should be executed after any new i/o re-direction.

 io-cons?	( -- flg )					'ioconsq'	forth
	ret previously determined i/o handling state,
	tf if both, stdin and stdout connected to a console

 cons?  	( fd -- flg )			(s)		'consq'		forth
	tf if fd is a console channel.
	does not affect fd channel's handling state.
	by test w/ syscall ioctl,TIOCGSID

 <toutcons>	( -- )				(s)(u)(k)
	eflags: NZ if fd = bx is not a console
	used to check whether stdin is console.
	syscall ioctl -re- man 2 ...

 in-cons?	( -- flg )			((s))		'inconsq'	forth
	tf if stdin is console,
	set stdin-type flag in cdt, clear flag in uvari (aux) if not a console
	syscall ioctl -re- man 2 ...

 out-cons?	( -- flg )			((s))		'outconsq'	forth
	tf if stdout is console,
	set stdout-type flag in cdt, clear flag in uvari (aux) if not a console
	syscall ioctl -re- man 2 ...

 echo-on	( c -- )			((s))		'echon'		forth
	test whether c is a console channel, modify cdt-flags to echoing, if appropriate.
	w/ syscall ioctl,TIOCGSID

 echo-off	( c -- )					'echof'		forth
	if c is a console channel, modify cdt-flags to non-echoing

=====================================================================;
 l4consio.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4constants.inc>
--------------------------------------------------------------------------

================================================================
 -- constants

 -1.		( -- dn )					'dmone'		forth
	double cons -1

 true		( -- tf )			(e)(m,6)			forth
	leave cell value with all bits set (-1)

 0.		( -- dn )			(m,4)		'dzero'		forth
	double cons 0

 mem		( -- n )			(m,3)		'zero'		forth
	flag for bit opr's, test cell in memory (single cons 0)
 false   	( -- ff )			(e)(m,3)	'zero'		forth
	cell value with all bits un-set (0)

 true		( -- tf )			(m,6)		'pone'		fig
	f.i.g. true flag = 1 (+ve!)

 cell   	( -- n1 )			(a:c)		'pfour'		forth
	no. of bytes per cell (4)

 -0.		( -- dn )			(f6)		'dmzero'	forth
	double cons -0 (zero with sign bit set)

 -0		( -- n1 )			(f6)(m,6)	'mzero'		forth
	single cons -0 (zero with sign bit set)

 #vocs  	( -- n )			(f6)		'nvocs'		forth
	cons, number of vocabulary ptrs in voc-stack, 
	on top of two items volatile stack of context, ocontext.
	push by {also} is to lower addresses, two cells each.

 (hichar)	( -- p )					'phicharp'	hidden
	dft lower to upper case mapping character table

 (lochar)	( -- p )					'plocharp'	hidden
	dft upper to lower case mapping character table

 4th>abs	( p -- address )		(m)		'fth2abs'	forth
	convert forth ptr to true (virtual) address

 abs>4th	( address -- a )		(m)		'abs2fth'	forth
	convert true (virtual) address to forth ptr

=====================================================================;
 l4constants.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4cpl.inc>
--------------------------------------------------------------------------


 udisp?  	( n -- n flg )					'udispq'	forth
	check whether disp n to uref(uot) is in range and 4-aligned.

 data?  	( p -- fl )					'dataq'		hidden
	true flag if kref'd p points to allocated r/x data-memory.

 ?prog  	( p -- p | abort-21 )				'qprog'		forth
	abort if p not in job's allocated compile-memory

 prog?  	( p -- fl )					'progq'		hidden
	true flag if kref'd p points to allocated compile-memory.

 xec?		( n -- addr flg )				'xecq'		forth
	test whether n is -most probably- an {execute}able item,
	either one of an uot index, kref'd or, true address of code entry.
	n = 0 is not considered valid, thus ix of {root} not recognized.
	ret flg (any non-zero value!) and executable true address.

 kprog? 	( p -- fl )					'kprogq'	hidden
	true flag if kref'd p in kernel or allocated compile-memory.

 kernel?	( p -- fl )					'kernelq'	hidden
	true flag if kref'd p points to library kernel memory.

 static?	( p -- fl )					'staticq'	system
	true flag if program statically linked to L4.
	

================================================================
-- compiler - preliminary impl.

	cpl stores new {cp}, cinterpret calls bcp, restores cp from bcp

	compiling variables:

	initiated	from
		c0	system	at initial setup
		cp	c0	running ptr to actual posn of code compiling
		head	cp	backup before 1st entering compiling state
		tail	cp	backup before last entering compiling state
		bcp	head	backup before entering compiling state
		btail	cp	backup at initial entry into compilestate

	copied to	from
		cp	explicit value by
				codespace alignment words and
				codespace allocation words,
			bcp	after immediate execution of standard words,
			btail	error exit, discarding erroneous code,
			c0	emergency cold (re-)start.
		head	bcp	when entering compilestate with {[}, 'lbrac'.
		tail	cp	when entering 1st nesting level
		bcp	explicit value by
				codespace allocation words
		btail	

	compiling values, {state} bits & bitmasks re "constants.inc"

================================================================
-- runtime primitives

	

 dobcons	( -- n )			(k)
	fetch unsigned single byte cons from codespace

 doscons	( -- n )			(k)
	fetch single cell cons from codespace

 dosvari	( -- p )			(k)
	fetch ptr to single cell vari from codespace

 douvari	( -- p )			(k)
	fetch ptr to user vari

 doucons	( -- n )			(k)
	fetch cell content of user vari

 (vr	  	( -- p )			(k)		'pdovar'	novoc
	return ptr to item in dataspace, kernel def'd {variable}

 (vl		( -- n )			(k)		'pdoval'	novoc
	fetch cell content from dataspace, kernel def'd {value}

 <pdo2val>	( -- n )			(k)
	fetch double cell content from dataspace, kernel def'd {value}

 ulitb  	( -- u )			(k)
	fetch unsigned(!) literal byte from compilespace

 litw		( -- n )			(k)
	fetch signed literal word from compilespace

 lit		( -- n )			(m,6)				hidden
	fetch cell from compilespace

 flit			( -- df )						hidden
	fetch double from compilespace

 dlit			( -- dn )						hidden
	fetch double from compilespace

 qlit			( -- qn )						hidden
	fetch quad from compilespace

 nlit			( -- .xx. N )						hidden
	compiled by {nliteral}, fetch bignum from compilespace

 (.")		( -- )(X: -- )					'pdotqtep'	hidden
 (.()		( -- )(X: -- )							hidden
	print compiled <nul> terminated string, for {."} and {.(}

 (")		(X: -- p )			(fg)		'pqtep'		hidden
 (c")		(X: -- p )			(a:ce)		'pqtep'		hidden
	compiled by {"} and {c"}, fetch non-alterable string ptr to stack

 (s")		(X: -- a u )			(a:ce)		'psqtep'	hidden
	fetch non-alterable string ptr & cnt to stack
	compiled by {s"}, {z"} 
	

----------------------------------------------------------------
-- branches
	compiled displacement is (destn - {c-here} at posn of disp)

 bcc						(n.i.)
	compare current eflags with compiled bytes pair,
	emulates { 1st eflags and 2nd xor 0= if ... },
	1st unmasks the relevant flagbits, 2nd defines
	which flag should be set to taking the branch.

 optimizing branches, not available to hi-level 4th

 0>branch					(f6)(k)		'gtbra'		hidden
	: 0> 0= IF

 +branch					(f6)(k)		'plbra'		hidden
	: 0< IF

 0-branch					(f6)(k)		'lebra'		hidden
	: 0>    IF

 0<branch	( n -- )(C: -- ptr 'bran' )	(fg)(k)		'mibra'		hidden
	: 0< 0= IF

 0branch	( n -- )(C: -- ptr 'bran' )	(fg)		'zbra'		hidden
	: IF
	conditionally branch if flag = 0, for WHILE, UNTIL

 ?0branch					(f6)(k)		'zdupbra'	hidden
	: -dup IF
	branch & drop if zero else dup

 -branch	( n -- )(C: -- ptr 'bran' )	(fg)		'nzbra'		hidden
	: 0= IF
	conditionally branch if flag =/= 0, for IF

 branch 	( -- )(C: -- )			(fg)				hidden
	unconditionally branch, for AGAIN, ELSE, REPEAT

 ?1branch					(f6)(k)		'nzdb'		hidden
	: -dup 0= IF
	discard @tos & enter true part if @tos = 0, else leave @tos

 ?=branch					(f6)(k)		'neqbra'	hidden
	: over  = IF drop
	enter true part and 2drop if @tos = @nos, for {?case}

-- hi-level loop runtimes

 (+loop)	( n -- ) (XR: n1 n2 -- n1 n3 | -- )		'pploopp'	hidden
	increment loop index by n from datastack and branch
	until next index(n2) increment overflows or equals limit(n1).

 (loop)  	(XR: n1 n2 -- n1 n3 | -- )			'ploopp'	hidden
	increment loop index by one and branch
	until next index(n2) increment equals limit(n1).

 (?do)  	( n1 n2 -- n1 n2 | )				'pqdop'		hidden
	if n1 =/= n2 push loop parameter to returnstack,
	else jump to after end of loop structure

 (do)								'pdop'		hidden
	push loop parameter to returnstack
	adjust limit to limit+1 if start = limit, to looping once only
	does{ swap 2dup = IF 1+ ENDIF >r >r }

 (leave)					(m,8)		'pleavep'	hidden
	prepare loop parametres such that next {loop} will terminate,
	stores limit := (1+index) to leaving structure at next {loop}

 (-leave)	( flg -- )			(fg)(m,15)	'pmleavep'	hidden
	conditionally prepare loop parametres such that next {loop} will terminate,
	if flg =/= 0 store limit := (1+index) to leaving structure at next {loop}

----------------------------------------------------------------
-- compiler control

	

-- state flags
	-re- {compiler} words and, source-file "constants.inc"

 <hpts>					(k)
	increment state level cnt, backup head and tail ptrs
      called by {]}, {]]}, structures and {create}.

 <hptr>					(k)
	reset state, restore cp from backup tail
	by {quit}, {error}
	

 ]]		( -- )						'rrbrac'	compiler
	for structures start, instead of {]}.
	should be used for any construct designed to before teminating the 
	currently defined word permitting an intermediately interpreting sequence.
	use{ ]] start .. [ .. (interpreting) .. ] .. end [[ }.

 ]		( -- )						'rbrac'		forth
	enter compiling state.
	increment compile-state level by one,
	clear intermediately interpreting state.

 [[		( -- )				(i)		'llbrac'	compiler
	for structures termination, instead of {[}, re {]]}.

 c[		( -- )						'clbrac'	root
	decrement compile-state level by one,
	leave state flags unchanged.
	at zero level of state execute until then compiled code.
	use{ ]] start .. ] ..next level cpl.. c[ .. end [[ }.

 [		( -- )				(i)		'lbrac'		root
	decrement compile-state level by one,
	if non-zero @state set interpreting state to intermediate,
	else execute until then compiled code.
	cannot be used as a structures terminator - re {[[} !

 cpl		( -- )				(i)				hidden
	advance {c-here} to current codeptr

 cpl;		( -- )				(i)				hidden
	terminate permanent code compilation

 <xcomp>	( -- )				(k)
	subroutine call, early ret to caller if not in compiling state

 <ccplq>	( -- )				(e)(k)		'ccplq'
	subroutine call for {cpl?} & internal use,
	eflags only, compiling state if NZ.

 cpl?		( -- flg )			(e)		'cplq'		root
	returns true if caller is in permanently compiling state
	(e: NZ if cpl)

 call-by-disp?  ( -- flg )					'cbdispq'	compiler
	true flag if call by immediate displacement compiling enabled.

 call-by-disp	( -- )				(i)		'cbdisp'	compiler
	enable call by displacement compiling mode.
	code executes 10%+ (up to about 50%) faster than by ref to u.o.t. 
	and compiles one byte shorter code for 4th words calls (5 bytes).
	call-by-disp mode compiles calls by PC-relative displacements which 
	thus depends on a particular lib4th version.

 call-by-uot	( -- )				(i)		'cbuot'		compiler
	enable call to indirect uot reference compiling mode.
	system default, 4th word calls are 6 bytes, ea.
	call-by-uot mode compiles indirect calls to uot cells by index 
	which is independent of a particular lib4th version.
	(re "lib4th.mac", <callx> and <jmpx> macroes for assembly level 
	(application programming.

 macro  	( -- )				(i)		'cmacro'	compiler
	enable expanded code compiling, flag in (bits) uvari.

 end-macro	( -- )				(i)		'cendmacro'	compiler
	disable expanded code compiling, flag in (bits) uvari.

 mac-disp	( ix -- n )			(i)		'macdisp'	compiler
	ret n = disp of macro code from xec entry,
	-ve n if word cannot be compiled as a macro.

 mac-size	( ix -- n )			(i)		'macsize'	compiler
	ret n = no. of bytes to be cpl'd in macro compiling mode,
	n = 0 if word cannot be compiled as a macro.

 asciz  	( -- n )					'hasciz'	compiler
	state-flag value for the asciz string compiling state,
	for {z"} & {place}, flg valid until next change of state.

----------------------------------------------------------------
-- codespace management, code insertion
	align & allot in dataspace
	calign & c-allot in codespace
	l-align & l-allot in local mem

	

	
-- local mem

 l-align  	( -- )				(a)		'xalign'	forth
	adjust ptr to local memory to lowest multiple of cellsize 
	greater or equal { lp @ }

 l-allot  	( n -- | abort )				'lallot'	forth
	allocate +/- b bytes in local memory, abort if out of memory

	
-- data-space, extendable range [@d0,@d-top)

	

 paligned  	( x -- x )					'palignp'	linux
	align-up true address/value @tos to memory page bounds

 paligned-	( x -- x )			(m,)		'palignm'	linux
	truncate true address/value @tos to memory page bounds

 aligned	( x1 -- x2 )			(a:c)(m,)			forth
	adjust x2 to lowest multiple of cellsize greater or equal x1

 aligned-	( x1 -- x2 )			(a:c)(m,)	'alignedm'	forth
	adjust x2 to lowest multiple of cellsize greater or equal x1

 FALIGNED	( x1 -- x2 )			(a:f)(m)			float
	adjust true address/value x2 to lowest multiple of 
	f.p.-item size (double cell) greater or equal x1.

 DFALIGNED	( x1 -- x2 )			(a:f)(m)			float
	adjust true address/value x2 to lowest multiple of 
	f.p.-item size (double cell) greater or equal x1.

 naligned	( a1 +u -- a2 )							forth
	adjust true address/value a2 to lowest multiple of +u greater or equal a1
	abort if +u is not a power of 2.

 FALIGN  	( -- )				(a:e)				float
	adjust ptr to dataspace to lowest multiple of f.p. size
	greater or equal {here}, and erase allocated memory.

 DFALIGN  	( -- )				(a:e)				float
	adjust ptr to dataspace to lowest multiple of double f.p. size
	greater or equal {here}, and erase allocated memory.

 align  	( -- )				(a)		'xalign'	forth
	adjust ptr to dataspace to lowest multiple of cellsize 
	greater or equal {here}.

 allot  	( n -- | abort )						forth
	allocate +/- b bytes in dataspace, abort-12 if out of memory

 ,		( n -- )					'comma'		forth
	allocate next cell in dataspace and store n
	abort-12 if unsufficient memory

 w,		( n -- )					'wcomma'	forth
	allocate next half-cell in dataspace and store l.s. 16 bits of n
	abort-12 if unsufficient memory

 b,		( n -- )					'bcomma'	forth
	allocate and store l.s.b. of n to next byte in dataspace
	abort-12 if unsufficient memory

 c,		( c -- )					'ccomma'	forth
	allocate and store c to next char in dataspace
	abort-12 if unsufficient memory
	

	
-- code-space, fixed range [@c0,@d0)
	

 cfalign	( -- )								forth
	adjust ptr to codespace to lowest multiple 
	of f.p.-item size (double cell) greater or equal {c-here}.

 calign  	( -- )								forth
	adjust ptr to codespace to lowest multiple 
	of cellsize greater or equal {c-here}.

 cnalign 	( n -- | abort-3)						forth
	align codeptr to nearest greater or equal multiple of n,
	abort if n not a power of 2.

 c-allot	( n -- | abort )				'callot'	forth
	allocate +/- b bytes in compilespace, alignment remaining unchanged.
	abort-12 if out of memory - which might abort due to a segfault, anyway...

 4,		( n -- ) 					'cpl4'		forth
	compile dword n, append <ret> code, advance cp by 4
	allocate next cell in code-space and store n

 2,		( n -- ) 					'cpl2'		forth
	compile l.s. word of n, append <ret> code, advance cp 2
	allocate next 2 bytes in code-space and store l.s. 16 bits of n

 1,		( n -- ) 					'cpl1'		forth
	compile l.s.byte of n, append <ret> code, advance cp by 1
	allocate next byte in code-space and store l.s.byte of n

-----------------------------------------------------------------
-- compiler-primitives, accessible at source assembly level, only
	
	NOTE: do not attempt to 'know' about the actually compiled
	code, since %macro-defs involved might have been modified!
	

	
-- compiling (executeable) data to codespace

 <cplp> 	( n -- ) or ( -- ), (R: addr -- )	(k)
	compile from pattern, n=/=0 supplies variable bytes if required
	compiles to {cp}+, adjusts {cp} to end of code.
	NOTE: do not attempt to 'know' about the actually compiled
	code, since %macro-defs involved might have been modified!

 <cpll>	(ecx:ptr edx:cnt) (R/S: -- )	(k)
	compile supplied length @nor of code @tor, -re- kernel word <cplp>

 ---

	c_<name>:	;compiling subroutine
		call cplp	; the code compiler
		db b1		; length of code
		db b2		; variable bytes within length, at end of code.
	d_<name>:	;compile patterns, don't execute!
		codebytes	; code- & vari-block to compile.
	.e:

	

	conditional jumps, dft ref'd to next location, i.e. disp = 0
	(B:"below", A:"above", L="less", G:"greater")
  O           0	O		(overflow flag set)
  NO          1	 		(overflow flag not set)
  C  B   NAE  2 U<	C		(carry flag set)
  NC NB  AE   3 U>=			(carry flag not set)
  Z  E        4 =	Z		(zero flag set)
  NZ NE       5 0=/=			(zero flag not set)
     BE  NA   6 U<=	C+Z		(either of carry or zero flags set)
     NBE A    7 U>	~C*~Z		(neither of carry or zero flags set)
  S           8 0<	S		(sign flag set)
  NS          9 0>=			(sign flag not set)
  P  PE      10	P		(even parity, flag set)
  NP PO      11			(odd parity, flag not set)
     L   NGE 12 <	S*~O+~S*O	(either one of sign or overflow set)
     NL  GE  13 >=			(neither one of sign or overflow set)
     LE  NG  14 <=	Z+S*~O+~S*O	(zero or either one of sign or overflow set)
     NLE G   15 >	~Z*(S*O+~S*~O)	(not zero and both, sign and overflow either unset or set)

	
 d_jccs  					(k)
	jcc short disp	$70(db)
 d_jccn  					(k)
	jcc near disp	$0f80(dd)
 d_jmps  					(k)
	jmp short disp	$eb(db)
 d_jmpn  					(k)
	jmp near disp	$e9(dd)
 d_calln  					(k)
	call dword disp	$e8(dd)
	

-- stack, exec.

 tospush  					(k)
	TOSPUSH(1)	$8d7f04
 tospull  					(k)
	TOSPULL(1)	$8d7ffc
 spush  					(k)
	free @tos for data item	$ab
	(may change, according to %macro spush, file <lib4th.mac>)
 spush2  					(k)
	free @tos for double data item, $abab (stosd, stosd)
	(may change, according to %macro spush, file <lib4th.mac>)
 spop						(k)
	drop @nos into @tos, $8B47FC8D7FFC
	patch -ve bytecount at byte {c-here}-1 and {c-here}-8, after compilation
	NOTE: code may be different, according to %macro spop, file <lib4th.mac>.

 c-dodoes	( -- )				(k)		'c_dds'
	cpl dodoes frame, pfa to be patched in at start+2
	cpl: lea edx,[pfa]; lea ecx,[edx+4]; add edx,[kref edx]; add edx,KR; jmp edx
 kcall  					(k)
	call [dword kref (disp)], $ff93(dd)
 xcalla  					(k)
	call [uref 4*reg+uv.ultab], $ff9485(ltab+dd)
 xcall  					(k)
	call [uref uv.ultab+(disp)], $ff95(ltab+dd)
 xjmp						(k)
	jmp [uref uv.ultab+(disp)], $ffa5(ltab+dd)
 ret 						(k)
	ret-code, $c3
 itld						(k)
	load T register: mov edx,imed, $ba(dd)
 iwld						(k)
	load W register: mov ecx,imed, $b9(dd)
 xtos						(k)
	mov eax,[uref uv.ultab+(disp)], $8b85(ltab+dd)
 utosa  					(k)
	add eax,[uref (disp)], add user vari, $0385(dd-link)
 utos 					(k)
	mov eax,[uref (disp)], $8b85(dd-link)
 ktos1  					(k)
	mov ecx,[kref (disp)], $8b8b(dd)
 ktosm  					(k)
	mov TOS(1),ecx, $894ffc
 ktos						(k)
	mov eax,[kref (disp)], $8b83(dd)
 itos1  					(k)
	mov TOS(1),imed, $c747fc(dd)
 tos						(k)
	mov eax,imed, $b8(dd)
 c-litp   	( n -- ) 			(k)		'c_litp'
	cpl single literal, add eax,dword n, $abb8(dd)

 c-plsto   	( n -- n ) 			(k)		'c_plsto'
	prepare cpl add and drop @tos to "value", add [kref dword n],eax\ <spop>
	caller must save c-here and store n to this ptr+2, after compilation,
	re {to} implementation for an example.	$8983(dd)8d7ffc8b07

 c-sto   	( n -- n ) 			(k)		'c_sto'
	prepare cpl store and drop @tos to "value", mov [kref dword n],eax\ <spop>
	caller must save c-here and store n to this ptr+2, after compilation,
	re {to} implementation for an example.	$8983(dd)8d7ffc8b07

 c-valu 	( n -- ) 			(k)		'c_valu'
	cpl single "value": <spush> : mov eax,[kref dword n], $ab8b83(dd)

 c-lit   	( n -- ) 			(k)		'c_lit'
	cpl single literal, <spush> mov eax,dword n, $abb8(dd)
	

 c-qvlit  	( qv -- )			(k)		'c_qvlit'
	cpl quad ranum (four cells' pair) literal

 c-qlit  	( q -- )			(k)		'c_qlit'
	cpl quad literal

 c-dlit 	( d -- ) 			(k)		'c_dlit'
	cpl double literal

 c-flit 	( f -- ) 			(k)		'c_flit'
	cpl double precision f.p. literal (n.i.)

 c-locv 	( n -- ) 			(k)(7)		'c_locv'
	cpl single local "value",
	<spush> : mov eax,[lref disp]

 c-locp 	( n -- ) 			(k)(10)		'c_locp'
	cpl ptr to a local "value",
	<spush> : mov eax,LP: sub eax,KR: sub eax,disp

 c-locto 	( -n -- ) 			(k)(13)		'c_locto'
	cpl local "to",
	mov ecx,@tos; spop;mov [lref disp],ecx

 c-plocto 	( -n -- ) 			(k)(13)		'c_plocto'
	cpl local "+to",
	mov ecx,@tos; spop; add [lref disp],ecx

 c-nlit	( .x. N -- )			(k)		'c_nlit'
	cpl counted integer

 -compile,	( ix -- )					'mcompilec'	forth
	compile call to ix if in compiling state, else execute.

 [compile]	ccc( -- )			(i)		'bcb'		forth
 POSTPONE	ccc( -- )			(i)		'bcb'		ans
 [_]		ccc( -- )			(i)(h4)		'bcb'		root
	suppress immediacy of next word <ccc> in input stream or,
	compile non-immediate word to being compiled at runtime.
	([compile], postpone and, [_] execute all the same code)

 compile,	( ix -- )			(a:cx)		'compilec'	forth
	cpl subroutine call by execution token ix:
	call [uref disp], w. disp=ix*4+uv.ultab-(uv.link)

 [,]		( ix | ix s1 -- | abort )	(i)		'bcompilecb'	root
	{[,]} takes uot index from tos or from below colon compiler structure

 statex	( ..xx.. -- ..yy.. )		(k)
	if @state =/= 0 execute from cell where RS points to,
	else do nothing. does{ r> state@ IF execute ENDIF }

================================================================
-- compiler
	process control, immediate & defining words

	

-- wordheader flags modifiers

 smudge  	( -- )				(e)				fig
	toggle smudge bit of -re- {latest} word-header.
	(e: Z flag reflects smudge state)

 unsmudge	( -- )								root
	mark -re- {latest} word-header ready for -re- {find}.

 immediate	( -- )								root
	modify -re- {latest} word to immediately executing. -re- {imed?}

 casedep	( -- )								compiler
	modify -re- {latest} word to only case dependently being found.

 no-opt	( -- )				(i)		'noopt'		root
	xec: modify -re- {latest} word to not optimizing jmp for ret.
	cpl: suppress latest word's jmp-modification by resetting the cpl'd 
	     words' counter to zero, uvari {(cmc)}.

 - header flags
	set   ( flag lfa -- ) { lfa>ffa or! }
	clear ( flag lfa -- ) { swap not swap lfa>ffa and! }

	
 cmac		( -- n )					'hcmac'		compiler
	header flag: compile-macro, bitmask to compiling inline code.

 imed		( -- n )					'himed'		compiler
	header flag: immediately executing, set by {immediate}; -re- {imed?}

 ixec		( -- n )					'hixec'		compiler
	header flag: do not compiled execute when in interpreting state;
	provision for the emergency case - e.g. {bye}, {cold}.

 pfax		( -- n )					'hpfax'		compiler
	header flag: execute from pfa in header, pass ptr to body in ecx

 nopt		( -- n )					'hnopt'		compiler
	header flag: suppress backward code optimizing

 smud		( -- n )					'hsmud'		compiler
	header flag: word finding disabled, un-set by {unsmudge}, toggled by {smudge}

 inif		( -- n )					'hinif'		compiler
	header flag: word which requires initialization from header data
	@pfa is ptr to init. code wrt beginning of module

 varf		( -- n )					'hvarf'		compiler
	header flag: 2nd-ary pfa holds disp to beginning of variables dataspace.
	used for default values and ptr's of kernel defined variables

 vocf		( -- n )					'hvocf'		compiler
	header flag: word is vocabulary, fieldcount is no. of wordheaders.
	set by -re- {vocabulary} or {wordlist} definition.

 wcas		( -- n )					'hwcas'		compiler
	header flag: word may only be found case dependently

 xwfl		( -- n )					'hxwfl'		compiler
	header flag: additional parameter-fields count mask (0..15),
	no. of dwords (cells) after concerning word header's pfa.

 imed?  	( n -- f )					'imedq'		compiler
	ret f =/= 0 if lfa or ix n points to an -re- {immediate} word.
	other flags -re- 
		{cmac} {imed}, {ixec}, {pfax}, {nopt}, {smud}, 
		{inif}, {varf}, {vocf}, {wcas}, {xwfl}
	flags set by the rsp. defining words; 
	a program should safely modify no other than {imed}, {smud}, {wcas}:
		set   ( flag lfa -- ) { lfa>ffa or! }
		clear ( flag lfa -- ) { swap not swap lfa>ffa and! }

----------------------------------------------------------------
 -- compiler
	

 -compile	ccc( -- )					'mcompile'	forth
	compile call to ccc if in compiling state, else execute.

 compile	( -- | abort-27 )						forth
	at runtime compiles next compiled word, abort-17 if not compiling.
	don't use in macro cpl mode: {compile} is not an immediate word and
	thus cannot catch any errors which might result from false opcodes.
	re {compile,} for compiling by execution token (ix, uot index).

 [CHAR]  	ccc(C: -- )(X: -- c )		(i)		'char'		ans
	compile leading char of next word in input stream as a literal
 ascii  	ccc(C: -- )(X: -- c )		(i)		'char'		forth
	dependent on @{state} compile or... -re- {CHAR} in ans-voc.
 CHAR		ccc(C: -- )(X: -- c )						ans
	fetch to stack the 1st char of next word in input stream as a literal.
	control chars can be fetched if (upper case) char prefixed w/ "^".

 literal	(C: x1 -- )(X: -- x1 )		(i)				forth
	cpl: compile sing as a literal, interp: noop

 2literal	(C: d1 -- )(X: -- d1 )		(i)		'dliteral'	forth
	cpl: compile double as a literal, interp: noop

 2LITERAL	(C: f1 -- )(X: -- f1 )		(i)		'adliteral'	ans
	cpl: compile float item (double cell) as a literal, interp: noop
	ANS mode, reversed (big endian) cells order.

 4literal	(C: q1 -- )(X: -- q1 )		(i)		'qliteral'	forth
	cpl: compile quad (four cells) as a literal, interp: noop

 qvliteral	(C: qv1 -- )(X: -- qv1 )	(i)		'qvliteral'	rational hidden
	cpl: compile four cells' pair (quad ranum) as a literal, interp: noop

----------------------------------------------------------------
-- imed, compiler
	immediate execution blocking until resolved

	

 drop;s  	( n -- )			(m,)(k)		'drops'		hidden
	{drop} and {;s}

 -exit  	( flg -- )			(i)		'dexit'		forth
	cpl/execute conditional {exit}, to exitting a word if flg =/= 0.

 (-exit)  	( flg -- )			(m,8)		'pdexitp'	hidden
	exit if flg =/= 0

 ;s		( -- )(R: a -- )		(m,1)		'semis'		forth
	immediately leave current & return to calling word at true address a.
	(e: no flags affected, pop RS & ret)

 exit		( -- )(R: a -- )		(i)		'exitf'		forth
	immediately leave current word & return to caller.
	compiles local values de-allocation and apropriate return opr.
	modifies last <call & ret> sequence to jmp into last word, 
	dependent on content of {(cmc)} vari and {nopt} header-flag.
	interpretive compiling locals de-allocation left to {;}.
	-re- conditional {-exit}, {else;}, {endif;}

=====================================================================;
 l4cpl.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4cstruct.inc>
--------------------------------------------------------------------------


 mark		( -- ptr )			(79)				forth
	push current {c-here} for later resolution of back reference

 back		( ptr -- )					'back'		forth
	cpl back reference at {c-here}, append <ret>.

 ahead  	( -- ptr )			(a:te)				forth
	push current {c-here},
	reserve cell in code-space for branch disp, append <ret>.

 >resolve	( ptr -- )			(79)		'toresolve'	forth
	resolve forward branch from ptr to {c-here}

 recurse	( -- )				(i)(a:c)			forth
	recursion (self call) efficient wrt programming effort, but... (resources!)
	one exception, though, is "tail recursion", which lib4th compiles to a branch.
	cannot be used with headerless words; should not be used in a {does>} part.
	recursive execution of run-time part in a defining word should be set up 
	separately to circumventing re-execution of the _defining_ word - example:
		: (lit>!) 1- dup 1 < if drop 1 1 else dup recurse endif dup * ;
		: lit>! create , does> @ (lit>!) ;
		10 lit>! 10!	10!	.
	tail recursion:
		: tt dup 0> if dup . endif 1- recurse ;
		see tt \ ">;" notifies the JMP instr. to latest word, "tt"

 begin  	( -- )(C: -- p f )		(i)				forth
	enter a loop structure, terminated by {again}, {repeat} or {until}.

 while  	- re {if} -			(i)				forth
	Forth (lib4th, etc) mode of operation:
	conditionally, if tf, continue execution until next {while},
	{repeat} or {until}, else terminate loop and continue after.
	multiple {while}s in a begin/until or begin/repeat structure
	resolved at end of loop, w/o additional words and, terminate 
	the loop execution as soon as one {while} part not entered.
	{while} cannot point to beyond the end of a {begin}...-loop!
	-re- {WHILE} in ans voc.

 WHILE   	- re {if} -			(i)		'whilea'	ans
	ANS-4th mode of operation:
	conditionally, if tf, continue execution until next {while},
	{repeat} or {until}, else terminate loop and continue after.
	resolve excess {while}s in a begin/until or begin/repeat structure
	by an equal number of additional {else}/{then}, after loop end.

 repeat  	(C: pn fn .. p f -- pm fm )( -- )(i)				forth
	unconditionally branch back to after {begin}.
	{repat} resolves {begin} and as many {while}s as used after the 
	corresponding {begin}. -re- ans {WHILE} for ANS-style resolution.

 again  	(C: p f -- )( -- )		(i)				forth
	unconditionally branch back to after {begin}.

 until  	(C: .. p1 f1 -- .. pm fm )(X: flg -- )(i)			forth
	{until} resolves {begin} and as many {while}s as used after the 
	corresponding {begin}. -re- ans {WHILE} for ANS-style resolution.

 (unloop)					(ac)		'rdrop2'	hidden
	immediately discard loop parameters
	{unloop} runtime, executes {2rdrop}.

 UNLOOP  	( -- )				(i)(a:c)(wc)			ans
	discard loop parameters, i.e. limit and index on RS. requires 
	{exit}ting before next LOOP or explicit branch to after the LOOP disp.

 ?do		( n1 n2 -- )(R: -- n1' n2' )	(i)(83)		'qdo'		forth
	enter a LOOP structure if n1 =/= n2, else continue after it's end
	compiles{ (?do) ... (loop?) }.

 +loop  	( n -- )			(i)		'ploop'		forth
	increment loop counter by n, branch back to after {do}/{?do} if
		n > 0: counter unsigned less than limit,
		n < 0: counter unsigned greater than limit.

 do		(C: -- p f )(X: n1 n2 -- )(R: -- n1' n2' )	(i)		forth
 	C: f:"dudu" p:c-here
	X: push loop limit and start to tor and enter LOOP structure,
	   if n1 = n2 adjust n1 := n1+1 to loooping once, only

 if		( n -- )			(i)				forth
	if n =/= 0 enter code immediately following {if}
	else branch forward to next {else} or {endif}, rsp.

 0if						(i)		'nif'		forth
	substitutes { 0= if }, used in {-enter}

 ?case  	( n1 n2 -- n1 | )		(i)(k6)		'qcase'		forth
	does{ over = if drop }, resolved with {else}/{endif}.
	use{ nn ..words.. n1 ?case ..words.. else n2 ?case ... endif endif }

 branch  	( n -- )			(i) n.i.	'ibranch'	forth
	branch by disp = n wrt PC after {branch} code.

 loop		(C: p f -- )(X: -- )		(i)		'xloop'		forth
	increment loop counter by one, terminate { do .. loop } if counter = limit.

 else		(C: p1 f1 -- p2 f2 )(X: -- )	(i)				forth
	begins alternate part of {if .. else .. endif } decision

 endif  	(C: p f -- )(X: -- )		(i)				forth
 THEN		synonym to {endif}				'endif'		ans
	terminates { if .. else .. endif } decision

 endif;  	(C: p f -- )(X: -- )		(i)		'endifs'	forth
	substitutes { ... exit endif }. saves the {exit} code.

 else;  	(C: p f -- )(X: -- )		(i)		'elses'		forth
	substitutes { ... exit else ... },
	saves {exit} and eliminates the unconditional branch to after {endif}.

 enter  	(C: -- p1 f1 )(X: -- )		(i)		'nter'		forth
	unconditionally branch forward into a structure to
	resolving multiple inner unconditional branches of
		{ .. begin ... while ... repeat }
	to a single one on entry, e.g.
		{ .. enter begin ... entry ... until }

 -enter    	(C: -- p f )(X: flg -- )	(i)		'mnter'		forth
	conditionally, if true flg, branch forward to after {entry}
	else continue execution immediately after {-enter}. for instance:
	{ .. .nn. -dup -enter .. enter begin .. entry .. entry ... until }
	                  | false  `----->--------'        |
	                  `->--true------>-----------------'
	{enter} and {-entry} may multiply be nested around a single {begin}.

 entry  	(C: p1 f1 p2 f2 -- p2 f2 )(X: -- )(i)		'ntry'		forth
	entrypoint from branch into a BEGIN.. or IF.. construct via {enter}.

 -leave  	(X: flg -- )			(i)		'dleave'	fig
	leave if non-zero flag - fig-4th mode!
	use{ DO ..words1.. condition -LEAVE ..words2.. LOOP }
	wherein {words2} will be executed, whether leaving or not.

 leave  					(i)		'xleave'	forth
	NOTE: fig-4th mode of operation, i.e. actually leaving a
	DO..LOOP structure is delayed till next {loop} execution.
	use{	DO ..words1.. condition 
		 IF ..words2.. LEAVE ..words3.. \ executes words2 and(!) words3
		 ELSE ..words4.. ENDIF
		..words5.. LOOP }
	wherein {words5} will be executed, whether leaving or not.

-- ANS-4th case construct

 CASE		( n -- n )(C: -- f f )		(i)				ans
	CASE-group is nothing really useful, just a simplification to writing
	a sequence of cascaded IF/ELSE decisions, required by DPANS 6.2.0873:
	  { n1 CASE n2 OF ..true.. ENDOF  n3 OF ..n3-true.. ENDOF .. ENDCASE }
	-re- {case:} in forth-voc. for a much more efficient 'substitute'...

 OF		( n1 n2 -- | n1 )(C: -- p f )	(i)				ans
	if n1 = n2 drop both and enter code after {of},
	continue until {endof} and branch to after {endcase}
	if n1 =/= n2 drop n2 and continue after next {endof}
	substitutes { over = if drop .... }

 ENDOF  	( -- )(C: p f -- p' f )		(i)				ans
	terminate code sequence after {of}, synonym to {else}.

 ENDCASE	( n1 -- )(C: p'1 f1 ... p'n fn -- )(i)				ans
	terminate and resolve a {case} structure.
	compiles a {drop} of the comarison item and, as many {endif}s as 
	{OF}s were encountered, after the latest initiating {CASE}.

 DEFAULT	( n1 -- n1 )			(i)				ans
	a {noop} word, may be used to point to last statement before {endcase}, 
	section after last {endof} receives the {case} comparison value which 
	will be dropped from tos by {endcase}.

	

=====================================================================;
 l4cstruct.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4debug.inc>
--------------------------------------------------------------------------


 dbg		beginning of debugging routines

 puvari					(k)(u)
	debugging utility, display main user vari

=====================================================================;
 l4debug.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4defining.inc>
--------------------------------------------------------------------------


-- word header ---

 build  	( p -- )							hidden
	build a word header at {here}, linked to {current} wordlist.
	pass ptr p to subroutine for fetching a valid name which should move 
	the name stg to build-time {here} and leave that ptr and true flag 
	on tos - entry to {head} w/o error handling.
	{build} in contrary to {head} does neither, {align} nor {!csp}.

 head		ccc( -- )							hidden
	{align} data-space to multiple of cellsize,
	store data-stack ptr to {csp} - re {ds-pick},
	build a word header at {here}, linked to {current} wordlist,
	leave header 'smudged', not ready to {find}.
	NOTE:
	{head} implements semantics like fig-forth "create".
	  [idx|flg][macflg][link][cnt+name][data...] - [items] 4-aligned.
	  ^ifa^ffa ^-mfa   ^-lfa ^-nfa     ^-pfa
	initial flg=smud, macflg=0, pfa={ here cell - }
	>body returns pfa+4, pfa is storage of executeable words' xec-ptr.

 alias  	ccc( ix -- )							tools
	defines a synonymous word, ccc, executing xec token ix.
	no code, header only: 28 + 4-aligned (namelength+1) bytes in data-space.
	NOTE: {alias}ed words conflict w/ {forget} and {:forget}.

-- defining words ---

 end-code							'endcode'	assembler
	terminates assembly sequence, after ;code, in interpreting state

 ;		( -- )(S: s1 [ s2 ] -- |abort )	(i)		'semi'		forth
	terminates a colon definition.
	modifies last <call> to <jmp> to preventing call+ret sequence,
	which is disabled after a structure's end-ptr or, {cmc-off}.
	leaves final <ret> in place, for safe return from compiler.

 :		ccc( -- s1 )					'colon'		forth
	begin a named hi-level definition, linked to {current} wordlist.
	ANS mode: leaves s1 = ptr-s to codespace and datastack on datastack!
	for fig-compatible handling and {;code}, stores initial SP to {csp}.

 code		ccc( -- )(C: -- )		(a:tx)				forth
	cpl:
	begin named lo-level definition which, initially is not <ret> terminated 
	and does not set-up nor leave any control data in the compile-stack. 
	word ccc can be found immediately after creation by {code} and, should 
	be orderly continued and terminated before return to the interpreter.
	xec:
	W-register <ecx>, [kref ecx] = pfa+cell = >body of word ccc
	T-register <edx>, [kref edx] = code entry
	(an entirely useless word, just to complying ANS-4th setup and, not tested!)

 create  	ccc( -- p )(C: -- )		(w)				forth
	xec:
	word ccc leaves ptr to {here} in dataspace at definition time which is 
	the same ptr which {>body} would return, one cell after the word's pfa.
	cpl:
	build by name executeable word header, linked to @{current} wordlist.
	compiles literal ptr to after <pfa> & <ret> to {c-here}, 7 bytes in codespace.
	data arranged such that
		{ ' ccc idx>pfa @ } equals { ' ccc idx>xec }

 2constant	( -- dn )(C: dn -- )		(a:d)		'twocons'	forth
	non-alterable const double value, compiled to codespace.

 4constant	( -- qn )(C: qn -- )		(a:d)		'qconstant'	forth
	non-alterable cons quad value, compiled to codespace.

 :noname	(C: -- ix )					'noname'	forth
	begin headerless hi-level definition, leave uot index after terminating {;}.
	{:noname} definitions occupy an uot item, ea., but no header-space.
	for fig-compatible handling and {;code}, stores initial SP to {csp}.
	use{ :noname ... ;    : word .. [ 0 cs-pick ] [,] ... ;    drop }

 variable	ccc( -- p )(C: -- )		(a:c)				forth
	create named ptr to a cell of reserved dataspace (ANS: initiated to zero)
	execution of name ccc leaves same ptr as { ' ccc >body }.

 2variable	( -- p )(C: -- )		(a:c)		'twovari'	forth
	create named ptr to double cell of reserved dataspace (ANS: initiated to zero)

 4variable	( -- p )(C: -- )		(a:c)		'qvari'		forth
	create named ptr to quad cell of reserved dataspace (ANS: initiated to zero)
 <with  	ccc( -- )			(f6)(n.i.)	'ltwith'	forth

 wordlist	ccc(C: -- )(X: -- wid )		(a:s)				forth
	create an empty, named wordlist, linked into {voc-link} chain
	re DPANS 16.6.1.1595: number of wordlists is not limited.

 vocabulary	ccc( -- )(X: -- )						forth
	re DPANS 16.6.1.1595: the number of vocabularies is not limited!

 constant	( -- n )(C: n -- )		(a:c)				forth
	defines a named, non-alterable sing numeric literal.

 4integer	ccc( -- dn )(C: dn -- )		(h4)((i))	'integer4'	forth
	immediate, non-alterable quad cons, which executes a 4literal.
	value can be altered e.g. w/ { ' name >body 4! }, before compiling.

 (i4		( p -- qn )			(i)		'dointeger4'	novoc
	immediately fetch {4integer} as a {4literal} from data-space.

 2integer	ccc( -- dn )(C: dn -- )		(h4)((i))	'integer2'	forth
	immediate, non-alterable double cons, which executes a 2literal.
	value can be altered e.g. w/ { ' name >body 2! }, before compiling.

 (i2		( p -- dn )			(i)		'dointeger2'	novoc
	run-time code: immediately fetch {2integer} as a {2literal} from data-space.

 integer	ccc( -- n )(C: n -- )		(h4)((i))			forth
	non-alterable sing cons, IMMEDIATEly compiling a literal.
	literal value can be altered with {to}, {+to}, before compiling, 
	e.g. to determining a constant at compiletime from program data. 
	modification does NOT affect already compiled {integer}s.
	can substitute { create , } but, would also declare ccc 'immediate'!

 (i1		( -- n )			(i)		'dointeger'	novoc

 val+  	ccc( n -- )(X: n1 -- n2 )			'valp'		forth
	increments @tos n1 by "value" n

 cons+  	ccc( n -- )(X: n1 -- n2 )	((i))		'consp'		forth
	increments @tos by non-alterable literal value n
	{cons+} compiles an IMMEDIATE word which compiles a literal increment.

 =:		ccc( -- n )(C: n -- )		(h4)(p4)	'valdef'	forth
	store n to previously defined {value} or {integer} if found in 
	current search order. otherwise, in interpreting state, define 
	a new, alterable -re- {value}.

 value  	ccc( -- n )(C: n -- )		(a:cx)				forth
	self fetching variable, w/ -re- {to}, {+to}, {=:} alterable cons.
	value of ccc stored to dataspace and alterable at { ' ccc >body }.
	{value}s can be altered with {to} and {+to}, which also affects 
	already compiled words. fetching and storeing a {value} is usually 
	faster than the rsp opr on a {variable}.

 +>		ccc( n -- )			(i)(p4)		'pltov'		ans
 +to		ccc( n -- )			(i)(a:cx)	'pltov'		forth
	add n to a {value}, equivalent to { ' name >body +! }.
	can substitute {+!} to a {variable}, by about 10% faster.
	defines new {value} if in interpreting state and ccc unknown.

 ->		ccc( n -- )			(i)(p4)		'tov'		ans
 to		ccc( n -- )			(i)(a:cx)(a:l)	'tov'		forth
	store new number to a {value} - equivalent: { ' name >body ! }.
	also substitutes {!} to {variable}s or {defer}red words.
	values storeing with { to name } is a (tiny) bit faster than with 
	{ [ ... ] literal ! } and by about 10% faster than { vari-name ! }.
	(this would have been much simpler with just a compile-flag if ANSI didn't 
	(decide differently, due to whatever reason -if any- re DPANS, A.6.2.2295.

 2value  	ccc( -- n )(C: n -- )				'value2'	forth
	double, alterable cons.
	value of ccc stored to dataspace and alterable at { ' ccc >body 2! }.
	altered {2value}s also affect already compiled words.

 2to		ccc( dn -- )			(i)		'to2'		forth
	store double to a {2value}
	does{ ' name >body 2! }  w/o error checks!

 does>  	( -- )(C: s1 -- s1 )(X: -- p )	(i)		'doesgt'	forth
	terminates defining part compilation of defining word, 
	compiles (;code) ;S, continues defining hi-level runtime procedure.
	defining word will not be found until after terminating {;}.
	the {does>} part of a word can be provided by a separate definition.
	NOTE: implemented such that it does not permit multiple {does>} in a
	single defn - which may be enabled w/ <__mdoes>, re lib4th Makefiles.

 (;code)							'pscodep'	assembler
	cpl'd by {does>}; appends runtime semantics to current defining word.
	NOTE: definitions using a such created word cannot compile access 
	      by uot and thus should reside in the same binary module.

 ddo		( -- )				(r)		'dodoes'	novoc
	xec from pfa: [ dodoes ][ kref<pfa> ]
		 pfa: [ kref<cfa> ][ ..data.. ]
	compiled to code-space in RAM at startup time, re <iwlink>
	arg passing by W-reg, <ecx>

 (code)  					(4)		'pcodep'	assembler
	terminates a colon definition, returns to interpreting state. -?-

 ;CODE  					(a:tx)(ix)(4)	'scode'		ans
	terminates a colon definition, returns to interpreting state. -?-

 defer  	ccc(C: -- )(X: ..xx.. -- ..x.. )(ix)				forth
	execute word the uot index or true xec-address of which is stored in data body.
	at runtime reverts to default action if defined word not in valid memory range.
	null ptr de-activates the deferred word and does not revert to default action.
	compiles an initial {forget>} which removes the word from the {defer-lk} chain,
	additional forget-handlers may be assigned, which execute prior to the default.
	xec de-activated if ix = 0 or (fastest) { 0 4th>abs } at data body.
	{defer}red words linked to {defer-lk}:
		defer-lk dup @ +	-> ptr to last link
		<lastlink> dup @ +	-> ptr to previous link, <zero> at end of chain

 ddf		(X: p -- xx )			(k)		'dodfer'	novoc
	runtime entry from {defer}.
	cplmem: ptr to pc(data) -> [ xec(code) | xec(default) | linkage ]
	reverts to default action if defined word not in valid memory range.
	{noop} if p is null-ptr (=kref+0) or zero.

 ddk		(X: -- p )			(k)		'pdodefer'	novoc
	kernel deferred -re- {ddf}

 ndf    	( -- error-26 )			(k)		'ndferd'	novoc
	#26 error, "xec vec undefined"

 ?deferred	( ix -- | error-26 )				'qdferd'	forth

 df?		( f -- | error-26 )		(k)		'dfder'		novoc
	0= #26 ?error

 dfg		( ix -- ix )			(k)		'dfdfg'		novoc
	deferred default forget action

 deferred?	( ix -- f )			(4)		'dferdq'	forth
	tf if word the xec token of which is ix is linked to the deferred words chain.

 is?		ccc( -- ix )					'isq'		forth
	fetch xec token which the deferred word ccc will execute

 is@		( ix -- ix1 ix2 | abort-26 )			'isf'		forth
	fetch default ix1 and xec token x2 of a deferred word.

 is		ccc( -- | abort-26 )		(4)(i)				forth
	check and store an execution token to deferred word.
	use{ ' name is deferred-word }, for the default opr -re- {is-default}.
	use{ ['] name is deferred-word } while ANS-mode compiling.
	{>body} and {to} may be used, instead, which do no error checking.

 (is		( p -- )					'dois'		novoc

 default-is	ccc( -- )			(4)(i)		'defaultis'	forth
	restore a deferrred words default action
	use{ default-is deferred-word }

 (di		( pp -- )					'dfi'		novoc

 is-default	ccc( ix -- )			(4)(i)		'isdefault'	forth
	store default action to deferred word
	use{ ' action is-default deferred-word }

 (dd		( pp -- )					'ddi'		novoc

	
--- multi-decision lists, case:, range:, associative:
	

 casehead-size	( -- n )					'caseheadsz'	hidden
	size in bytes of a {case:}-list header -re- <inc/l4struc.inc>

 is-case	ccc( n1 n2 -- )			(4)(i)			'iscase'	forth
	store list item n1 to list w/ name ccc at posn by index n2
	 
	data type flag at 1st cell of data body,
	over-all list bytes size stored at 2nd cell of data body, -re- {cases,}.
	
	forcing to numeric type:
		{ -1 ' listname >body c! }
	testing whether an index fits into list:
		{ ( caseindex ) 4* casehead-size + ' listname >body 4+ @ 4- > }
	  which returns tf if index was out of range.
	  list entries follow at {casehead-size} bytes disp to data body.
	modifying a list entry:
		{ ( new-entry caseindex ) 4* casehead-size + ' listname >body + ! }

 #case	( -- n )					'ncase'		forth
	if 1st in a compiled word, case:-index by which the word was called.
	(can be used to reading the <edx> register content)

 case:  	xec: ( caseindex -- xx )	(i)(f6)(h4)	'caseco'	forth
 		cpl: cc1 cc2 ... ;	( -- )	while compiling
 		def: name cc1 cc2... ;	( -- )	while interpreting
	initiate a case decision by index list of executeables or numeric data:
	cpl:
		compile typed list of xec tokens or sing numeric values.
		list may span multiple lines w/ words separated by {bl}s, only, 
		and may be interleved w/ {\ ...} comment lines.
	def:
		compile header for later execution by name, procede as above.
	xec:
		check range and according to type, push indexed value or execute.
	
	Executeable type list is a 'jump table' of xt-s, by ix or true address, 
	numeric type returns the rsp. entry corresponding to the supplied index.
	state dependently built as a named word or, compiled into a forth word. 
	valid range: -1 < caseindex < no. of items,
	at list execution ovf indices will be fetching from the rsp bounds.
	(rather hypothetical) max. no. of list items is 2^31-3.
	A numeric mode list will be compiled if any one list item was not found 
	as a forth word in current search order, but could be converted to some
	numeric value, compiling it's least significant cell, any excess data 
	silently discarding. That list returns the rsp. xec token (uot index) in 
	any case an executeable word was specified.
	
	defining a list
		compiles each non-immediate item w/ -re- {cases,} until
		1st {;} which terminates the list, from input stream;
		executes other immediates - which should not leave more 
		than one cell on data-stack.
	  while compiling
	  compiles a {case:} list into the current word:
		..words.. case: case1name case2name .. lastcasename ; ..words..
	  while interpreting
	  builds the by <listname> executeable {case:} list:
		case: listname case1name case2name .. lastcasename ;
	execution:
		xec indexed compiled word or, push indexed value to data-stack.
		-ve index refers to 1st, +ve beyond last refers to last item.
	modifying a list
		-re- {is-case}

 (dc		( ix p -- xx )			(f6)		'docasec'	novoc
	according to list type fetch or execute by ix indexed cell

 (kc		(X: -- p )			(k)		'pdocasec'	novoc
	kernel deferred -re- {(dc}

 cases, 	ccc..( -- p )			(f6)		'casesc'	hidden
	initiate and build a 'cnum'-list, from uot indices ('xec tokens') or 
	numeric values as found in current search order, from input stream, 
	cpl list items into data-space until {;}, xec other immediates. 
	ret ptr to list header.
	preceded w/ a header field of top case-index and list type:
		[ list-type flags][ listsize bytes ][ 1st item ] .. [ last ]
		all entries of cell-size, <listsize> inclusive header cells.
		l.s.b. flags =/= 0 is numeric type, remaining space reseved.
	list structure subject to change, -re- {casehead-size}, {case:}.

 (#,		( p -- p n | p )		(k)(f6)		'cpasfq'	novoc
	fetch a single list item, ret eax & S if ix or num fetched
	empty stack and Z after {;}, NS*NZ*NZ ok & no data after imed
	abort-31 if neither word nor number

 (ch		( -- p )			(f6)		'ccasec'	novoc
	build named list for {associative:}, {case:}, {range:}

 range: 	xec: ( n1 -- n2 )		(f6)		'rangec'	forth
 		def: cc1 cc2 ... ;	( -- )	while compiling
 		def: name cc1 cc2... ;	( -- )	while interpreting
	{ range: rg n1 n2 .. nn ; nx --rg-- nn : nn := index(nm), nm <= nx < nm+1
	i.e. ret. index is 0 for values below 1st, num(items) for values above top, 
	and, within list range the no. of greatest item which is equal or below n1.
	list structure and compiling rules otherwise as numeric -re- {case:}.

 (dr		( n1 p -- n2 )			(f6)		'dorangec'	novoc

 (rc		(X: -- p )			(k)		'pdorangec'	novoc
	kernel deferred -re- {(dr}

 associative:	xec: ( n1 -- n2 )		(f6)		'assocc'	forth
 		def: cc1 cc2 ... ;	( -- )	while compiling
 		def: name cc1 cc2... ;	( -- )	while interpreting
	return list index n2 of found value n1, else top index+1
	list structure and compiling rules otherwise as numeric -re- {case:}.

 (ac		(X: -- p )			(k)		'pdoassoc'	novoc
	kernel deferred -re- {(dc}

=====================================================================;
 l4defining.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4dsarith.inc>
--------------------------------------------------------------------------


================================================================
-- arithmetic opr

----------------------------------------------------------------
-- single integers

 abs		( n1 -- n2 )			(e)(m,10)	'cabs'		forth
	negate n1 if -ve; { dup 0 min minus swap 0 max max }
	"negative zero" case: ret 0 if n1 = -0
	(e: C if n1 was -0)

 ABS		( n1 -- n2 )			(e)(m,6)	'aabs'		ans
	ret n2 := | n1 | = { dup 0 min minus swap 0 max max }
	no "negative zero", ret n2 := n1 if n1 = -0
	(e: C if n1 was -0)

 0max		( n1 -- n2 )			(k6)(m,6)	'zmax'		forth
	n2 = n1 larger than or adjusted equal to zero

 max		( n1 n2 -- n3 )							forth
	ret the larger of two signed single integers

 umax		( u1 u2 -- u3 )							forth
	ret the larger of two unsigned single integers

 min		( n1 n2 -- n3 )							forth
	ret the smaller of two signed single integers

 umin		( n1 n2 -- n3 )							forth
	ret the smaller of two unsigned single integers

 +-		( n1 n2 -- n3 )			(fg)		'spm'		forth
	apply sign =/= 0 of n2 to n1.

 negate  	( n1 -- n2 )							forth
	2-s complement sing @tos

 minus  	( n1 -- n2 )			(fg)(m,2)	'negate'	forth
	2-s complement sing @tos

 +		( n1 n2 -- n3 )			(e)(m,8)	'plus'		forth
	2-s cpl add single cells

 -		( n1 n2 -- n3 )			(e)(m,10)	'ssub'		forth
	2-s cpl subtract sing

 swap-  	( n1 n3 -- n3 )			(e)(m,8)	'swsub'		forth
	reverse subtract: leave result of { n3 n1 - }

 mod		( n1 n2 -- r )			(e)				forth
	2-s cpl div sing remainder

 /mod		( n1 n2 -- r q )		(e)		'bymod'		forth
	2-s cpl div sing remainder & quotient, 'floored'

 /		( n1 n2 -- q )			(m,11)		'by'		forth
	2-s cpl div sing quotient, 'round near zero' mode
	if n2=0 ret q = sgn(n1) ovf value or, 1 if n1=n2
	check zero or ovf conditions before, if macro compiling.

 gcd		( n1 n2 -- u3 )			(e)		'gcd'		forth
	greatest common denominator u3 of the absolute value of two signed sings. 
	If either number is zero, returns the absolute value of the other number.
	(e: Z if u3 = 1)

 *		( n1 n2 -- n3 )			(m,6)		'smul'		forth
	multiply sings

 */mod  	( n1 n2 n3 -- n4 n5 )		(e)(a:c)	'mulbym'	forth
	signed divide by n2 double product of signed multiplication n1 by n2
	leave signed quotient n5 and remainder n4; rounding mode near zero.
	(e: overflow into double quot can be checked with NZ flag from {flg}.

 */		( n1 n2 n3 -- n4 )				'mulby'		forth
	signed divide by n2 double product of signed multiplication n1 by n2
	division result rounding mode as with m/.
 
 lg(base)	( n1 -- n2 )							forth
	numerus of log n1 wrt actual {base}
	(which is one less than count of digits of the printed number n1)
	hi-level defn:
		: lg(base) 0 begin swap base @ / ?dup while swap 1+ repeat ;
 
 log		( n1 n2 -- n3 )							forth
	numerus of log n1, to the base of n2; if n1 = 0 ret n3 := 0

 lg2    	( d1 -- n2 )					'lg2'		forth
	ret n2 = numerus of log double, d1 to the base of 2

 2^	  	( n1 -- d2 )					'pow2'		forth
	ret d2 := n1-th power of two, -1 < n1 < 64

 pow2?  	( n -- flg )			(e)		'pow2q'		forth
	tf if signed n is a power of 2 (including n=1, n=80000000h).
	(e: flg value)

 bsf		( n1 f -- n2 | -1 )				'bsff'		forth
	scan for bit-no. n2 of 1st set bit, beginning at least significant bit,
	use n1 as a cell value if f=0 -re- {bsfr}-
	else n1 = ptr to memory and cells range = f -re- {bsfm}:
		{ n 0 bsf } aequivalent to { n sp@ 1 bsf }.

 bsfm		( p n1 -- n2 | -1 )						forth
	bit scan forward in memory, range limited by count n1 > 0 cells.
	ret bitcount n2 from ptr p to the 1st non-zero bit in address range [p,p+n1*4].

 bsfr		( n1 -- n2 | -1 )		(m,10)				forth
	bit scan register

 bsr		( n1 f -- n2 | -1 )				'bsrf'		forth
	scan for bit-no. n2 of most significant set bit, beginning at m.s. bit,
	n1 = cell value if f = 0, else n1 = ptr to memory, scanning up to f cells.

 bsrm		( p n1 -- n2 | -1 )						forth
	bit scan reverse in memory, range limited by count n1 > 0 cells.
	ret bitcount n2 from ptr p to the last non-zero bit in address range [p,p+n1*4].

 bsrr		( n1 -- n2 | -1 )		(m,10)				forth
	bit scan register

 tstb		( p1 n2 -- flg )		(m,13)				forth
	the cpu BT memory instruction, flg =/= 0 if specified bit is set.
	test bit no. n2 in range of [-2^31..2^31-1] wrt memory ptr p1.

 setb		( p1 n2 -- flg )		(m,13)		'setb4'		forth
	the cpu BTS memory instruction, set bit n2 wrt n1 - re {tstb}

 resb		( p1 n2 -- flg )		(m,13)		'resb4'		forth
	the cpu BTR memory instruction, reset bit n2 wrt n1 - re {tstb}

 cplb		( p1 n2 -- flg )		(m,13)				forth
	the cpu BTC instruction, complement bit n2 wrt n1 - re {tstb}

----------------------------------------------------------------
-- double integers

	

 d+-		( d1 n1 -- d2 )			(79)		'dpm'		forth
	apply sign of sing n1 to double d1.

 dabs		( d1 -- +d1 )			(f6)				forth
	negate double d1 if -ve

 dminus  	( d1 -- -d1 )			(fg)(m,8)	'dnegate'	fig
 dnegate	( d1 -- -d1 )			(a)(m,8)			forth
	2-s complement of double
	(eflags reflect result)

 u+		( dn1 u2 -- dn3 )		(e)		'uplus'		forth
	unsigned add dn1 + u2 := dn3
	(eflags reflect double cell addition)

 m+		( dn1 n2 -- dn3 )		(e)(79)		'mplus'		forth
	signed add n2 + dn1 := dn3
	(eflags reflect double cell addition)

 d+		( dn1 dn2 -- dn3 )		(e)		'dplus'		forth
	add d2 to d1
	(eflags reflect double cell addition)

 d-  		( dn1 dn2 -- dn3 )		(e)		'dsub'		forth
	subtract d2 from d1
	(eflags reflect double cell subtraction)

 ud*		( ud1 ud2 -- ud3 )		(4)		'udmul'		forth
	unsigned multiply doubles, ret double prd

 d*		( d1 d2 -- d3 )			(4)		'dmul'		forth
	signed multiply doubles, ret double prd

 dmod   	( d1 d2 -- d3 )			(4)				forth
	divide doubles d1 by d2, leave signed double rmd d3

 d/		( d1 d2 -- d3 )			(4)		'dby'		forth
	divide doubles d1 by d2, leave signed double qot d3

 d/mod  	( d1 d2 -- d3 d4 )		(4)		'dbym'		forth
	divide doubles d1 by d2, leave signed doubles rmd d3 and qot d4

 dgcd  	( d1 d2 -- d3 )			(4)		'dgcd'		forth
	returns the greatest common denominator d3 of the absolute value of two signed 
	doubles. If either number is zero, returns the absolute value of the other one.
	

----------------------------------------------------------------
-- mixed double and sing
	

 m/mod  	( dn n1 -- n2r n3q )		(v)		'mbym'		forth
	double by sing to sing rmd and quot division,
	xec from uvari (m/mod) which initially is vectored to {sm/rem}.

 sm/rem  	( d1 n1 -- r2 q3 )		(e)(a:c)	'smbyrem'	forth
	signed divide d1 by n1,
	leave symmetric quotient q3 and remainder r2.
	Dividend Divisor | Quotient Remainder
	-------- ------- + -------- ---------
	   20       7    |     2        6    
	  -20       7    |    -2       -6    
	   20      -7    |    -2        6    
	  -20      -7    |     2       -6    
	 dvs = 0 ovf:
		dvd > 0  $7fffffff  $7fffffff
		dvd < 0  $80000001  $80000001
		dvd = 0          1   0
	(e: overflow into double quot. if NZ flags)

 m/		( d1 n2 -- n3 d4 )		(e)		'mby'		forth
	signed divide double d1 by single n2,
	leave symmetric double quotient d4 and remainder n3.
	Dividend Divisor | Quotient Remainder
	-------- ------- + -------- ---------
	   20       7    |     2        6    
	  -20       7    |    -2       -6    
	   20      -7    |    -2        6    
	  -20      -7    |     2       -6    
	 dvs = 0 ovf:
		dvd > 0  $7fffffff.ffffffff  $7fffffff
		dvd < 0  $80000000.00000001  $80000001
		dvd = 0          0.00000001   0
	[hopefully, all that sick "exceptions" stuff will safely be intercepted...

 um/mod  	( ud u1 -- u2 u3 )		(e)(GA)		'umbymod'	forth
	unsigned divide ud by u1
	leave quotient u3 and remainder u2.
	 dvs = 0 ovf:
		dvd > 0  $ffffffff $ffffffff
		dvd = 0          1 0

 um/		( ud1 u2 -- u3 ud4 )		(e)		'umby'		forth
	unsigned divide double ud1 by single u2,
	leave unsigned double quotient ud4 and remainder u3.
	[this is "lib4th" basic unsigned division operation.]
	 dvs = 0 ovf:
		dvd > 0  $ffffffff.ffffffff $ffffffff
		dvd = 0          0.00000001 0

 fm/mod  	( d1 n1 -- n2 n3 )		(e,?)(GA)	'fmbymod'	forth
	signed divide dvd=d1 by dvs=n1, leave floored quotient n3 and remainder n2.
	fm/mod from sm/rem and, if quot 0<, rmd := rmd + divisor, quot := quot - 1.
	 Dividend Divisor   Quotient Remainder
	 -------- ------- | -------- ---------
	     10      7    |    1        3
	    -10      7    |   -2        4
	     10     -7    |   -2       -4
	    -10     -7    |    1       -3
	 dvs = 0 overflow values:
		dvd > 0    $7fffffff  $7fffffff
		dvd < 0    $80000001  $80000001
		dvd = 0     1          0

 m*		( n1 n2 -- d3 )			(f6)(a)(m,8)	'mmul'		forth
	signed multiply sings n1 by n2 to double d3

 u*		( n1 n2 -- d3 )			(f6)(m,8)	'umul'		forth
 um*		( n1 n2 -- d3 )			(a)(m,8)	'umul'		forth
	unsigned multiply sings, leave double

 dm*		( d1 n2 -- d3 ovf )		(e)		'dmmul'		forth
	signed multiply double by sing to double.
	ovf is m.s. cell of treble product.
	(e: NZ*S if ovf =/= 0)

 udm*		( ud1 u2 -- ud3 ovf )		(e)		'udmmul'	forth
	unsigned multiply double by sing to double,
	ovf is m.s. cell of treble product.
	(e: NZ*S if ovf =/= 0)

 udm*/mod	( ud1 u2 u3 -- u4 ud5 )		(4)		'udmmulbym'	forth
	unsingned double ud5 = ud1*u2/u3, u4=rmd; w/ quad intermediate opr.

 m*/		( d1 n2 n3 -- d4 )				'mmulby'	forth
	singned double d4 = d1 * n2 / n3; w/ quad intermediate opr.

 um*/		( u1 u2 u3 -- ud4 )				'ummulby'	forth
	unsingned double ud4 = u1*u2/u3

	

 u^		( u1 +u2 -- +d3 )				'upow'		forth
	return double +d3 as u1 to the pover of u2,
	ud3 := 0 if u2 < 0

 ^		( n1 +n2 -- d3 )				'pow'		forth
	return signed double d3 as n1 to the pover of n2,
	d3 := 0 if n2 < 0, d3 := 1 if n2 = 0

 udsqrt  	( ud1 -- ud2 j )		(x)				forth
	ud2 := sqare root of unsigned double |ud1|; j := -1 if top bit of ud1 set (-ve).
	note: ud2 m.s. sing always zero, left in place for -re- {vsqrt}, {dvsqrt}.

 udsqrt  	( ud1 -- ud2 j )				'fudsqrt'	non-mmx
	ud2 := +ve sqare root of double |ud1|; j := -1 if ud1 signed < 0.
	note: ud2 m.s.cell always zero, left in place for -re- {vsqrt}, {dvsqrt}.
	ud2 is nearest integer the sqare of which is lower or equal |ud1|*(2j-1).
	

----------------------------------------------------------------
-- fast & special arithmetics

	

 flg		( -- u )			(m,3)				tools
	fetch eflags register from latest opr
	can efficiently be used immediately after those words
	which are marked "(e)".

 flg>smb	( n -- p u )					'flg2smb'	tools
	convert eflags value to symbolic string at {hld}+,
	string corrupted by consecutive numeric conversions.

 chars  	( n1 -- n2 )			(a:c)(m,0)			forth
	multiply n1 by charsize (1, i.e. a {noop} word)

 2*		( n1 -- n2 )			(e)(m,2)	'mul2'		forth
	multiply n1 by 2

 noop		( -- )				(fg)(m,1)			forth
	most efficiently do nothing,
	hi-level call immediately returns,
	macro inserts a <nop> operation.

 6*		( n1 -- n2 )			(e)(m,4)	'mul6'		forth
	multiply n1 by 6

 3*		( n1 -- n2 )			(e)(m,3) 	'mul3'		forth
	multiply n1 by 3

 10*		( n1 -- n2 )			(e)(m,3)	'mul10'		forth
	multiply n1 by 10

 5*		( n1 -- n2 )			(e)(m,3)	'mul5'		forth
	multiply n1 by 5

 7*		( n1 -- n2 )			(e)(m,5)	'mul7'		forth
	multiply n1 by 7

 9*		( n1 -- n2 )			(e)(m,3)	'mul9'		forth
	multiply n1 by 9

 cells  	( n1 -- n2 )			(a:c)(m,3)	'mul4'		ans
	multiply n1 by cellsize(4)
 4*		( n1 -- n2 )			(e)(m,3)	'mul4'		forth
	multiply n1 by 4

 FLOATS 	( n1 -- n2 )			(e)(m,3)	'mul8'		ans
 SFLOATS	( n1 -- n2 )			(e)(m,3)	'mul8'		ans
 8*		( n1 -- n2 )			(e)(m,3)	'mul8'		forth
	multiply n1 by 8
 abits  	( n1 -- n2 )			(m,3)		'mul8'		ans
	n2 := no. of n1 address units bits

 DFLOATS	( n1 -- n2 )			(e)(m,3)	'mul16'		ans
 16*		( n1 -- n2 )			(e)(m,3)	'mul16'		forth
	multiply n1 by 16

 @lshift	( p +u -- )			(e)(m,9)	'mlshift'	forth
	shift cell in memory at ptr p by +u < 32 bits

 @rshift	( p +u -- )			(e)(m,9)	'mrshift'	forth
	shift cell in memory at ptr p by +u < 32 bits

 @rshifta	( p +u -- )			(e)(m,9)	'mrshifta'	forth
	shift cell in memory at ptr p by +u < 32 bits, propagate sign bit

 rot-l  	( x1 u -- x2 )			(e)(m,9)	'rotl'		forth
	left rotate x1 by u bits

 shift  	( x1 n -- x2 )							forth
	32 > n > 0 : {lshift}, -32 < n < 0 {rshift}; x2 := 0 if |n| > 31.

 lshift  	( x1 u -- x2 )			(e)(a:c)(m,9)			forth
	unmodified cpu opr, i.e. x1 unchanged for u = any multiple of 32

 2/		( n1 -- n2 )			(e)(m,12)	'div2'		forth
	signed divide n1 by 2. 'round towards zero' mode.
	(NOTE: correct result incl. odd -ve, not ANS-4th compliant)

 2/		( n1 -- n2 )			(e)(m,2)	'shr2'		ans
	signed divide n1 by 2, 'floored rounding' mode -re- DPANS 6.1.0330.

 4/		( n1 -- n2 )			(e)(m,13)	'div4'		forth
	signed divide n1 by 4 (cellsize). 'round towards zero' mode.

 CELL/  	( n1 -- n2 )			(e)(m,3)	'cellby'	ans
	signed divide n1 by 4 (cellsize). w/ floored rounding.

 8/		( n1 -- n2 )			(e)(m,) 	'div8'		forth
	signed divide n1 by 8. 'round towards zero' mode.

 16/mod 	( n1 -- n2 n3 )			(e)(m,) 	'div16m'	forth
	signed divide n1 by 16, ret quot n2, rem n3. 'round towards zero' mode.

 rshift  	( x1 u -- x2 )			(e)(a)(m,9)			forth
	unmodified cpu opr, i.e. x1 unchanged for u = any multiple of 32

 rshifta	( n1 u -- n2 )			(e)(a)(m,9)			forth
	unmodified cpu opr, i.e. x1 unchanged for u = any multiple of 32

 rot-r  	( x1 u -- x2 )			(e)(m,9)	'rotr'		forth
	right rotate x1 by u bits

 2lshift	( dx1 u -- dx2 )		(e)(x)		'dlshift'	forth
	logic shift left double

 d8*		( d1 -- d2 )			(x)		'dmul8'		forth
	multiply double by 8

 d4*		( d1 -- d2 )			(x)		'dmul4'		forth
	multiply double by 4

 d2*		( d1 -- d2 )			(e)(x)(a:d)	'dmul2'		forth
	multiply double by 4

 2lshift	( dx1 u -- dx2 )		(e)		'dlshiftf'	non-mmx
	logic shift left double

 dslbits	( d1 -- d1 n )							forth
	ret no. n of bits by which d1 may be shifted left w/o change of sign.

 2rshifta	( d1 u -- d2 )			(e)(x)		'drshifta'	forth
	double shift right, arithmetic
	floored, signed division by 2^(u), u < 64.

 2rshifta	( dx1 u -- dx2 )		(e)		'drshiftfa'	non-mmx
	shift right a double, sign preserving

 d8/		( d1 -- d2 )			(e)		'deightby'	forth
	divide double by 8

 d4/		( d1 -- d2 )			(e)		'dfourby'	forth
	divide double by 4

 d2/		( d1 -- d2 )			(e)(a:d)	'dtwoby'	forth
	divide double by 2

 2rshift	( dx1 u -- dx2 )		(e)(x)		'drshift'	forth
	logic shift right double, u mod 64

 2rshift	( dx1 u -- dx2 )		(e)		'drshiftf'	non-mmx
	logic shift right double, u mod 64. non-mmx subst.

 1+		( n1 -- n2 )			(e,fg)(m,1)	'add1'		forth
 char+  	( n1 -- n2 )			(e,C)(m,1)	'add1'		forth
	increment sing by 1

 1-		( n1 -- n2 )			(e,fg)(m,1)	'sub1'		forth
 char-  	( n1 -- n2 )			(e,C)(m,1)	'sub1'		forth
	decrement sing by 1

 2+		( n1 -- n2 )			(e)(fg)(m,3)	'add2'		forth
	increment sing by 2

 2-		( n1 -- n2 )			(e)(fg)(m,3)	'sub2'		forth
	decrement sing by 2

 4+		( n1 -- n2 )			(e)(m,3)	'add4'		forth
 cell+  	( n1 -- n2 )			(GA)(m,3)	'add4'		forth
	n2 := n1 + cellsize(4), increment sing by 4

 4-		( n1 -- n2 )			(e)(f6)(m,3)	'sub4'		forth
 cell-  	( n1 -- n2 )			(a)(m,3)	'sub4'		forth
	n2 := n1 - cellsize(4), decrement sing by 4

 8+		( n1 -- n2 )			(e)(f6)(m,3)	'add8'		forth
	increment sing by 8

 8-		( n1 -- n2 )			(e)(f6)(m,3)	'sub8'		forth
	decrement sing by 8

 d1+		( d1 -- d2 )			(e)(f6)(m,7)	'donep'		forth
	increment double by 1

 d2+		( d1 -- d2 )			(e)(f6)(m,7)	'dtwop'		forth
	increment double by 2

 d4+		( d1 -- d2 )			(e)(f6)(m,7)	'dfourp'	forth
	increment double by 4

 d8+		( d1 -- d2 )			(e)(f6,m,7)	'deightp'	forth
	increment double by 8

 d1-		( d1 -- d2 )			(e)(f6)(m,7)	'donem'		forth
	decrement double by 1

 d2-		( d1 -- d2 )			(e)(f6)(m,7)	'dtwom'		forth
	decrement double by 2

 d4-		( d1 -- d2 )			(e)(f6)(m,7)	'dfourm'	forth
	decrement double by 4

 d8-		( d1 -- d2 )			(e)(f6)(m,7)	'deightm'	forth
	decrement double by 8

=====================================================================;
 l4dsarith.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4dstack.inc>
--------------------------------------------------------------------------


================================================================
-- basic data-stack opr

	dpans94: stacks should not be accessed directly!
	returnstack grows towards lower addresses, datastack grows
	towards higher addresses, thus they differ in cell order.
	@tos stored in eax register, @(sp@) may temporarily be valid
	further, data will be stored to returnstack offset by <kref>
	and adjusted back when fetched to datastack.

----------------------------------------------------------------
 datastack

 depth  	( -- n )							forth

 -depth  	( -- n )					'mdepth'	forth
	free space on datastack

 cdepth  	( -- n )							compiler
	no. of -double- items in compilestack, valid only after {!csp} or {:}.

 sp!		( | p -- )			(fg|a:c)	'spstore'	forth
	vectored, either to forth or ans version of {sp!}.

 sp>		( | p -- )			(m,5)		'fspstore'	forth
	re-initiate datastack from @{s0}

 sp!		( -- )				(fg)		'fspstore'	fig
	f.i.g.-mode: re-initiate datastack from @s0 - F83 mode by ans-word {SP!}.
	being the safer one this is in {forth} and {fig} vocs for precedence over
	-re- ANS-mode {SP!}, which is in {ans} vocabulary.

 SP!		( p -- )			(a:c)		'aspstore'	ans
	reset datastack to kref(p). ANS-std word, in {ans} wordlist.
	(e: eflags remain unchanged)

 sp@		( -- a )			(fg)		'spfetch'	forth
	get datastack ptr
	ANS: programs shall NOT access datastack by address!
	@tos stored to corresponding address but, might get lost with operations to 
	follow. references to above @tos will be safe. "above" is to descending addr!

 @csp		( -- )				(f6)		'fcsp'		hidden
      restore datastack ptr from saved in {csp} compilestack ptr
	(e: eflags remain unchanged)

 !csp		( -- )				(m,12)		'scsp'		forth
	store datastack ptr to uvari csp.
	executed by {head} and {:noname}, thus by all named defining words.

 csp@		( -- p )					'cspf'		hidden
      fetch kref'd compilestack ptr to tos
	(e: eflags remain unchanged)

 -drop  	( n | 0 -- 0 )					'mdrop'		forth
	drop n if non-zero

 0drop  	( n | 0 -- n )			(m,9)		'zdrop'		forth
	drop if zero

 drop		( n1 -- )			(e)(m,5)			forth
	remove item from tos
	(e: eflags remain unchanged)
 ?DUP		( n1|0 -- n1 n1 | 0 )		(a:c)(83)	'qdup'		ans
	duplicate n1 if non-zero

 -dup		( n1|0 -- n1 n1 | 0 )		(fg)(m,4)	'mdup'		forth
	duplicate n1 if non-zero

 dup		( n1 -- n1 n1 )			(m,1)		'cdup'		forth
	duplicate item on tos
	(e: eflags remain unchanged)

 ddup		( n1 -- n1 n1 n1 )		(m,2)		'ddup'		forth
	twice duplicate sing on tos
	(e: eflags remain unchanged)

 d2dup  	( d1 -- d1 d1 d1 )		(m,x)		'd2dup'		forth
	twice duplicate double on tos
	(e: eflags remain unchanged)

 2sdup  	( d1 d2 -- d2 d1 d1 )		(x)		'sdup2'		forth
	does{ 2swap 2dup } or, { 2over 2swap }
	(e: eflags remain unchanged)
 2sdup  	( d1 d2 -- d2 d1 d1 )				'twosdupf'	non-mmx
	does{ 2swap 2dup } or, { 2over 2swap }; non-mmx subst.

 2dup		( d1 -- d1 d1 )			(a:d)(m,8)	'dup2'		forth
	duplicate double @tos

 3dup		( n1 d2 -- n1 d2 n1 d2 )	(f6)(x)		'dup3'		forth
	duplicate top three cells @tos
	(e: eflags remain unchanged; mmx mode w/o timing gain)

 3dup		( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )		'dup3f'		non-mmx
	duplicate top three cells @tos; non-mmx subst.
	(e: eflags remain unchanged)

 swap		( n1 n2 -- n2 n1 )		(m,8)				forth
	exchange contents of tos and nos cells
	(e: eflags remain unchanged)

 2swap   	( d1 d2 -- d2 d1 )				'swap2'		forth
	exchange top two doubles at tos
	(e: eflags remain unchanged)

 over		( n1 n2 -- n1 n2 n1 )		(m,4)				forth
	copy sing @nos to tos
	(e: eflags remain unchanged)

 2over   	( d1 d2 -- d1 d2 d1 )				'over2'		forth
	copy double @nos to tos
	(e: eflags remain unchanged)

 2rot		( d1 d2 d3 -- d2 d3 d1 )	(x)(a:dx)	'rot2'		forth
	roll 3rd double to tos
	(e: eflags & non-mmx regs remain unchanged)

 2rot		( d1 d2 d3 -- d2 d3 d1 )	(a:dx)		'rot2f'		non-mmx
	roll 3rd double to tos; non-mmx subst.

 2-rot  	( d1 d2 d3 -- d3 d1 d2 )			'mrot2'		forth
	reverse roll double @tos to 3rd
 2roll   	( nx...nm +N -- nx...nm nN )			'roll2'		forth
	 	( nx...nm -N -- nN nx...nm )
	roll double, re {roll}, index range -16383 < N < 16382

 roll		( n1 nN n3 ... nm +N -- n1 n2 n3 ... nm nN )			forth
	move +N-th to tos, move N+1 items one cell up.
 roll		( n1 nN n3 ... nm -N -- n1 nN n2 n3 ... nm )
	move -N items one cell up, move @tos to -N-th cell above tos.
	N including 0, in either case.

 2rotd  	( d1 d2 d3 -- d2 d3 )		(x)		'rotd2'		forth
	{ 2rot 2drop }
	(e: eflags remain unchanged; mmx mode w/o timing gain)
 2rotd  	( d1 d2 d3 -- d2 d3 )				'rotd2f'	non-mmx
	(e: eflags remain unchanged)

 rotd		( n1 n2 n3 -- n2 n3 )		(m,9)				forth
	{ rot drop }
	(e: eflags remain unchanged)

 -rot		( n1 n2 n3 -- n3 n1 n2 )	(79)		'mrot'		forth
	(e: eflags remain unchanged)

 rot		( n1 n2 n3 -- n2 n3 n1 )					forth
	(e: eflags remain unchanged)

 pick		( nm..n1 n -- nm..n1 n{n} )	(m,5)				forth
	fetch n-th item to tos, { 0 pick } is {dup}.
	NOTE:	meaningless data if -ve index passed to cpl'd macro variant
		use -re- {-pick}, instead
	(e: eflags remain unchanged)

 2pick   	( nm..n1 n -- nm..n1 n{n} )	(m,12)		'pick2'		forth
	(e: eflags remain unchanged)

 -pick  	( nm..n1 n -- nm..n1..n2 )	(m,23)		'mpick'		forth
	store n1 as n-th item @tos, position of n1 (item to store) counts for zero.
	drop count and n1 if n < 0

 2-pick   	( dm..d1 n -- dm..d1..d2 )			'mpick2'	forth
	store d1 as n-th item @tos, position of d1 (item to store) counts for zero.
	drop count and d1 if n < 0

 third  	( n1 n2 n3 -- n1 n2 n3 n1 )	(m,4)				forth
	fetch 3rd item from stack. substitutes { 2 pick }
	(e: eflags remain unchanged)

 2third  	( d1 d2 d3 -- d1 d2 d3 d1 )	(m,8)		'third2'	forth
	fetch 3rd item from stack. substitutes { 2 2pick }
	(e: eflags remain unchanged)

-- compile-time stack ref.

 ds-pick	( n1 -- n2 )(C: ..x.. -- ..x.. )		'dspick'	forth
		( -n -- )(C: ..x.. n1 -- n1 ..x.. )		'dspick'	forth
	pick from/to saved top of datastack (as stored by {head} or user/appl)
	for use while {:}-compiling, in intermediately interpreting state.
	storeing an item back to data-stack by -n with -1 referring to @tos.
	(e: eflags remain unchanged)

 cs-drop	( n -- )(C: s(n)..s1 -- s(n).. )(a:tx)				forth
	drop control item (double cell) on datastack

 cs-pick	( n -- )(C: s(n)..s1 -- s(n)..s1 s(n) )(a:tx)			forth
	pick control item (double cell) from datastack

 cs-roll	( n -- )(C: s(n)..s1 -- ..s1 s(n) )(a:tx)			forth
	roll control item (double cell) on datastack

 cs-depth  	( -- n )					'csdepth'	forth
	no. of compile-stack items (doubles) after colon defn. initialization.

-- 'sillywords' and misc. combined stack opr.

 3drop   	( n1 n2 n3 -- )			(e)(m,6)	'drop3'		forth
	(e: eflags remain unchanged)

 dmin		( d1 d2 -- dn )			(a:d)(15)			forth
	drop larger one of two doubles.

 2drop  	( dn -- )			(a:c)(m,5)	'drop2'		forth
	drop double @tos
	(e: eflags unchanged)

 dmax		( d1 d2 -- dn )			(a:d)				forth
	drop smaller one of two doubles.

 2sdrop  	( d1 d2 -- d2 )			(f6)(m,9)	'sdrop2'	forth
	drop double @nos; does{ 2swap 2drop }
	(e: eflags remain unchanged)

 2dropd  	( d1 d2 -- d1 d1 )				'dropd2'	forth
	copy double @nos to @tos, does{ 2drop 2dup }
	(e: eflags unchanged)

 2sover  	( d1 d2 -- d2 d1 d2 )		(f6)(x)(m,10)	'sover2'	forth
	{ 2swap 2over } - macro compiling only if mmx enabled.
	(e: eflags remain unchanged)

 2sover  	( d1 d2 -- d2 d1 d2 )		(4)		'twosoverf'	non-mmx
	{ 2swap 2over }
	(e: eflags remain unchanged)

 2oswap  	( n1 n2 -- n1 n1 n2 )		(m,14)(x)	'oswap2'	forth
	does{ 2over 2swap }
	(e: eflags remain unchanged; mmx mode w/ minor timing gain )

 2srot  	( d1 d2 d3 -- d3 d2 d1 )	(m,8)(x)	'srot2'		forth
	{ 2swap 2rot }, i.e. exchanges @tos and 2nd
	(e: eflags remain unchanged; mmx mode w/o timing gain)

 2srot  	( d1 d2 d3 -- d3 d2 d1 )	()		'srot2f'	non-mmx
	{ 2swap 2rot }, i.e. exchanges @tos and 2nd
	(e: eflags remain unchanged)

 2rots  	( d1 d2 d3 -- d2 d1 d3 )	(m, )(x)	'rots2'		forth
	{ 2rot 2swap }, i.e. swap next on tos doubles
	(e: eflags remain unchanged)

 2rots  	( d1 d2 d3 -- d2 d1 d3 )	()		'rots2f'	non-mmx
	{ 2rot 2swap }, i.e. swap next on tos doubles
	(e: eflags remain unchanged)

 rotd2s  	( n1 n2 n3 -- n1 n1 n2 n3 )	(m)(x)				forth
 quck-tuck					(a?)(n.i.)
	duplicate 3rd on tos, supporting {skip}, {scan}, etc: { rot dup 2swap }
	(e: eflags remain unchanged; mmx mode w/ minor timing gain)

 rotd2s  	( n1 n2 n3 -- n1 n1 n2 n3 )	(m)		'rotd2sf'	non-mmx
	substitutes { rot dup 2swap }, non-mmx
	(e: eflags remain unchanged)

 swap2s 	( n1 n2 n3 n4 -- n4 n3 n2 n1 )	(m,20)				forth
	revert cells order of top four cells
	does{ swap 2swap swap }
	-re- {bswap} for conversion of bytes order in a cell
	(e: eflags remain unchanged)

 >|<		( n1 -- n2 n3 )			(m,9)		'w2b'		forth
	split n1 lo.word into n3:=hi and n2:=lo bytes
	(e: eflags remain unchanged)

 >||<		( n1 -- n2 n3 )			(m,11)		'd2w'		forth
	split n1 lo into n3:=hi and n2:=lo words

 bswap  	( n1 -- n2 )			(m,2)		'bbswap'	forth
	swap bytes, convert big <-> little endian byte order.
	-re- {swap2s} for conversion by cells
	(e: eflags remain unchanged)

 ><		( n1 -- n2 )			(lm)(m,2)	'xgb'		forth
	swap l.s. bytes (8bit portions) of cell n1.
	(e: eflags remain unchanged)

 wswap  	( n1 -- n2 )			(c1)(m,3)			forth
	swap lo and hi words (16bit portions) of n1.

 unpack  	( n1 -- n2 )							forth
	expand l.s. 4 4bit-nibbles to cell of 4 8-bit bytes

 pack		( n1 -- n2 )							forth
	pack a cells 4 l.s. 4bit-nibbles per 8bit-byte to 16bit word

 srot		( n1 n2 n3 -- n3 n2 n1 )	(m,8)				forth
	{ swap rot }, i.e. exchanges @tos and 2nd
	(e: eflags remain unchanged)

 rots		( n1 n2 n3 -- n2 n1 n3 )	(m,12)				forth
	{ rot swap }, i.e. swap next on tos cells
	(e: eflags remain unchanged)

 NIP						(a:ce)		'sdrop'		ans
	drop @nos; does{ swap drop }

 sdrop  	( n1 n2 -- n2 )			(m,3)				forth
	drop @nos; does{ swap drop }
	(e: eflags remain unchanged)

 TUCK   					(a:ce)		'sover'		ans
	does{ swap over }

 sover  	( n1 n2 -- n2 n1 n2 )		(m,12)				forth
	{ swap over }
	(e: eflags remain unchanged)

 over-  	( n1 n2 -- n1 n3 )		(f6)(m,3)	'overm'		forth
	{over -}, leave n3 := n2-n1
	(e: eflags reflect result)

 over+  	( n1 n2 -- n1 n3 )		(m,3)		'overp'		forth
	{over +}, leave n3 := n2+n1
	(e: eflags reflect result)

 oswap  	( n1 n2 -- n2 n2 n1 )		(m,8)				forth
	does{over swap}
	(e: eflags remain unchanged)

 sdup		( n1 n2 -- n2 n1 n1 )		(m,9)				forth
	does{swap dup} or, {over swap}
	(e: eflags remain unchanged)

 dropd  	( n1 n2 -- n1 n1 )		(m,3)				forth
	copy @nos to @tos, does{ drop dup }
	(e: eflags unchanged)

 m>s		( p n -- n1..nn )				'mtos'		forth
	fetch n bytes from ptr p to tos, beginning w. cell aligned n1.

 ndrop  	( x y(n)...y(1) n -- x | abort )				forth
	reserve -n cells, stack content indeterminate or,
	drop +n cells from datastack. stack bounds check.

 nswap  	( nx0 nx1..nxm ny0 ny1..nym m -- ny0..nym nx0..nxm )		forth
	multiple cells swap, swap blocks of m cells

 c-xchg  	( p1 p2 +u -- )					'cxchg'		forth
	exchange +u bytes in ranges p1,p1+u2 and p2,p2+u2.

 swapn  	( nx nN nm .. n0 M -- nx n0 nm .. nN  )				forth
	swap N-th cell with cell on tos

 bounds  	( x1 n -- x2 x1 )		(fg)(m,4)			forth
	leave x1 and x2 := x1+n, ready for do..loop etc.
	{ over + swap }
	(e: eflags reflect result of addition)

=====================================================================;
  l4dstack.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4envq.inc>
--------------------------------------------------------------------------

----------------------------------------------------------------
  ANS-Forth environmental queries
	
 ANS defined environment strings are word names in the {environment} vocabulary
 which is a {hidden} sub-vocabulary.
 user definitions which extend lib4th to further standard compliance should
 thus simply supply the respective query strings by new words defined in the 
 {environment} vocabulary which return the appropriate values which with no
 further precautions will then be handled by {environment?}.
 non-present features can simply be left undefined because the {environment?} 
 query returns zero for any unknown such word-names' strings.
	

 ENVIRONMENT?	( p u -- ff | .xx. flg )	(a:c)(v)	'envirq'	root
	letter case independently find and, execute ANS-4th environment string.
	returns zero for any non-present capability.

 LIB4TH 	( -- 1 -1 )							environment
	whether a program is using/based on "lib4th"

 CORE 	( -- 0 )							environment
 CORE-EXT	( -- 0 )							environment
 FLOORED  	( -- ff )							environment

 queries which return non-zero values

 ADDRESS-UNIT-BITS ( -- n )							environment

 /COUNTED-STRING ( -- n )							environment

 STACK-CELLS	( -- n )							environment
 DATASTACK-SIZE ( -- n )							environment
	(NOTE: data- and return-stack share a common memory area.)

 BLOCK	( -- fl )							environment
 BLOCK-EXT	( -- fl )							environment

 DOUBLE 	( -- fl ) 						 	environment
 DOUBLE-EXT	( -- fl ) 						 	environment

 EXCEPTION 	( -- fl ) 						 	environment
	untested, hi-level substitutes available
 EXCEPTION-EXT	( -- fl ) 						 	environment

 FACILITY	( -- fl )							environment
 FACIILITY-EXT ( -- fl )							environment

 FILE 	( -- fl )       						environment
 FILE-EXT	( -- fl )       						environment

 FLOATING	( -- fl )							environment
 FLOATING-EXT	( -- fl )							environment

 LOCALS 	( -- fl )							environment
 LOCALS-EXT	( -- fl )							environment

 MEMORY_ALLOC	( -- fl )							environment
 MEMORY_ALLOC-EXT ( -- fl )							environment

 SEARCH-ORDER ( -- fl )							environment
 SEARCH-ORDER-EXT ( -- fl )							environment

 STRING 	( -- fl )							environment

 TOOLS	( -- fl )							environment
 TOOLS-EXT	( -- fl )							environment

 MAX-N  	( -- n )							environment
	max. sing integer, MIN-N is -ve MAX-N (i.e. hex 80000000 not a valid integer!).

 MAX-D  	( -- d )							environment
	max. double integer, MIN-D is -ve MAX-D (hex 80...00 is not a valid double!).

 MAX-FLOAT  	( -- df )							environment
	a "float" is a pair of double cells, representing a rational (real) number
	by fraction of signed numerator (@nos) and unsigned denumerator (@tos).
	smallest representable number is 1/max-float, displayed w/ up to {#fplaces} 
	fractional digits. beyond |2^62-1| only integers representable.

 MAX-CHAR  	( -- n )							environment

 MAX-U  	( -- n )							environment

 MAX-UD  	( -- d )							environment

 /PAD    	( -- n )							environment

 /HOLD  	( -- n )							environment
	space for numeric to stg conversion, between {pad2} and {here}.

 RETURNSTACK-CELLS	( -- n )						environment
	 query returns half size of data- and return-stack shared memory area.

 #LOCALS  	( -- n )							environment
	cells count remaining available for allocation in local dataspace.
	n is taken as half of unused memory between data- and return-stack, where 
	dependent on both stacks actual useage more or less locals may be allocated.
	This limit is about 1/8 that value while compiling, due to additional space 
	being used for the temporary named word-headers. A Local requires 8 cells 
	plus the name's length, while at runtime occupying only a single cell.

 environment 	( -- )				(x)(i)				hidden
	vocabulary for the ANS-4th environment query.
	

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4errhd.inc>
--------------------------------------------------------------------------


 -- error handling, messages.

 ?error  	( flg n2 -- | in blk ,quit )	(v)		'qerror'	forth
	if nonzero flg display error message no. n2 and {quit}

 [CATCH]  	( flg n2 -- 0 | n2 )		(a:ex)?		'bcatchb'	ans
	if nonzero flg leave n2. else false

 [THROW]	( er -- | abort-er )		(a:ex)?		'bthrowb'	ans

 [?error]  	( flg n2 -- | in blk ,quit )			'bqerrb'	hidden
	if nonzero flg display error message no. n2 and {quit}

 error  	( n --> quit )					'errorf'	root
	display error (+n) or system (-n) message and {quit}.

 [error]	( n --> quit )					'berrb'		hidden
      {error} vector default:
      display error (+n) or system (-n) message, rst RP & tib, {quit}.

 message	( n -- )							forth
	display system message, lib4th defined w/ +n, Linux kernel w/ -n
	overflow: 'msg #' n
	display startup text if n = 0x80000000

 msgstg  	( n -- p u )							forth
	return ptr p and length u of message stg corresponding to signed no. n
	

================================================================
-- errors

	

 null?	( p -- f )					'nullq'		forth
	tf if p = 0 or ref to zero 4th address

 ?null  	( p -- abort-14 )				'qnull'		forth
	abort w/ "Bad address" if p is zero or zero 4th address

 ?comp  	( -- | abort-17 )				'qcomp'		forth
	abort if not in compiling state

 ?exec  	( -- | abort-18 )				'qexec'		forth
	abort if not in true (vs. imtermediatly) executing state

 ?csp		( -- | abort )					'qcsp'		forth
	abort if stack is out of balance w. stored value from {csp}.

 ?pairs2	( f1 f2 f3 -- | abort )		(k)		'qpairs2'
	abort if neither f2 = f1 nor f3 = f1

 ?pairs  	( f1 f2 -- | abort )		(fg)		'qpairs'	forth
	abort if f1 =/= f2

 ?stack  	( --  abort )			(fg)		'qstack'	forth
	abort w. message "empty stack" if unsufficient space
	abort w. message "stack overflow" if upper bound overflow
	else continue silently

 ?depth  	( n -- | abort )		(f6)		'qdepth'	forth
	check whether sufficient data cells on datastack, else
	rst datatstack and send message "off working area" to stderr

 depth?  	( n -- flg )			(f6)		'depthq'	forth
	tf if at least n cells on stack.

 abort  					(d)		'cabort'	root
	restore stacks & kref, lc-unmap, uc-unmap, enter {quit} or,
	if @pid =/= actual job's pid terminate w. SIGSTKFLT 

 [abort]  							'babortb'	hidden
	deferred -re- {abort} default.

 abort" 	ccc( f -- )			(i)(4)		'abtqte'	forth
	if f = 0 continue, else send <"> delimited message stg ccc and {abort}.

 daystg  	( n [cc] -- p u )				'daystg'	forth
	return ptr to day name corresponding to no. n
	optional country code cc, one of <en>, <de> (l4_0.0.57).

 sigstg  	( n -- p u )					'sigs'		linux
	return ptr to signal name corresponding to no. n
	leading "SIG" implied.

 errstg  	( n -- p u )					'errs'		forth
	return ptr to error name corresponding to no. n
	leading "E" implied.

 enum@  	( n p1 -- p2 u )				'enumf'		forth
	find string(p2,u) by number n in list of <nul>-terminated stg-s at p1.
	<nul> <nul> is list terminator. enum list constructor -re- {:slist} etc.

  {errno} and {signo}
	respond to upper case strings, unless {lc-ignore} mode set.

 errno  	( p u -- n )					'erno'		forth
	find error number +n corresponding to given name p,u.
	leading "E" may be omitted.

 signo  	( p u -- n )							linux
	find signal number +n corresponding to given name p,u.
	leading "SIG" may be omitted.

 enum#  	( p1 u p2 -- n )  		(4)		'enumn'		forth
	item number n of string p1,u1 in list of asciz strings at p2.
	ret n:= +ve item number, else n:=-1 if string not found.
	-re- {enum@} and, enum list constructor {:slist} etc.

 errno?  	( -- )						'ernoq'		forth
	display error names in {errno} list.

 signo?  	( -- )						'signoq'	linux
	display signal names in {signo} list.

 enum?  	( p -- )			(4)		'enumq'		forth
	display all asciz strings of list p, space delimited.
	-re- {enum#}, {enum@}, enum list constructor {:slist} etc.

=====================================================================;
  l4errhnd.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4ersigt.inc>
--------------------------------------------------------------------------


  l4ersigt.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4file.inc>
--------------------------------------------------------------------------

================================================================
 -- i/o

	

 source  	( -- a +u )			(v)(83)				forth
	addr of current input buf. & maxcount of data
	execute true address uot vector (source), dft {[source]}.

 refill  	( -- flg )			(a:c)(e)			forth
	dependent on input mode, re {source-id}, fetch next group of input data 
	to current input buf. ret tf, else ret ff if no input available.

 save-input	( -- xn..x1 n )			(a:cx)		'saveinput'	forth
	[n:(source-id), s0, blk, in, (tib), (tib-max), span, set-chan(stdin), (iolink):1]
	and cnt n stored to data-stack. an application may further store this
	block to memory and link to (iolink) and, assign local {tib}.
	local dataspace left over after entry would be resolved by next {restore-input}.

 restore-input	( xn..x1 n -- flg )		(a:cx)(e)	'restoreinput'	forth
	restores data-stack top from (iolink), stores cnt n saved values back to
	[n:(source-id), s0, blk, in, (tib), (tib-max), span, set-chan(stdin), (iolink):1]
	and forcedly resolves after latest -re- {save-input} locally assigned memory.
	(eflags; Z if at top input level else NZ, S after early termination - re <popiosrc>)

 push-io	( n -- )(R: -- -tib- nn...nm nc )		'pushio'	forth
	allocate n bytes of local tib, >in := n, tib-max := n
	push i/o source data to tor, link into (iolink) chain

 pop-io 	( -- )(R: -tib- nn...nm nc -- )	(e)		'popio'		forth
	pop i/o source from tor, discard latest local tib, remove from (iolink) chain
	(eflags: NZ if, on entry, no more levels to resolve.
	
 -- file
	

 path-max	( -- n )			(c)(m,6)	'pathmax'	linux
	max. length of a path-name (4K-1 w/ kernel 2.2.xx)

 f"		ccc ( -- p u )  		(i)(4)		'fqte'		forth
	{fname"} w/ {path-max} bytes buf. at {pad}. -re- {[fname]}.

 fname" 	ccc( p1 u1 -- p2 u2 )		(i)(4)  	'fnmqte'	forth
	fetch <"> delimited file-name to buf(p1,u1), search {f8dir}, {path}, {lxpath}
	ret the fully qualified path+file name stg(p2,u2) to buf(p1,u1).

 [fname]	( p1 u1 p2 u2 -- p3 u3 )	(i)(4)  	'bfnameb'	forth
	search in {f8dir}, {path} and {lxpath} for filename(p2,u2);
	ret fully qualified path+file name stg(p3,u3) to buf(p1,u1).
	else, if file not found ret empty stg(p3,u3) u3=0.

 [fn		( d.buf d.file -- np nu )	 (k)(r)		'pfnamep'	novoc
	runtime {[fname]}, 
	search cwd if not 'root', then {f8dir}, {path}, {lxpath} for filename(d.file). 

 w-close	( -- er )			(s)		'wclose'	forth
	close {work}-channel - re {close-file}.

 close-file	( c -- er )			(s)		'closef'	forth
 close-dir	( c -- er )			(s)		'closef'	ans
	close channel no. c, ret er = 0 after success, else 
	error code er = +ve (fd, duplicate exists) or -ve (fss error).
	invalidate chp entry.
	don't actually close if duplicate channel other than {work} exists,
	if {work} is duplicate to channel c close work, also.
	channel protected if c = stdin and fd = host STDIN.
	syscall close -re- man 2 ...

 a-close	( -- )						'aclose'	util
	close channels no. 5 .. { max-chan 1- }, and work-channel (3).

 delete-file	( p u -- er )			(s)(a:f)	'deletf'	forth
	ret 0 or, -ve er after failure.
	syscall unlink -re- man 2 ...
	! if data security is an issue, pse, note that there is no safe way to 
	! erasing any data from e.g., a hard disk, but physical destruction...
	
----------------------------------------------------------------
 -- basic fd access mode flags (open)
	read, write
	

 r/o		( -- n )			(a:f)(m,7)	'rbyof'		forth
	'read only' file open access mode

 r/w		( -- n )			(a:f)(m,7)	'rbywf'		forth
	'read and write' file open access mode

 w/o		( -- n )			(a:f)(m,7)	'wbyof'		forth
	'write only' file open access mode

----------------------------------------------------------------
 -- modifiers to 'read'/'write' fd access mode flags
	directory, append, nonblock, sync, nofollow, excl, creat
	

 app		( n1 -- n2 )			(m,6)		'appf'		linux
	modify acess flag to append mode

 bin		( n1 -- n2 )			(a:f)(m,0)	'binf'		forth
	modify access flag to binary (non text, <eol>, etc) mode.
	ANS required; "bin"ary is a *transfer* mode and not a files entity!
	too silly, specific to a certain 'OS' and just a {noop} in Linux.

 cre		( n1 -- n2 )			(m,6)		'cref'		linux
	modify acess flag to truncate after open, i.e. open overwriting

 dir		( n1 -- n2 )			(m,6)		'dirf'		linux
	modify acess flag to open only if file is directory

 nbl		( n1 -- n2 )			(m,6)		'nblf'		linux
	modify acess flag to non-blocking i/o,
	required for console single key input mode.

 nof		( n1 -- n2 )			(m,6)		'noff'		linux
	modify acess flag to not following links

 syn		( n1 -- n2 )			(m,6)		'synf'		linux
      modify acess flag to synchrounous mode, waiting until actual
	opr. finished - <enter> if console input. flushing output data.

 trn		( n1 -- n2 )			(m,6)		'trnf'		linux
	modify acess flag to truncate after open, i.e. open overwriting

 any		( n1 -- n2 )			(m,6)		'anyf'		forth
	modify access flag to 4th calling a modified {create-file} which
	also returns error-free if the file is an accessible serial channel.
	

----------------------------------------------------------------
 -- file access

 -- directories

 f8doc  	( -- p u )			(kv)				util
	ret path to lib4th documentation files (dft compiled in by lib4th compilation).

 f8glo  	( -- p u )			(kv)				util
	ret glossary filename stg(p,u)

 f8gls  	( p1 u1 -- p2 u2 )		((kv))				util
	store path+file(p2,u2) of l4-glossary to buf(p1,u1)
	NOTE: string concatenation requires buf(p1,u1) as an argument!

 f8dir  	( -- p u )							forth
	path to lib4th supplemental files (fix, compiled in w/ __LIBF8D in Makefile):
	'__LIBF8D:__LIBF8D/app:~/.f8:~/f8:~/.f8/app:~/f8/app:$(__LIBDIR)'
	
 -- resources

 mfopen       ccc( n1 pf -- c flg )						linux
      open file ccc w/ flags n1 & pf, -re- {mopen-file}.

 mopen-file	( p u n1 pf -- fd flg )		(s)		'mopenf'	linux
	{open-file} w/ file permissions pf, using @{(fperm)} if not > 0.

 mcreate-file	( p u n1 pf -- n2 n3 )		(s)		'mcreaf'	linux
	{create-file} w/ file permissions pf, dft = 600 if pf not > 0.
	{mopen-file} w. TRUNC and CREAT flags or-ed to access code.

 create-file	( p u n1 -- n2 n3 )		(s)(a:f)	'creaf'		forth
	open old and truncate or, create new file,
	{open-file} w. TRUNC, CREAT, NONBLOCK flags or-ed to access code.

 open-dir	( p u -- fd flg )				'opendirf'	linux
	r/o open directory path (p,u).

 mcreate-dir	( p u pf -- n2 n3 )		(s)(a:f)	'mcread'	linux
	create a directory w/ file access mask pf.
	-re- man 2 mkdir

 create-dir	( p u -- n2 n3 )		(s)(a:f)	'cread'		linux
	create a directory w/ file access mask &02700.
	-re- man 2 mkdir

 fopen        ccc( n1 -- c flg )				'fopenf'	forth
      open file ccc, n1 & ret re {open-file}

----------------------------------------------------------------
 -- fd open flags

 -- Linux 2.2.14 kernel open-flags:
	 O_ACCMODE	    3		mask
	 O_RDONLY	    0
	 O_WRONLY	    1
	 O_RDWR		    2
---------------------- modifiers
	O_ANY		0x80000000	lib4th specific for {create-file}, any file-type
	 O_CREAT	  100q
	 O_EXCL		  200q
	 O_NOCTTY	  400q
	 O_TRUNC	  1000q
	 O_APPEND	  2000q
	 O_NONBLOCK	  4000q
	 O_NDELAY	O_NONBLOCK
	 O_SYNC		010000q		only on block devs & files on ext2 fs
	 O_DIRECT	040000q		direct disk access hint - currently ignored
	 O_LARGEFILE	100000q
	 O_DIRECTORY	200000q		must be a directory
	 O_NOFOLLOW	400000q		don't follow links
	 FASYNC		020000q		fcntl, for BSD compatibility
---------------------- access mode, re <man 1,2 chmod>
		value	4 for	read access
			2	write
			1	execution
	or-ed together and coded in three octal digits where
			m.s. digit is for the file's owner (user)
			2nd			     group
			l.s.			     all other
---------------------- fcntl fd,cmd[,arg|struc]
	 F_DUPFD	     0		dup
	 F_GETFD	     1		get f_flags
	 F_SETFD	     2		un-/set close-on-exec flag
	 FD_CLOEXEC	     1		f_setfd: actually anything with low bit set goes
	 F_GETFL	     3		get all flags of fd
	 F_SETFL	     4		set section of O_APPEND, O_NONBLOCK, O_ASYNC flags
	 F_GETLK	     5		\
	 F_SETLK	     6		 )get/set file locks
	 F_SETLKW	     7		/
	

 open-file	( p u n1 -- c flg )		(s)(a:f)	'openf'		forth
	open in mode n1 an existing file the name of which is string (p,u).
	n1 either one of {r/w}, {r/o} or {w/o}, which may be ORed by several
	modifiers, e.g. {app}, {cre}, {dir}, {nbl}, {nof}, {syn}, {trn}, {any}.
	file open words expect valid path to file -re- {path+file}, {f"}.
	permissions set to value from uvari {fperm}, dft 600o
	ret c := work-channel no. or error code, and flg := tf after success, or ff.
	actual fd stored to (work) and work-chp if open was successful.
	syscall open -re- man 2, and glossary "fd open flags".

 --		( -- )						'slsl'		root
	optional, active initial arguments terminator; a noop used for termination 
	by <argcopy> at program startup. - should be passed as a single argument!

 ss		( -- )						'ss4'		root
	required for shell script execution, after {#! /path/executeable}:
	copy stdin, stdout, stderr to {in-chan}, {out-chan}, {err-chan},
	fetch next space delimited argument/string and execute {included}.
	while executing the scriptfile itself is source to {stdin}, PIPEd
	or redirected i/o channels can then be referred w/ the copied id-s.
	use {include}, instead, to omitting the i/o channels setup.
	optional words may be inserted between path to lib4th executable 
	and {ss} - or {include} - being executed before script execution 
	starts. the entire line, after path to f8 but including the {ss} 
	word, becomes 1st argument passed to the application:
		#! /usr/local/bin/f8 { optional words } ss
		(text of 4th script follows)

 include	ccc( -- )							forth
	open and include source text from file ccc, re {include-file}
	search {f8dir} and {path} if ccc is not a fully qualified file-name

 include?	www ccc( -- )					'qincludeq'	forth
	a no-op if word www already accessible, else -re- {include} file ccc.

 include"	ccc( -- )					'includeqte'	forth
	include source from filename <ccc>, delimited by a quote <">.
	search {f8dir} and {path} if ccc is not a fully qualified file-name

 included	( .xx. p u -- .yy. | abort )	(a:f)		'included'	forth
	non-blocking open r/o file w. name+path p,u and {include-file}.
	abort w. error message on open error.
	an abort while compiling leaves all data on stack and returns the 
	rsp tib address and 1's-complement of the error line's <eol> position.

 include-file	( .xx. c -- .yy. )		(a:f)		'ifile'		forth
	save current input source description, revert to -re- {int} mode,
	redirect file input by channel no. to stdin,
	un-nesting, early termination by return to {quit}.

 file-size	( c -- un|er )			(s)(a:f)(e)	'fsizef'	forth
	32-bit file size un or error code, by channel no. c
	syscall fstat -re- man 2 ...
	(eflags reflect error code)

 stat-size	( -- +u )			(m)		'statsize'	forth
	required buf. size for {file-status} data structure.

 file-status	( p1 +u p2 -- er|p2 )		(s)(a:fx)	'fstatf'	forth
	return error or ptr to description of file status, by path+name p1,u.
	required buf. size at p2 is linux kernel specific, re "asm/stat.h".
	NOTE: implementation conformant to DPANS 11.6.2.1524 is impossible!
	use -re- {fstat} to reading the file status by number of an open channel.
	syscall stat -re- man 2 ...
	lx kernel 2.2 stat structure ("SHORT" is 16-bit, half CELL):
		00 	SHORT st_dev	; device, zero for PIPE
			SHORT pad1
		04	CELL  st_ino	; inode
		08	SHORT st_mode	; protection
		0a	SHORT st_nlink	; number of hard links
		0c	SHORT st_uid	; user ID of owner
		0e	SHORT st_gid	; group ID of owner
		10	SHORT st_rdev	; device type (if inode device)
			SHORT pad2
		14	CELL  st_size	; total size, in bytes
		18	CELL  st_blksize; blocksize for filesystem I/O
		1c	CELL  st_blocks	; number of blocks allocated
		20	CELL  st_atime	; time of last access
		24	CELL  unused1
		28	CELL  st_mtime	; time of last modification
		2c	CELL  unused2
		30	CELL  st_ctime	; time of last change
		34	CELL  unused3
		38	CELL  unused4
		3c	CELL  unused5

 flush-file	( c -- er )			(s)(a:fx)	'flushf'	forth
	assure all rsp. data cached by system flushed to fd, re man(2) fdatasync.
	syscall flush -re- man 2 ...

 read-file	( p +u1 c -- u2 er )		(s)(a:f)	'readf'		forth
	read +u1 chars into buf. of size u1, or until <eof>.
	u2 is no of received bytes.
	er<0 is an error, regardless of u2; er=0 and +u2=0 is <eof>.
	syscall read -re- man 2 ...

 read-line	( p +u1 ch -- u2 flg er )	(a:f)		'readl'		forth
	read at most +u1 chars until <eol> into buf. of size u1.
	return error code er and no. of received chars u2 until <eol> or u1.
	false flg and er<0 is an error, regardless of u2
	false flg and er=0 and +u2=0 is <eof>.
	flg=0 and er=EOVERFLOW(-75) if input ok & buffer full, no <eol> received.
	reading by bytes if ch is a pipe, {ch-fpos} advanced by count of bytes read 
	and, {ch-rnum} returns: 1 if input ok, 0 at eof, -ve after an error.
	NOTE1: fills buf. w. {read-file}, then scans for <eol> and
	       adjusts file pointer accordingly.

 read-char	( ch -- c flg )					'readchar'	forth
	input from supplied channel, otherwise identical -re- {?ekey}
	no time-out, execute { ch ch-eof } to find out whether a file is at it's end.

 rename-file	( p1 u1 p2 u2 -- er )		(s)(a:fx)	'renamf'	forth
	rename file p1,u1 to name p2,u2.
	syscall rename -re- man 2 ...

 reposition-file	( ud c -- er )		(a:f)		'reposnf'	forth
	set file-ptr of channel no. c to position ud.

 resize-file	( ud c -- er | abort )		(s)(a:f)	'resizef'	forth
	truncate writable file or extend with <nul> bytes, re man(2) ftruncate.
	VERIFY: <nul>s extension might be linux kernel version dependent.
	NOTE: ANS-std double cell (64bit) file size available w. linux 2.4. kernel,
	      until then {resize-file} will abort on size overflow into m.s. cell.
	syscall ftruncate -re- man 2 ...

 write-line	( p u1 fd -- er ) 		(a:f)		'writeline'	forth
	send string p,u to file fd, append <eol> code(s) as defined in (ccr).

 WRITE-FILE	( p u1 c -- er )		(s)(e)(a:f)	'awritefile'	ans
	write data from buf. p,u1 to file fd, er := 0 or error code. - ANS-mode 
	syscall write -re- man 2 ...

 write-file	( p u1 c -- u2 er )		(s)(e)(a:f)	'writefile'	forth
	write data from buf. p,u1 to file fd, ret u2 no. of data sent.
	syscall write -re- man 2 ...

 kbd-type	( p u -- )			(e)		'kbdtype'	forth
	send a string to the keyboard channel
	use { kbd ch-rnum } for error code.

 kbd-emit	( c -- )			(e)		'kbdemit'	forth
	{emit} to keyboard channel
	use { kbd ch-rnum } for error code.

 write-char	( c ch -- )			(s)		'writechar'	forth
	emit a single multi-byte (up to four) char to channel ch
	use { ch ch-rnum } for error code.

 file-position  	( c -- ud er )		(s)(a:f)	'fposf'		forth
	return file-ptr
	

-------------------------------------------
 -- linux specific file opr's, not in ANS-std
	

 fposre 	( d1 c -- d2 er )		(s)(f6)				linux
	set file-ptr by displacement d1 to current posn,
	return current file-pointer value, {lseek} w. SEEK_CUR

 llseek  	( d1 n2 c -- ud2 er )		(s)		'llseekf'	linux
	syscall _llseek w. d1=signed offset, n2=relation, c=channel; -re- man 2 ...
	n2	offset set to
	 0 SEEK_SET	unsigned d1 bytes.
	 1 SEEK_CUR	it's current location plus signed d1 bytes.
	 2 SEEK_END	eof plus signed d1 bytes.
	ret ud2 := new file ptr, er := ernum.
	file offset may be set beyond the end of the existing end-of-file. If data 
	later written at this point, subsequent reads in the gap return <nul>-bytes.

 copy-file	( p1 u1 p2 u2 -- er )		(s)		'copyf'		forth
	fast, kernel-space only file transfer by file names;
	copy in-file(p1,u1) overwriting to out-file(p2,u2).
	ret er:=error code or er:=no. of bytes sent. no ernum in {work}-cdt.
	ret w/ out-file un-modified if in-file opening returns an error.
	copy by channel numbers -re- {file>file}.
	syscall sendfile -re- man(2) sendfile.
	NOTE:	source restricted to channels which support <mmap> 
		operations, destination may be a socket.
		for instance, cannot be used to reading /dev/vcs{,a}.

 file>file	( c1 c2 ud1 u2 -- er )		(s)		'f2file'	forth
	fast, kernel-space only file transfer, 
	send u2 bytes from channel c1 to channel c2, beginning at file-ptr ud1.
	ret er = error code or er = no. of bytes sent; no channels being closed.
	copy by file names -re- {copy-file}.
	syscall sendfile -re- man(2) sendfile, man(2) mmap.
	NOTE:	source restricted to channels which support <mmap> operations,
		destination may be a socket but, not the source channel.

 fstat  	( c p -- er|p )			(s)		'ffstatf'	linux
	fetch file channel c status data to buf. of size {stat-size} at p.
	use -re- {file-status} to reading the file status by file name.
	syscall fstat -re- man 2 ...

 cd	  	ccc( -- )			(4)(i)		'cdf'		root
	change working directory to {bl}-delimited path ccc.
	no error message, noop if path doesn't exist; $HOME if zero length text.
	use -re- {s"} or {string} and {chdir} for path names w/ blanks.

 (cd		( p u -- )					'pcdp'		novoc

 chdir  	( p u -- 0 | er )		(s)		'chdirf'	linux
	change working directory to path (p,u)
	syscall chdir -re- man 2 ...

 pwd		( -- )								linux
	print working directory (to stdout).

 cwd@		( p1 u1 -- p1 u2 | er )		(s)		'cwdf'		linux
	fetch current working directory path to buf(p1,u1), 
	ret stg(p1,u2) or, p1 and -ve error code. 
	buffer limited to u bytes, by syscall, max up to { path-size 2+ }. 
	syscall getcwd -re- man 2 ... 

 umask  	( n -- )			(s)		'umaskf'	linux
	set new files permissions creation mask
	syscall umask -re- man 2 ...

 file access query modifiers

 r-ok		( -- n )			(m.6)		'rok'		forth
	readable, file access query flag

 w-ok		( -- n )			(m.6)		'wok'		forth
	writable, file access query flag

 x-ok		( -- n )			(m.6)		'xok'		forth
	executable, file access query flag

 f-ok		( -- n )			(m,6)		'fok'		forth
	file present, file access query flag

 faccess	( n c -- er )			(s)		'faccessfd'	linux
	test file access perm by channel no. c w/ query mask n
	ret er = ff if accessible, else -ve. -re- {file-access}.

 file-access	( p u n1 -- 0 | er )		(s)(a:fx)	'faccessf'	forth
	n1 OR-able flags {r-ok}, {w-ok}, {x-ok}, {f-ok}.
	ret zero if caller has access according to flag n1 to file the 
	path+name of which is u chars at p, else ret -ve error code. 
	syscall access -re- man 2 .., linux/fs/open.c.
	security relevant applications should check _after_ open.
	NOTE: syscall by <root> returns root permissions, i.e. all enabled.

 unlock-file	( ch -- er )			(s)(e)		'unlockf'	linux
	clear lock on a file by channel ch, 
	syscall -re- man 2 fcntl
	(eflags reflect error code)

 lock-file	( ch -- er )			(s)(e)		'lockf'		linux
	set lock on a file by channel ch, 
	disabling write access by any other file descriptor.
	syscall -re- man 2 fcntl - returns error free but, no effect... <=
	(eflags reflect error code)

 <decnum>					(k)
	asciz unsigned decimal number string, for {ch-name}

 <decdnum>					(k)
	asciz unsigned decimal number string

 ch-name	( p1 u1 c -- p1 u2 | p1 0 )	(s)		'chname'	forth
	find path and filename of channel c. - requires "proc" filesystem accessible.
	returns valid name w. +ve u2 or, on error u2:=0; does not store a count-byte.
	error code stored to uvari {(ierr)}, -1 if channel c was not open.
	uses {hld} area, below {pad2}, overwritten by words for numeric stg output.
	syscall readlink -re- man 2 ..

 readlink	( p1 p2 u2 -- p u )		(s)		'readlk'	linux
	resolve linkname per asciz-string at p1 to filename (p,u) in buf. (p2,u2)
	syscall readlink -re- man 2 ...
 

 <placeps>	( p1 u1 -- a2 ..cc.. a3 )	(k)
	(supposedly) thread-safe temporary local string conversion & storage:
	temporarily store u1 chars of stg from p1 to asciz stg on tos,
	ret a2 ptr to strg { a2: a3 abs>4th cell- @ }, a3 initial PS, PS:=PS+u1
	NOTE:	for "lib4th" kernel, or within native code words, only!
		PS should be restored before any regular access to datastack.

 search-file	( p1 u1 ch -- d2 0 | dx er )	(s)		'searchf'	forth
	search file by channel ch for stg(p1,u1) beginning at current file-ptr.
	terminates if stg found or at <eof>, <nul> and after <nl> if ch is a console.
	if stg found ret disp of file-ptr from entry to end of stg and er = 0
	if stg not found ret byte-count until eof and er = ENODATA (-61).
	stg(p1,u1) may be up to {path-max} bytes of length.
	reading by single bytes, thus slow but, suitable to any kind of input.

 -- files/devices locking (n.i.)

	

 -- files/devices memory mapping
	{mmap} selects appropriate access method, returns base address or error;
	{msync} for syncronization of data w/ file; {munmap} reverts assignations.
	

 mmap		( p1 u1 m f fd o -- p2|er )	(s)				linux
	maps u1 bytes of file/device w/ file-descriptor fd, beginning at offset o
	bytes, to memory, preferrably at p1, the actual value of which is returned 
	by page-aligned ptr p2 or, an error code er if in range 0 < p < $ffff0000.
	args:
	p1	if zero the system call returns p2 chosen by host kernel, 
		if flag MAP_FIXED set, p2 will forcedly be set to p1, or failure, 
		any non-zero p1 will be page-aligned towards higher addresses.
	u1:	(partial) file size to map into memory
	m:	access mode -re- {prot-r}, {prot-w}, {prot-x} or, neither one.
	f:	flags (re sys/mman.h),
		either one of MAP_SHARED or MAP_PRIVATE required, others otional:
			MAP_SHARED      0x01    Share changes
			MAP_PRIVATE     0x02    Changes are private
			MAP_FIXED       0x10    Interpret addr exactly, fail otherwise
			MAP_ANONYMOUS   0x20    don't use a file
			MAP_GROWSDOWN   0x0100  stack-like segment
			MAP_DENYWRITE   0x0800  ETXTBSY
			MAP_EXECUTABLE  0x1000  mark it as an executable
			MAP_LOCKED      0x2000  pages are locked
			MAP_NORESERVE   0x4000  don't check for reservations
	fd:	file descriptor of file to map, -re- {ch-id}
	o:	file ptr to where to begin mapping.
	sys_mmap receives the data structure:
		00: 0 or preferred/forced address,
		04: length of file, may be partial length,
		08: mode
		0C: flags
		10: file descriptor,
		14: offset wrt file beginning, a multiple of -re- {page-size}.
	syscall re man (2) mmap

 munmap 	( p u -- er )			(s)				linux
	un-map range u at ptr p, mapped file not guaranteed to be updated 
	accordingly unless prior execution of -re- {msync}.
	syscall re man (2) munmap

 msync  	( p u n -- er )			(s)				linux
	synchronize rsp. file w/ mapped range u at ptr p, according to flags n:
		MS_ASYNC        1  sync memory asynchronously
		MS_INVALIDATE   2  invalidate the caches
		MS_SYNC         4  synchronous memory sync
	syscall re man (2) msync

----------------------------------------------------------------
 -- i/o channels (double) redirection - re <struc cdtd> in "lib4th.mac".

	ANS term "fileid" in FILE wordsets is lib4th "channel number", in the 
	range of [0,63] pointing as an index into a table of channel specific 
	data, i.e. the actual file descriptor, access permission and mode bits, 
	several other flags, each of which is extendable by a (yet unused) 
	per-channel link to further data.
	ch-id, "channel identifier", is the linux file descriptor of a "channel"
	which, when set to -1 signifies an unused channels table.

	The pre-compiled number of available channels -re- {max-chan} can 
	be changed by re-definition of %assign-ed cdt_bnum (dft 6) in 
	"constants.inc", cdt tables re-sizeable with %assign-ed <cdt_bsize> 
	in "l4struc.inc".

	

 stdin  	( -- c ) 			(m,5)		'stdinc'	forth
	actual standard input channel number

 stderr  	( -- c ) 			(m,5)		'stderrc'	forth
	actual standard error output channel number

 stdout  	( -- c ) 			(m,5)		'stdoutc'	forth
	actual standard output channel number

 work	  	( -- c ) 			(m,5)		'workc'		forth
	actual work-channel number

 cdt-xptr	( -- n )			(c)(m,6)	'cdtxptr'	linux
	ret disp to xtension ptr in a channel's defn table

 cdt-flags	( -- n )			(c)(m,6)	'cdtflags'	linux
	ret disp to flags in a channel's defn table
	-re- {channel}, {ch-rnum}, {ch-omode}, {ch-perm}, {ch-eof}.

 cdt-fptr	( -- n )			(c)(m,6)	'cdtfptr'	linux
	ret disp to double cell file ptr in a channel's defn table
	-re- {channel}, {ch-rnum}, {ch-omode}, {ch-perm}, {ch-eof}.

 cdt-size	( -- n )			(c)(m,6)	'cdtsize'	linux
	ret size in bytes of a single channel defn table.

 max-chan	( -- n )			(c)(m,6)	'maxchan'	linux
	ret max. number of available channel ptrs/numbers.

 kbd		( -- c )			(c)(m,5)	'kbdc'		forth
	initial keyboard channel, set from stdin

 kbd-chan	( -- n )			(c)(m,6)	'kbdchan'	forth
	keyboard-channel number - system channel, not redirectable.

 kbd-id  	( -- n )					'kbdid'		linux
	keyboard channel number

 work-id	( -- n )					'workid'	linux

 err-id 	( -- n )					'errid'		linux

 out-id 	( -- n )					'outid'		linux

 in-id  	( -- n )					'inid'		linux

 ch-id  	( c -- fd | abort-3 )				'chid'		linux
	file descriptor, n := -1 if fd not available.
	abort if c not in range [0,max-chan); dft -re- {max-chan} = 64 (L4 v10+).
	channel flags -re- {channel}, {ch-rnum}, {ch-omode}, {ch-perm}, {ch-eof}.

 ch-omode	( c -- n )			(m,10)		'chomodef'	linux
	channel open mode. dft is un-set, n=0

 ch-perm	( c -- n )			(m,10)		'chpermf'	linux
	channel permission bits. dft is un-set, n=0

 ch-flags	( c -- n )			(m,10)		'chflagsf'	linux
	channel flags. dft is un-set, n=0

 ch-cons?	( c -- flg )					'chconsq'	linux
	tf if c is in range of lib4th channels and a console channel -re- {max-chan}.

 ch-pty?	( c -- flg )					'chptyq'	linux
	tf if c is in range -re- {max-chan}, and connected to a pty device.

 ch-rnum	( c -- n )					'chrnum'	linux
	ret channel c specific latest error code.

 ch-eof 	( c -- flg )					'cheof'		linux
	ret tf at file eof (if zero ernum in cdt) -re- {ch-rnum}

 channel	( c -- n1 n2 )							forth
	channel i/o-flags n2 and id n1.
	n1 := -1 if fd not available, flags then in-valid.
	other flags -re- {ch-rnum}, {ch-omode}, {ch-perm}, {ch-eof}

 chp		( c -- p | abort-3 )						linux
	ptr p to description of channel c

 new-chan	( -- c | -1 )					'newchan'	forth
	get lowest free channel number, c in range (prt-chan,scr1-chan).
 <svcons>	( -- )				(k)
	store stdin to kbd, if console channel

 to-chan	( c1 c2 -- )					'tochan'	forth
	copy c1 channel description to channel no. c2

 set-chan	( .x. .nn. c -- .x. )				'setchan'	linux
	store file data to channel no. c datafield, clear flags & ptrs

 is-chan	( c -- )					'ischan'	forth
	assign work-channel data to channel no. c

 get-chan	( .x. c -- .x. .nn. )				'getchan'	linux
	fetch file description of channel no. c, ready to {set-chan}

 fd>chan	( fd c -- )					'fd2ch'		linux
	store file descriptor fd to channel c,
	close previously existent channel c

 work-num	( -- c )							linux
	find highest channel no. with fd currently in {work}

 chp>chan	( p -- c )					'chp2ch'	linux
	find channel number from chp - not for {work}-channel

 chn-num	( fd -- c )					'chnnum'	linux
	find highest channel no. which refers to file descriptor fd.
	find highest unused channel no. if fd = -1 passed - re {new-chan}

 xg-io  	( -- )				(4)		'xgio'		linux
	exchange stdin and stdout channel definitions

 xg-chan	( c1 c2 -- )					'xgchan'	linux
	exchange channel defn-s c1 and c2

 source-chan	( -- c )					'sourcechan'	forth
	current input source channel

=====================================================================;
 l4file.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4init.inc>
--------------------------------------------------------------------------


 crea4th	( a1 a2 a3 n1 a4 -- x )		(k)
		( a1:xec a2:nam a3:ss n1:sz a4:bss -- x:er|tor )
	allocate .bss & .ss memory,
	setup standard 4th job stack structure, put initial ptrs to jobstack
	copy caller's user-vari and link to own
	verify/enable initial r/w/x access rights for dictionary in .bss area
	a1... are non-relative addresses (use {fth2abs} for 4th ptrs)
		a4: top address of alterable (.bss) memory currently allocated
		n1: size in no. of bytes to allocate for clone
		a3: bottom address of .ss memory currently allocated
		a2: address of new job's name (asciz)
		a1: initial execution address
	ret x error or clone's esp
;:HIER: -!-

 actv4th	( n1 a1 -- n2 )			(s)
	activate 4th job from previously set up structure - re {crea4th}
	with sys_clone flags n1, ret error or clone's pid & enter clone
	syscall clone, -re- man 2 clone
;:HIER: -!-

 clon4th	( a1 -- a2 )			
	cloned 4th job initial data setup
	refers to data on initial esp, must be called from clone, un-nested
	a1 rel(kref) ref to ref to <quit> entry
	a2 rel(kref) ptr to clone's asciz name string
;:HIER: -!-
;;    mov byte[byte uref uv.aux+3],-1;lock kernel job (i/o)
;;:or:	; ???
;;    mov eax,--wasdenn-- ; <= nach crea4th verlegen und im stack mitliefern
;;    call stacksini.n
	

 <inisiz>
	default "i4th" structure

 ini4th		( -- )			(k)
	initiate base 4th program task
	returns with system regs, memory and user vari set up
	initial {current} and {context} is {root}
	returnstack on return is different to that on exit!
	{ini4th} thus cannot be called from 2ndary subroutine levels, 
	previously stacked data can be accessed via user-vari {(esp)} which
	after return from {ini4th} contains the esp value from before entry.
 entry:
	edi := 0 or addr, ptr to struc w. address of application <quit>, or 0 for {quit} entry
	esi := 0 or addr, ptr to callers arguments

 getref  	( -- )				(k)
	fetch kernel library reference <kref> to ecx
	subroutines, 4th-words, all data refer to this address
	ecx := address of library base reference

 getgot  	( -- p | 0 )							linux
	access to lib4th g.o.t.; restores kref, ret 0 if inactive.
	no subroutine fetching, programs must set up own got reference.
	re macro <GETGOT> in "reloc.inc"

================================================================
 -- memory setup

	initiating routines for programs setup, not suited
	to hi-level 4th access, except those marked "(k)".

	

 <uvcopy>	initiate new 64K user area with old	(mc)

 usercopy	( addr1 -- addr2 )		(k)
	adjust bounds and copy old to new set of uservari
;:HIER: -!-

 <linkdcmem>	( mbot -- mtop )		(k)
	init basic linkage of .bss section, data- and compilespace
	use UR
	set @(bot) and @(top); true addr

 <linkumem>	( ubot -- ulink )		(k)
	init basic linkage of .ss section for stacks, uvari, tib
	set/use @(ulink) and UR reg; true addr

 <linkuvari>	( ubot -- iesp )		(k)
	init stacks, tib & uarea ptrs
	use KR, UR
	store initial regs, kref'd @r0, @s0, preset @(tib)
	dft uv.tib, kref'd terminal input buf.

 <uenvini>	( argptr -- sourceid )		(k)
	initial env & arg count & ptrs
	use KR, UR
	set @(argc), @(argn), @(source-id), @blk and @(argp); true addr
	uv.uargc	cnt		of received arguments
	uv.uargn	preset		argc running counter
	uv.blk		-1		if args present, else 0 for terminal input

 <quitini>	( i4th.addr -- quit.ptr )	(k)
	initial program execution entry, {quit} if zero
	use @(esp), KR, UR
	set kref'd @(quit).

 <idsvs>
	init compile- and dataspace in .bss memory
	set prior to entry:
		ebx	<Y>		kernel base address
			uv.mbot		tasks bottom of .bss memory
	setup of:
		edi	uv.d0		PS, datastack bottom and initial tos
			uv.dp		dataspace pointer
			uv.dtop		end of dataspace, init kref'd @uv.mtop
			uv.cp		codespace ptr
			uv.c0		bottom of codespace
			uv.head		compile/interpret-pointer, init @uv.cp
			uv.tail		compile/interpret-pointer, init @uv.cp
			uv.ctop		end of compilespace, init @uv.d0

 iiocons
 setup of new user's i/o constants:
	(uvari)		(initial val)	(usage)
	uv.up		uv.vbot-(uv.link)	disp from <uref 0> down into user area
	uv.inchp	0		chp of latest input channel
	uv.outchp	0		chp of latest output channel
	uv.uiovtim	qtermnum<<8|qtermtimo	VMIN chars, VTIME timeout
	uv.utibmax	d_ntib-4	size of t.i.b., leave space for trailing <nul>
	uv.span		0
	uv.in		0
	uv.base		d_base		number conversion radix
	uv.ueol		d_ccr		<cr> ascii sequence up to 4 bytes =/= 0
	uv.upchr	d_pchr		ranges of printing chars
	uv.uescc	d_escc		{ptype} escape symbol
	uv.ucan		d_cmul<<16|d_can  hi-w.min-cnt of lo-w.termination char
	uv.untab	d_tab		<tab> spacing
	uv.ustimo]	d_ustimo	timeout[s] for accept, by sys-select, {wait4in}
	uv.ustimm]	0		timeout[s]

 ivecw
	restore <kref>, init user vectored words by true addresses
	(word)		(uvari)		;	{name}s
	qterminal	uv.uekeyq	; ?terminal	<- (ekey?)
	emit		uv.uemit	; emit		<- (emit)
	type		uv.utype	; type		<- (type)
	osaccept	uv.uaccept	; accept	<- (accept)
	echo		uv.uecho	; echo		<- (echo)
	ok		uv.upokp	; [ok]		<- (ok)
	?error		uv.uqerror	; error		<- (?error)
	error		uv.uerror	; error		<- (error)
	eval		uv.ueval	; eval		<- (evaluate)
	number		uv.utonum	; [number]	<- (number)
	smbyrem		uv.umbym	; sm/rem	-> (um/mod)
	roottop		uv.last		;		-> last
	Vroot		uv.voclink	;		-> voc-link
	licc4thg	uv.icc4th	; 		-> <icc4th>
	locc4thg	uv.occ4th	;		-> <occ4th>

 alink					(k)
	adjust words linkage, subroutine by <ilink>

 task		( -- )								forth
	last word of kernel wordlists, a {noop}

 ilink
	system words initial linkage, 1st which may modify data-space
	for modules words linkage re {wlink}

 wlink  	( ptr -- ix )			(k)
	restore kref, link module
	NOTE:
	2ndary modules loading yet not orderly implemented (missing relocation)!

	linkage at [kref ptr]:
	blockbase, 1st lfa is relocation reference
		1st header[zero.indx,flags|link|exec|name]
			     .---------------^--------------<------.
		2nd.header[disp.to.1st.lfa|voclink|0|name|toplink] |
		module xtn:	[last.lfa|top.voclink]             |
					   ,---------------->------'
		3rd.header[rel.index,flags|link|name|exec]
					   ,-^
		4th.header[rel.index,flags|link|name|exec]
		nxt.header[..more-words..]
		top.header[rel.index,flags|link|name|exec]
				toplink ----^

 <setpty>					(k)
	check whether stdout is to pty, ret immediately if not,
	else re-open stdout in blocking w/o mode.
	curently disabled (since not required):
	dependent on compileflag in "Makefile", __PTY_CAL,
	if fast displaying output remains incomplete, still,
	re-vector {type} and {emit} to delayed variant, e.g.
		{ ' [dtype] idx>xec 4th>abs (type) ! }
	delay applies only to stdout determined to be a pty,
	i.e. output to Linux console remaining at full speed.

 <setkbd>					(k) (un-used)
	set {kbd-chan} to current input console
	open "/dev/tty" if neither of stdin, stdout, stderr is a console

 <inicdt>					(k)
	initialize true addr <tattr> and ptr to <palette> dataspace, 
	set-up channels definition and relocation tables.
	k: immediately after initial words linkage procedure

 argcopy	( -- )				(4)(k)
	copies initial program arguments to tib, delimited by blanks
	and, optionally terminated by the "--" argument.
	if any args present {tib} will then be current input source
	with fetched length in {span} and {#tib}, and {in} set to 0.

 vers		( -- n )							root
	decimal 4 bytes version no.

 lib4th  	( -- )				(uninitiated)			root
	rst kref, print library version

 --no-env-ini	( -- )								root
	pass as an argument to suppressing initial F8INI env-vari evaluation.

 --help 	( -- pid )			(uninitiated)	'ihelp'		root
	rst kref, print system-message, exit immediatelyl if {help} 
	was the single one arg passed w. program invocation.

 mquit					(k)(uninitiated)
	rst kref, exit program w. zero error code

 newline					(k)(u)
	rst kref, send line feed & carriage return to stderr

 --version	( -- )				(u)				root
	display lib4th version and exit if no other args passed to program.

 version	( -- )				(u)				root
	display lib4th version

 wzo		( -- )				(k)(s)(u)(r)	'writezo'	novoc
	send asciz string <ecx> to stdout.
	hard coded destn is host STDOUT channel.
	

 -- (i/o testing)

 keycall	( -- ) -:test:- keyboard input

 eus		( -- )				(s)(u)(r)	'erustg'	novoc
	uninitiated, print 4 chars @ecx to stderr

 esm		( n p -- )			(s)(k)		'ersmsg'	novoc
	send message no. and stg, -re- <erustg>, <erudot>

 erdot  	( n -- n )			(s)(k)(u)
	uninitiated, signed sedec number @eax output to stderr

 ekm		( p -- )			(s)(k)		'erkmsg'	novoc
	fetch by ptr & send message stg, -re- <erustg>, <erudot>

 eum		( a -- )			(s)(k)		'erumsg'	novoc
	fetch by true address & send message stg, -re- <erustg>, <erudot>

 eud	  	( u -- u )			(s)(k)(u)	'erudot'	novoc
	uninitiated, 8 digits unsigned sedec number @eax output to stderr
	for uninitated erros only; native 4th-routines.

 -- end of initial lo-level routines

================================================================
 l4init.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4interpret.inc>
--------------------------------------------------------------------------


------------------------------------------------------------------------
-- interpreter, forget, find
	

 marker 	ccc( -- )			(a:cx)(4)			forth
	defining: save stacked search-order, current, fence values, latest.
	execution: forget till marker, discard new, rst saved system state.
	NOTE:	{fence} values stored after the rsp marker was defined won't 
		protect against implied forget by the marker word.
		use -re- {empty} to {forget}ting everything after {fence}s.

 forget  	ccc( -- )			(a:t)				forth
	remove words defined after and including word w. name {ccc} and 
	{allot}ted data from dictionary, i.e. code- and data-space, including 
	and running through all vocabularies (orderly defined, i.e. not just 
	"wordlists"). noop if word not found, fenced or in non-alterable memory.
	special cases error handling can be achieved w/ -re- {sforget}.
	see also -re- {empty}, {:forget}, {forget>}, {marker}.

 empty  	( -- )								forth
	forget all above {fence}d ptrs.
	NOTE: current state of program code & data can be saved w/ -re- {fence!}

 iforget	( ix -- flg )							hidden
	forget words defined after and including word by execution token ix
	in range (last in kernel) < @ifence <= ix < @(lkindex).
	if ix is a voc replace occurences in voc-stack and current with {local}-wid.
	header-less words can only be removed in code-space, no data-ref exists.
	flg: -1 success,    1 search-order changed, 0 not found
	     21 {fence}d,  23 kernel/non-writable memory.

 sforget	( p u xt -- flg )						hidden
	forget words defined after and including word w. name of string (p,u)
	in range (last in kernel) < @ifence < ix(p,u) < min(xt,@(lkindex)).
	if (p,u) is a voc replace occurrences in voc-stack with {local}-wid - which is
	short (i.e. fastly searched) and, neutral because forcedly searched 1st, anyway.
	{context} will be restored from {ocontext}, if possible, else both set to {forth}.
	flg: -1 success,    1 search-order changed, 0 not found
	     21 {fence}d,  23 kernel/non-writable memory.
	NOTE:	unsafe if local values exist in the chain of words to forget.
		which applies to locals assigned while interpreting or, those 
		which may be left at error abortion while defining a word.

 :forget	ccc( -- )			(ix)		'colforget'	forth
	initiates a header-less word, linked to the {forget-lk} chain, 
	which will be executed before {forget} removes the word ccc.
	the handling word receives ix of the word to {forget} @tos and @nos
	and, should not modify the @nos item nor drop any item from stack; 
	except, a word can be protected by returning @nos cell set to zero.
	additional data left on stack will be discarded, internally.

 forget>	ccc( -- )			(i)		'forgetgt'	forth
	to be placed before {does>} and after {create} in a definig word, to 
	setting up a link to the chained word-specific forget handlers. 
	At execution the word being defined will be assigned the word ccc to, 
	which,in turn, will be executed immediatly before the newly compiled 
	word is to be removed by {forget}. -re- {:forget}, {sforget}.
	compiles a preliminary structure, 3 cells, the last of which contains 
	the execution token ix of the handler word. example:
		: defn ..words1.. create ..words2.. forget> noop does> ..words3.. ;

 fgl		( ix -- )					'fgl'		novoc
	by {forget>} cpl'd runtime code, ix is handler word's xec-token.
	(asm level useage example -re- {ibbuf}, buffer-blocks allocation)

 forget,	( ix1 ix2 -- )					'fgcomma'	forth
	allocate linkage field and link hnd ix2 for word ix1 into forget-lk chain.
	-re- {:forget}, {forget}, {sforget}.
	

 SEARCH-WORDLIST ( p1 u1 p2 -- p3 flg ) 	(a:s)		'swlist'	ans
	find name(p1,u1) in headers chain beginning at lfa p2
	this is ANS-4th version of (find) - re below

 (find)  	( p1 p2 -- p3 flg )		(e)		'pfindp'	hidden
	find name at p1 in headers chain beginning at lfa p2
	return lfa p3 and flg =/= 0, else strg p1 and 0;
	set macro-flag in {state} according to words capabilities.
	flg := 1 if word is immediately executing in either -re- {state}.
	default search mode letter case in-dependent, which can be forced to 
	case dependent w/ a header flag in the words' defn or, by {lc-depend}.
	upper case synonyma should conventionnaly be defined earlier than their 
	lower case counterparts, as in kernel, such that the lower case word 
	would take precedence before upper case defn, in case-independent mode.
	char and case conversion re-mappable, using tables (lo>hi) and (hi>lo).
	(e: eflags reflect flag value)

 blwf		( -- n1 f )			(k)				novoc
	does{ bl word find }, eflags set according to {find} flag result

 find		( p -- p 0 | ix 1 | ix -1 )	(e)(4)(a:c)			forth
	find uot index from string at p searching the stacked search order. 
	values returned by FIND while compiling or interpreting may differ.
	{local} searched 1st, unconditionally, {root} last if not in search 
	order. for wordlist specific search -re- {(find)}, {search-wordlist}.
	letter case dependency:
	dft {lc-ignore} and {uc-unmap} mode, true chars case independently,
	which can be modified by
	 {lc-depend} case dependent
	 {lc-ignore} case independent
	 {uc-map}    input mapping upper to lower chars
	 {uc-unmap}  input upper and lower chars

 -find  	ccc( -- p flg)			(e)(4)(fg)	'dfind'		forth
	find word w. name string <ccc> in the stacked search order,
	if found ret lfa and flg := 1 if word is immedate, else -1.
	ret ptr p to counted string <ccc> and flag 0, if not found.
	(e: result flag status)

 scanwlist	( n1 p1 -- n2 n3 )						hidden
	common routine to scanning vocabulary stack
	expects xec-ptr p1 of working routine w. stack flow
		( n1 toplfa -- n1 0 | n2 n3 )
	after {locals} wordlist, searching in stacked lists order,
	toplfa from vocstack and, if no success, lastly from {root},
	ret n2 as determined by routine p1, n3 flag according to result.
	scanning terminates early if supplied routine returns non-zero.
	last opr if no success is {perform}ing user-vari (scanwl).

 scanvocs	( n1 xt -- n2 )			(e)				hidden
	common routine to scanning vocabulary linkage, latest to 1st.
	expects xec token (uot index) xt of a working routine w. stack flow
		( n1 wid lfa lfa --      exit: nn xxx xxx  0	or
				 -- next word: nn wid lfa 0=/=	or
				 -- next voc.: nn xxx  0  0=/=	)
	scanning terminates if supplied routine returns zero or all vocs done.
	(eflags reflect state of n2)

 [scanvocs]	( n1 p2 -- n2 )					'bscanvb'	hidden
	as -re- {scanvocs} but, w/ p2 execution ptr instead of ix.

 [debug]	( flg ix -- flg ix )				'bdebugb'	compiler
	executed before compiling any non-immediate words. initially a noop.
	if non-zero execute true address or xec token from uot vector ([debug]).
	then store current cp and ix @nos to uvari (prevcp) and (previx).
	debugging routine receives previous ix in ECX reg, current ix is @nos; 
	items on stack may be modified to any appropriate (valid!) value.

 ]interpret	( p u -- p u )					'binter'	compiler
	execute if non-zero, true address or xec token in uot vector (]interpret).
	last action, called from <[interpret]> if neither, a word nor a number found.

 interpret[	( ix f -- ix f )				'interb'	compiler
	execute if non-zero, true address or xec token in uot vector (interpret[).
	1st action, called from <[interpret]> immediately after {find}.

 interpret					(v)				forth
	execute true address uot vector (interpret), default is <[interpret]>.

 [']		ccc(C: -- )( -- ix )		(i)		'tick'		ans
	compile execution index of word ccc as a literal
 '		ccc(C: -- )(X: -- ix )		(i)		'tick'		forth
	find execution token of word ccc and return a literal, else abort

 '		ccc( -- ix )			(a:c)		'atick'		ans
	find execution token of word ccc, else abort
	ANS-4th version, non-immediate.

 [interpret]	( -- )				(k)		'binterpretb'	hidden
	default 'outer interpreter' loop ('inner interpreter' is the cpu).
	reads word at ptr a1, pre-compiles exec token (uot index) or literal.
	executes -re- {interpret[} immediately after initial {find},
	and -re- {]interpret} if the token was neither a word nor a number.
.;; obsolete after {word} bugfix v0.0.58) -?-
';;

 \\		ccc( -- )					'quit'		forth
	comment till eof, exits loadfile (to next lower nesting level)

 quit		( .xx. -- .xx. ) (R: .xx. -- ) (C: .xx. -- ) (v)		root
	the outer interpreter, dft xec {[quit]}.
	

 [squit]	( .xx. -- )(R: .xx. -- )			'bsquitb'	hidden
	entry from abortion by SEGV signal handler

 [quit] 	( .xx. -- .xx. ) (R: .xx. -- ) (C: .xx. -- )	'bquitb'	hidden
	the outer interpreter (dft to {quit}):
	setup kernel ref, enable interrupts, 
	store zero to {blk}, {id} and {state}, 
	store {btail} to {cp}, clear return-stack, 
	enter interpreting loop, w. data-stack bounds check.

 [evaluate]	( p +u -- ..xx.. )				'bevalb'	hidden
	execute command or fetch number or send error.
	may be nested to any no. of levels, limited by available memory.
	saves/restores {blk},{in},{span},{stdin},{tib} on return-stack
	using p and +u, temporarily stored to locally assigned {tib} and {span}.
	initial vector for -re- {evaluate}.

 evaluate	( p +u -- ..xx.. )		(a:c)(v)			forth
	interpret string at p of length +u; dft -re- {[eval]}
	save/restore {source-id}, execute true address uot vector (eval).

 -execute	( p flg -- )					'dexecute'	forth
	-re- {execute} p if flg =/= 0, else drop p and flg

 perform	( p -- ..xx.. )							forth
	execute by ptr to uot index, drop & do nothing if p = 0 or @p = 0.
	ptr p is the ptr to index field (ifa) of a word header or any other 
	variable the l.s.w of which contains an execution token (uot index).
	example: { ' name sp@ perform }.
	NOTE:	because lib4th vectors may be de-activated by ptr to 0 
		{perform} cannot execute a call to {root} by uot index.

 execute	( ix | a -- ..xx.. )						forth
	execute 4th word by +ve uot index or, by true address a.
	noop if zero or kref'd zero or, if address not in regular program memory.
	{execute} can be used by index or by true execution address:
		{ -find name IF lfa>idx execute ENDIF }
	or,	{ c" name" find IF execute ENDIF }
	or,	{ (ok) @ execute }.
	or,	by ptr from <pfa> in word header if uot entry = 0.
	asm: <eax> if = ix converted to address, no (other) regs changed.

	

 <tudisp>	( n -- n )			(e)(k)
	eflags: disp into uot out of bounds if NZ
	for {see}, {dcm}, etc.

================================================================
-- conditional interpretation, comment, shell execution

	

 defined	ccc( -- f )			(w3)				forth
 [DEFINED]	ccc( -- f )			(i)				ans
	tf if wordd ccc found in current search order.

 o(		ccc( -- )			(i)		'ocommentp'	root
	dependent on type of output device print or silently discard a comment.

 (		ccc( -- )			(i)		'paren'		root
	discard multiple lines spanning comment till matching ")"

 .(		ccc( -- )			(i)		'commentp'	root
	display multiple lines spanning comment till matching ")"

 .\		ccc( -- )			(i)		'dotbslash'	root
	display comment till e.o.l.

 if-nfound	ccc( -- )			(i)(f6)		'ifnfound'	root
	conditionally include text until <eol> to interpretation

 if-found	ccc( -- )			(i)(f6)		'iffound'	root
	conditionally include text until <eol> to interpretation

 if-true	( flg -- )			(i)(f6)		'iftrue'	root
	conditionally include text until <eol> to interpretation

 \\		ccc( -- )					'quit'		root
	comment till eof, exits loadfile (to next lower nesting level)

 #!		( -- )						'hb'		root
	enable shell script execution. requires {ss} at end of top line:
		#! /forth-executeable ..optional args.. ss
	note that {#!} requires at least one trailing space (blank, tab).
	{#!} introduces a comment, as -re- {\}, such that an executeable 
	script alternatively can be {included} as a hi-level source file. 

 \		ccc( -- )			(i)		'bslash'	root
	comment till e.o.l.

 [IF]		( flg -- )			(i)(4)		'bifb'		root
	immediate, non-compiling decision construct, for conditional cpl, etc.
	([if]/[else]... construct transposed from -re- dpans94 document)

 [ELSE] 	( -- )				(i)(4)		'belseb'	root
	enter execution alternative after false flag to [IF].

 [THEN] 	( -- )				(i)		'noop'		root
	terminate [IF] construct.

=====================================================================;
 l4interpret.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4ioport.inc>
--------------------------------------------------------------------------


================================================================
 -- i/o port access

 ioperm 	( n1 n2 n3 -- er )		(s)		'sysioperm'	linux
	set access mode n3 of n2 ports beginning w. port no. n1.
	restricted to port 0..3ff, requires <root> access rights
	syscall ioperm -re- man 2 ...

 iopl		( n -- er )			(s)		'sysiopl'	linux
	set i/o permission level to n, requires <root> access rights
	syscall iopl -re- man 2 ...

 p@		( port -- n )					'pf'		linux
	read 32-bit value from port

 pw@		( port -- n )					'pwf'		linux
	read 16-bit value from port

 pc@		( port -- n )					'pcf'		linux
	read 8-bit value from port

 p@s		( ptr n port -- )				'pfs'		linux
	store n 32-bit values from port to memory at ptr

 pw@s		( ptr n port -- )				'pwfs'		linux
	store n 16-bit values from port to memory at ptr

 pc@s		( ptr n port -- )				'pcfs'		linux
	store n 8-bit values from port to memory at ptr

 p!		( n port -- )					'ps'		linux
	store 32bit n data to port

 pw!		( n port -- )					'pws'		linux
	store l.s. 16-bit of n to port

 pc!		( n port -- )					'pcs'		linux
	store l.s. 8-bit of n to port

 p!s		( ptr n port -- )				'pss'		linux
	store n 32-bit values from memory at ptr to port

 pw!s		( ptr n port -- )				'pwss'		linux
	store n 16-bit values from memory at ptr to port

 pc!s		( ptr n port -- )				'pcss'		linux
	store n 8-bit values from memory at ptr to port

=====================================================================;
 l4ioport.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4jobs.inc>
--------------------------------------------------------------------------


================================================================
 -- m-tasking

 sh|		( p1 u1 p2 u2 -- )		n.i.				root
	execute an outer shell command by stg(p1,u1), pipe output to buffer(p2,u2)

 sh		( p u -- )							root
	execute an outer shell command by stg(p,u)

 syskill	( n1 +n2 -- er )		(s)(mc)				linux
	send signal +n2 to process(group) n1, receive error flag er.
	n1 +ve:job, n1=0:current process group, n1=-1:all but pid 0, n1 -ve:-(group)
	detailled description re man(2) kill, man(7) signal.
	syscall kill -re- man 2 ...

 alarm   	( n -- )			(s)(4)		'calarm'	forth
	alarm signal after (n) seconds by syscall 'alarm', signal handler 
	executes deferred {(alarm)} which may be set to user supplied word.
	NOTE:	redirected calls due to till unknown reason could push/pop
		to/from datastack, and may even modify other ptrs/regs.
		check, before setting (alarm) to a self-calling 4th word!
	EXAMPLE: : a cur! 0. at-xy .time&date cur@ 10 alarm ;
		 ' a is (alarm)	1 alarm		\ enable
		 default-is (alarm)		\ disable
		-re- <4th/edit.f8>

================================================================
 -- self

	

 uid@		( -- n )			(s)(m,8)	'uidf'		linux
	fetch real user id of calling job
	syscall getuid -re- man 2 ...

 gid@		( -- n )			(s)(m,8)	'gidf'		linux
	fetch real process-group id of calling job
	syscall getgid -re- man 2 ...

 uid!		( n -- er )			(s)(m,8)	'uids'		linux
	set real and effective user id of calling job
	syscall setuid -re- man 2 ...

 gid!		( n -- er )			(s)(m,8)	'gids'		linux
	set real and effective process-group id of calling job
	syscall setgid -re- man 2 ...

 real-user	( -- )				(s)		'ruser'		root
	if set, recover from setuid-mode: set effective user id equal to real one.
	syscalls getuid, setuid -re- man 2 ...

 pid@		( -- n )			(s)(m,8)	'pidf'		linux
	fetch process-id of calling job
	re {4th-id} for main job-id
	syscall getpid -re- man 2 ...

 pause  	( -- )						'cpause'	system
	xec from @(pause) either by true address, by uot index or, by 'pfax' ptr.
	noop if zero, kref'd zero or, not in executeable program memory.

 [pause]  	( -- )				(s)		'bpauseb'	system
	force re-scheduling (nanosleep w. zero waiting time)
	syscall nanosleep -re- man 2 ...

 sleep-n  	( u1 u2 -- )			(s)		'nsleep'	linux
	sleep for u1 s + u2 ns
	syscall nanosleep -re- man 2 ...

 wait		( u -- )			(s)				forth

 sleep  	( u -- )			(s)				linux
	wait u seconds
	syscall nanosleep -re- man 2 ...

 ms		( u -- )			(s)(a:fx)			forth
	wait u milliseconds (accuracy greater than 2 o/oo, w. rt-linux).
	re DPANS 10.4.1.1/10.6.2.1905:
		repeatbility w/ rtl extension in range of nano-seconds, 
		otherwise deviation and min. time slice by about 10ms.
	syscall nanosleep -re- man 2 ...

 sleep-m	( u -- )			(s)(mc)				linux
	wait u microseconds
	syscall nanosleep -re- man 2 ...

 tick>s  	( dn -- dn )					'tic2s'		forth
	convert cpu clocks to seconds

 tick		( -- dn )			(f6)(m,9)	'tic'		root
	read cpu hardware clock register, using "rdtsc" opr.
	re DPANS 10.4.1.1: can be used to determining duration of a system-clock tick.

 ?ms		( -- n )							ans
	ret no. of milli-seconds elapsed after host system start. not a standard 
	word! frequently used w/ certain (pseudo-)ansi-ish benchmark programs...
	initiall 1s delay - if neither {set-cal} nor {ti-cal} previously executed.
	NOTE: prefer {tick} and {ti-cal}, for reliable & exact time measurements.

 set-cal	( -- )				(f6)(mc)	'setcal'	hidden
	find processor timing, 1s quiet + 1s for measurement.
	single (l.s.) cell result stored to user-vari (tick).
	multiple measurements accumulate to previous value, 1:1.

 <srstosb>, <sstosb>, <srstosd>, <sstosd>, 
 <srmovsd>, <smovsd>, <srmovsb>, <smovsb>

 <rlock>					(k)
	exec routine on next on tor w. interrupts locked, port i/o enabled
	unlock, return to caller. - kernel routine, only.

 mtlock  	( -- )								system
	lock multitasking, i.e. interrupts(!), enable global port i/o.
	use {mtunlock} or {xlock} to re-enable keyboard and files access.
	NOTE1: use PAIRED WITH {mtunlock}, else might leave OS un-accessible!
	NOTE2: interrupt locking active w/ root or suid root programs, only.
	%define __lockthread in "constants.inc" to locked data transfer mode.

 xlock  	( ix -- )							system
	exec routine at ix while interrupts locked and port i/o enabled
	ix is uot index of word to execute. lock, exec, unlock, ret to caller.
	suid programs, only! %define __lockthread in "constants.inc" to activate.

 mtunlock	( -- )								system
	unlock multitasking: enable interrupts, disable global port i/o.
	a noop if not applicable, -re- {mtlock}

================================================================
 l4jobs.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4locals.inc>
--------------------------------------------------------------------------

	

----------------------------------------------------------------
-- local memory
	<top> @s0[ data-stack ... tos]			- no locals
	<top> ..locals.. @s0[ data-stack ... tos]	- locals allocated
	most recent local data allocated @s0, stack content moved "up".
	ptr to <top> is absolute low limit for @s0 and locals and, can be
	used to control error situations if stack-ptrs became un-certain.

	

 >loc		( n -- )							forth
	allocates and clears +n or de-allocates -n cells of local data-space,
	accordingly adjusts user vari {s0}, {(locb)} and {csp}.
	requires explicite removal by -ve n, before end of a compiled word, 
	use before {locals|} defn to keeping the rsp local values' ptrs valid.
	asm: LP register <esi> set to true addr @s0 after de-/allocation.

 (LOCAL)	( p u -- )			(e)		'plocalp'	ans
	builds a local wordheader w. name from string(p,u). 
	use not within a control structure!
	stores disp to local cell wrt LP = @s0 to 'body'.
	at compile-time allocates local memory as required, diff @s0 before 
	and after; single cell runtime reservation.
	reserved names:
		'--'	introducing comment in " .. { .. | .. -- .. } "
		';'	terminator of other purpose ordered lists - n.i.
		'}'	terminator in " .. { .. | .. -- .. } "
		'|'	terminator in " .. locals|  ...  | " and,
			introducing zero-initiated locals in ".. { .. | .. -- .. }"
		';', 'M:' 
			reserved for other data structures (M = single decimal digit)
	(e: ret Z and char(s) in edx after reserved name, else NZ)

 locals 	( -- n )							forth
	ret number n of currently available, reserved local cells.

 locals?  	( n -- flg )					'localsq'	forth
	tf if suffient no. of currently reserved local cells available.

 loc-body	ccc(C: -- )(X: -- p )		(i)		'locbody'	local
		ccc(I: -- p )
	find ptr to "body" of word ccc in {local} wordlist, return/compile literal ptr p.
	compiletime utility, ix invalid after word defn finished.

 loc'		ccc(C: -- )( -- ix )		(i)		'tick'		local
	imed. get xt of a local name ccc, else abort-38 err.ni
	compiletime utility, ix invalid after word defn finished.

 loc!!  	ccc ccc( -- )			(i)		'locxsto'	forth
	exchange two local values by names, use{ loc!! name1 name2 }.

 l!!		( p1 p2 -- )			(k)		'dolxsto'	novoc
	runtime code for {loc!!}

 loc-ptr	ccc(C: -- )(X: -- p )		(i)		'locptr'	forth
	get literal ptr to runtime data-space of a local value

 locals|	ccc( -- )(C: n1..nn -- )		(i)(a:lx) 'locbar'	forth
	parse list of names delimited by "|" and assign local values, accordingly.
	use at beginning of a colon definition, before any other control structure.
	accessing double items:
		.. locals| n1h n1l | .. loc2@ n1h d. .. loc-ptr n1l 2@ d. ..
	(Non-)Limits:
	Locals don't interfere w/ any other data access method, stacks, dictionary, 
	etc. and, next levels' locals can be accessed in the order of definition.
	The number of locals is not limited other than by available stack- and 
	data-space, locals' names are limited to the common 255 chars (bytes) as 
	for any words' names. A runtime local takes 4 bytes of locals area, "below" 
	data-stack, and 7 bytes in code-space. While compiling a local uses 8 cells 
	plus name-length in data space and an uot index.
	further description re {local:}, compile-mode, and ANS word {(LOCAL)}.

 locref{ ccc ... } ( -- )				(i)	'locref'	forth
	refer to a caller's locals in sequence of given names list such, that any
	group of forth words operating on locals can be factored to separate words
	w/o requiring repeatedly fetching and storeing just to pass the arguments.
	names by this list are local, used to compile the rsp. reference by index
	in sequence left to right, which coincides w/ the sequence of the caller's 
	words, regardless of their names, if set up with -re- "{".
	next levels' locals can be accessed in the order of definition.
	NOTE1: a thus defined word cannot allocate own local values!
	NOTE2: access to doubles as in the word the locals of which locref{ refers to.

 {		ccc( -- )(C: n1..nn -- )		(i)	'loccb'		forth
	define local values in stack flow notation order, left to right.
	use "{ initiated locals | self-zeroing locals -- comment }"
	accessing double items:
		.. { n1l n1h } .. loc2@ n1l swap d. .. loc-ptr n1h 2@ swap d. ..
	NOTE:	this was a short 'hack' to enabling the apparently more 'fashionable'
		notation in stack flow order, where only(!) the initated locals cells 
		storage is in opposite order wrt that of {locals|}.

 local: 	ccc(C: -- )(C: p f ix -- )(X: -- n )	(i)(a:l) 'locol'	hidden
		ccc(I: n -- )		(X: -- n )
	define a single cell sized local value by name ccc. used by {locals:}.
	use outside any other control structure, preferrably at beginning of a 
	coln defn. words with a {locals|} group may be {exit}ted, out of order.
	While interpreting:
		constitute a {value} in local dataspace, in {local} wordlist
	  execution of <ccc>:
		push local value to tos.
	While compiling:
		constitute a {value} in local dataspace, in {local} wordlist,
		accessible by name within the current colon-definition, only.
		initially push 3rd control item to tos, set <mlocal> state-bit.
	  runtime <ccc> declaration:
		assign local data-space, transfer cell from tos.
	  execution:
		push local value to tos.
	Data structure:
		memory	@s0-@(locb}[ local memory .. @last ... local value(s) ]@s0
		xec	[ header [@pfa=kref(xec)][@body=disp] ]
		value	@(@s0-disp)
	Storing a value
		1: value initially taken from @tos.
		2: {to} and {+to} designed to modify either, local or global {value}s.
		3: by ptr to local data-field ( nn -- ) { loc-ptr name ! }
		   multiple cells storage in descending order of locals assignation,
		   latest named local stores l.s.cell of the rsp. item, for instance
			{ ..locals| n1 n2 n3 n4 | loc-ptr n4 4!.. }
		4: fetch/store a double ( d1 -- d2 ) { ..loc2! name .. loc2@ name.. }
	NOTE1:	while compiling pushes a 3rd cell to control-stack (at data-stack)
		which will be required for locals resolution by {;}, therefore the 
		locals| group should not be cpl'd within a program flow structure.
	NOTE2:	due to indirection of local data access, global values, variables 
		or constants execute faster than locals; a short sequence of simple 
		stack operations may be much faster, still.
		also, consider utilizing the {pick} and {-pick} operations.
	NOTE3:	locals stored to contiguous data-space, thus linearly accessible
		across multiple, unlimited levels.

 local values, runtimes
	

 lz:		( -- )				(k)		'dolocz'	novoc
	zero-initate single cell local vari, cpld by compiling "{"

 lv:		( n -- )			(k)		'doloci'	novoc
	initate single cell local vari, cpld by compiling {local:}

 loc2!	ccc( dn -- )			(i)(C)		'loc2s'		local
	cpl store double local vari, using named value's posn and next.
	little endian cells order wrt {locals|} setup, name ccc at l.s.cell.

 loc2@	ccc( -- dn )			(i)(C)		'loc2f'		local
	cpl fetch double local vari, using named value's posn and next.
	little endian cells order wrt {locals|} setup, name ccc at l.s.cell.

 la:		( -- )				(k)(r)		'doloca'	novoc
	runtime local values' memory allocation, cpld by compiling {local:}
	local data-space erased. LP-reg := @s0 := @s0 + local bytes, by {>loc}.

 lv>		( -- )				(k)(r)		'dolocc'	novoc
	fetch local value defined while compiling, cpl'd to pfa of (LOCAL) word

 lv@		( -n1 -- n2 )			(k)(r)		'dolocv'	novoc
	fetch local value which was defined while interpreting, by {local:}

 lv;		( -- )				(k)(r)		'dolocr'	novoc
	runtime remove local values. cpl'd by <locrmv> before ;s

 locrmv 	(C: ps lp | ix ps lp -- )	(i)(c)				compiler
	cpl intermediate local values de-allocation, do-nothing if none exist; by {;s}
 <locres>
	while compiling check whether locals defined, cpl final locals de-allocation
 i:	@tos	{ sp@ lp@ } | locals{ ix sp@ lp@ } & <blocl> flag in @bits set

=====================================================================;
 l4locals.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4lxsrc.inc>
--------------------------------------------------------------------------

	path to host constants sources files
 <linux>							'linuxt'
 <asm>							'asmt'
 <linux>							'lsrpt'
 								

 lxfiles	( -- p u )							linux
	compiled host constants source files list
 <fcntl.h>							'fcntl.ht'
 								
 <ioctls.h>							'ioctls.ht'
 								
 <page.h>							'page.ht'
 								
 <termbits.h>							'termbits.ht'
 								
 <termios.h>							'termios.ht'
 								
 <unistd.h>							'unistd.ht'
 								
 <version.h>							'version.ht'
 								
 								
 								

=====================================
 l4lxsrc.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4memfsto.inc>
--------------------------------------------------------------------------


================================================================
--  memory access
	false data may result if F8 stacks accessed directly!
	explicit addresses shall be passed as ptr's wrt kref.
	fetched data items not sign extended, unless mentioned.

 c@+		( a1 -- a2 u )			(m,7)		'cfetchp'	forth
	fetch byte pointed to by @tos and increment a1 by byte size
	(this is traditional {count} implementation)

 c@		( ptr -- u )			(m,4)		'cfetch'	forth
	fetch byte pointed to by @tos

 w@+		( a1 -- a2 u )			(m,10)		'wfetchp'	forth
	fetch half cell pointed to by @tos and increment a1 by its size

 w@		( ptr -- u )			(m,4)		'wfetch'	forth
	fetch half cell item pointed to by @tos

 @+		( a1 -- a2 u )			(m,8)		'fetchp'	forth
	fetch data item pointed to by @tos and increment a1 by cell size

 @		( ptr -- u )			(a:c)(m,3)	'fetch'		forth
	fetch data item pointed to by @tos

 2@		( ptr -- ud )			(m,10)		'twofetch'	fig
	fetch double pointed to by ptr.
 2@		( ptr -- ud )			(a:d)(m,10)	'twofetch'	forth
	fetch double pointed to by ptr.
	-re- 2@ in {ans} voc, for the ANS-4th big-endian cells order words.

 2@		( ptr -- ud )			(a:d)(m,10)	'twofetcha'	ans
	fetch double pointed to by ptr.
	NOTE: re DPANS94 .6.1.0350, inconsistent, BIG ENDIAN cells order!

 a@		( a -- n )			(m,2)		'afetch'	forth
	fetch cell from true address

 a!		( n a -- )			(m,10)		'astore'	forth
	store cell to true address

 c!		( uc ptr -- )			(a:c)(m,11)	'cstore'	forth
	store byte @nos to address pointed to by @tos

 w!		( uc ptr -- )			(m,13)		'wstore'	forth
	store l.s.half cell @nos to address pointed to by @tos

 !		( u ptr -- )			(a:c)(m,11)	'store'		forth
	store item @nos to address pointed to by @tos

 2!		( d ptr -- )			(a:d)(m,18)	'twosto'	fig
	store double @nos to address pointed to by @tos.
 2!		( d ptr -- )			(a:d)(m,18)	'twosto'	forth
	store double @nos to address pointed to by @tos.
	-re- 2! in {ans} voc, for the ANS-4th big-endian cells order words.

 2!		( d ptr -- )			(a:d)(m,18)	'twostoa'	ans
	store double @nos to address pointed to by @tos, 
	NOTE: re DPANS94 .6.1.0310, inconsistent, BIG ENDIAN cells order!

 c!-		( x p1 -- p2 )			(m,10)		'cstorem'	forth
	pre-decrement p1 by one and store byte x, leave new ptr p2.

 w!-		( x p1 -- p2 )			(m,13)		'wstorem'	forth
	pre-decrement p1 by half size of a cell and store l.s. half cell x, leave new ptr p2.

 !-		( x p1 -- p2 )			(m,12)		'storem'	forth
	pre-decrement p1 by cell size and store x, leave new ptr p2.

 c!+		( x p1 -- p2 )			(m,10)		'cstorep'	forth
	store byte x, post-increment p1 by one, leave new ptr p2.

 w!+		( x p1 -- p2 )			(m,13)		'wstorep'	forth
	store l.s. half cell x, post-increment p1 by half size of a cell, leave new ptr p2.

 !+		( x p1 -- p2 )			(m,12)		'storep'	forth
	 store x, post-increment p1 by cell size, leave new ptr p2.

 c@!		( p1 p2 -- )					'cfsto'		forth
	copy byte (char) at ptr p1 to ptr p2

 w@!		( p1 p2 -- )					'wfsto'		forth
	copy 16bit word (l.s.half cell) at ptr p1 to ptr p2

 @!		( p1 p2 -- )					'fsto'		forth
	copy cell at ptr p1 to ptr p2

 2@!		( p1 p2 -- )			(x)		'twofsto'	forth
	copy double cell from ptr p1 to ptr p2
	( mmx mode w/o timing gain )

 2@!		( p1 p2 -- )					'twofstof'	float
	copy double cell from ptr p1 to ptr p2

 c!!		( p1 p2 -- )					'cxsto'		forth
	exchange contents of byte at ptr p1 with byte at ptr p2

 w!!		( p1 p2 -- )					'wxsto'		forth
	exchange contents of word at ptr p1 with word at ptr p2

 !!		( p1 p2 -- )					'xsto'		forth
	exchange contents of cell at p1 with cell at p2

 4!!		( p1 p2 -- )			(x)		'qxsto'		forth
	exchange contents of quad at p1 with quad at p2

 4!!		( p1 p2 -- )					'qxstof'	float
	exchange contents of quad at p1 with quad at p2, non-mmx

 2!!		( p1 p2 -- )			(x) 		'twoxsto'	forth
	exchange contents of double at p1 with double at p2

 2!!		( p1 p2 -- )					'twoxstof'	float
	exchange contents of double at p1 with double at p2, non-mmx

 c+!		( u p -- )			(m,15)		'cplsto'	forth
	add byte u to byte pointed to by p

 +!		( u p -- )			(m,15)		'plsto'		forth
	add u to cell pointed to by p

 m+!		( u ptr -- )			(f6)		'mplsto'	forth
	add sign extended sing @nos to double pointed to by @tos

 2+!		( ud ptr -- )			(f6)		'twoplsto'	forth
	add double @nos to address pointed to by @tos

 (1+)		( p -- )			(e,fg)(M,8)	'b1pb'		forth
	increment cell at p by one

 (1-)		( n1 -- n2 )			(e,fg)(m,8)	'b1mb'		forth
	decrement cell at p by one

 (d1+)  	( p -- )			(e,fg)(M,8)	'bd1pb'		forth
	increment double cell at p by one

 (d1-)  	( n1 -- n2 )			(e,fg)(m,8)	'bd1mb'		forth
	decrement double cell at p by one
	

=====================================================================;
 l4memfsto.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4numconv.inc>
--------------------------------------------------------------------------


	
----------------------------------------------------------------
-- numeric input modifiers

 big		( -- )				(i)(l4)				root
	next numeric input will be taken as a counted integer.
	set bignum-flag in uvari (bits) for numeric stg input,
	flag reset immediately after next literal number or, at eol.

 quad		( -- )				(i)(f6)				root
	next numeric input will be taken as a quad integer or a double 'ranum'.
	set quad-flag in uvari (bits) for numeric stg input,
	the flag can accumulate w/ -re- {ranum} or "\" number input praefix.
	reset immediately after next literal number or, at eol.

 sf		( -- )				(i)(fs)		'sing'		root
	next numeric input will be taken as a SINGLE RATIONAL NUMBER.
	set 'ranum'-flag in uvari (bits) for numeric stg input -re- {rational}.
	flag can accumulate for quad ranum input w/ -re- {quad}.
	reset immediately after next literal number or, at eol.

 df		( -- )				(i)(fs)		'ranum'		root
	next numeric input will be taken as a DOUBLE RATIONAL NUMBER.
	set 'ranum'-flag in uvari (bits) for numeric stg input -re- {rational}.
	flag can accumulate for quad ranum input w/ -re- {quad}.
	reset immediately after next literal number or, at eol.

 qf		( -- )				(i)(fs)		'double'	root
	next numeric input will be taken as a QUAD RATIONAL NUMBER.

 flt    	( -- )				(i)(4)		'fltf'		root
	all numeric input will be taken as a double 'ranum', until xec. of {int}.
	pushes the -re- {FLOAT} vocabulary 1st to voc-stack if not already there.
	NOTE that in {flt} state any numeric input will return a rational number 
	(double) cells pair, which can be forded to quad integer w/ '\' praefix.
	Other numeric types can only be fetched in standard state -re- {int}.

 int    	( -- )				(i)(4)		'intf'		root
	clear {flt} state to default, integers interpreting mode.
	takes {FLOAT} from top of voc-stack, if applicable.
	-re- {sf}, {df}, {qf} for single or, {flt} permanent fp input mode.

 -flt    	( -- f )					'fltq'		root
	ret tf if numeric input mode not persistent floats -re- {flt}.

----------------------------------------------------------------
-- number conversion

 base!  	( n -- )			(f6)(m,8)	'bases'		forth
	store @tos to uvari {base}.

 base@  	( -- n )			(f6)(m,4)	'basef'		forth
	fetch current number conversion radix.
	with range check, 1 < @base < 257 if not compiled as a macro.
	expect abiguous numeric results if out of range 1 < @base < 197.
	base = 256 used for string data to character code conversion.

 binary 	( -- )				(f6)				forth
	set number conversion radix := 2

 octal  	( -- )				(f6)				forth
	set number conversion radix := 8

 decimal	( -- )				(f6)				forth
	set number conversion radix := 10

 hex		( -- )				(f6)				forth
	set number conversion radix := 16

 u>d		( n1 -- ud1 )			(m,3)		'u2dn'		ans
	does{ s>d 2abs }

 u->d		( n1 -- ud1 )			(m,3)		'u2dn'		forth
	unsigned extend sing to double, does{ s>d 2abs }.

 d->q		( dn -- qn )			(m,5)		'd2qn'		forth
	sign extend double to quad

 s->d		( n1 -- d1 )			(fg)(m,4)	's2dn'		forth
	sign extend sing to double

 s>d		( n1 -- d1 )			(m,4)		's2dn'		forth
	sign extend sing to double

 s->c		( n1 -- +n1 )			(m,3)		's2cn'		forth
	truncate cell to unsigned byte
	effect is extension of l.s.byte to unsigned single

 s->w		( n1 -- +n1 )			(m,3)		's2wn'		forth
	truncate cell to unsigned word
	effect is extension of l.s. half cell to unsigned single

 c->s		( n1 -- s )			(e)(m,3)	'c2sn'		forth
	signed extend l.s.byte to single

 w->s		( n1 -- s )			(e)(m,3)	'w2sn'		forth
	signed extend l.s.half cell to single

 d->s		( d -- s )			(e)		'd2sn'		forth
	truncate double cell to single
	(e: NZ if double doesn't fit into single)

 d>s						(a)		'd2sn'		forth
	truncate double cell to single.
	re DPANS 8.4.1.2: m.s. cell is lost, w/o indication of ovf.
	
 d->b		( d -- n1 .. n8 )				'd2bn'		forth
	unsigned extract 8 bytes of a double, m.s.b @tos

 s->b		( n -- n1 n2 n3 n4 )				's2bn'		forth
	unsigned extract 4 bytes of a sing, m.s.b @tod

 b->s		( n1 n2 n3 n4 -- n )				'b2sn'		forth
	combine 4 sings l.s.bytes to sing n, ms.b from tos

 b->d		( n1 .. n8 -- d )				'b2sn'		forth
	combine 8 sings l.s.bytes to double d, ms.b from tos

 sign		( n dn -- dn )			(fg)				fig
	FIG mode - ANS-4th is different: ( n -- ) !
	when in case-independent search mode and {forth} on top of voc-stack 
	this variant takes precedence over ANS-style {sign}!

 SIGN		( n -- )			(a:c)		'asign'		forth
	ANS word, linked to {forth} vocabulary, fig-4th is different: ( n dn -- dn )!
	fig-4th {sign} takes precedence when in case-independent search mode and fig 
	on top of voc-stack.

 q#s		( q1 -- q0 )					'qsharps'	forth
	convert q1 to numeric characters at @hld - re {#s}

 q#		( q1 -- q2 )					'qsharp'	forth
	{#} wrt quad no.

 #		( d1 -- d2 )					'sharp'		forth
	divide d1 by {base}, convert remainder to character,
	append char to beginning of numeric output string.

 hold		( c -- )							forth
	prepend char c to numeric stg at @-{hld}

 <#		( -- )						'ltsharp'	forth
	init pictured number conversion, quad or sing (any size)

 #s		( d1 -- 0. )					'sharps'	forth
	convert d1 to numeric characters at @-{hld}

 h>a		( n -- c )			(h4)		'h2a'		forth
	character representation c of byte n
	for any n within range 1 < @{base} < 198

 .r		( n u -- )					'dotr'		forth
	right aligned display n in u chars field, filled up w/ blanks.
	pass 1-s complement of fieldwidth n to appending a trailing blank.

 ?		( a -- )					'ques'		forth
	signed display content of cell at ptr a

 .		( n -- )					'dot'		forth
	signed sing numeric output

 d.		( d -- )					'ddot'		forth
	signed double numeric output

 d.r		( d n -- )			(f6)		'ddotr'		forth
	right aligned display signed double numeric output string
	pass 1-s complement of fieldwidth n to appending a trailing blank.

 (d.r)  	( d n -- p u )			(f6)		'pddotrp'	hidden
	ret double d as signed double numeric stg(p,u)
	right aligned to n bytes field, ready to {type}
	pass 1-s complement of fieldwidth n to appending a trailing blank.

 (ud.r)  	( ud n -- p u )			(f6)		'puddotrp'	hidden
	ret double d as unsigned double numeric stg(p,u)
	right aligned to n bytes field, ready to {type}
	pass 1-s complement of fieldwidth n to appending a trailing blank.

 #>		( xd -- caddr u )			(m)	'sharpgt'	forth
	finish numeric output string, ready to {type}

 q#>		( xq -- caddr u )			(m)	'qsharpgt'	forth
	finish numeric output string, ready to {type}

 (q.)		( q n1 n2 -- p u )			(k)	'pqdotp'	hidden
	convert quad to (n1:+ve)un- (n1:-ve)signed numeric string
	1-s complement fieldwidth n2 to appending a trailing blank.

 q.		( q -- )					'qdot'		forth
	display signed quad numeric output string.

 uq.		( q -- )					'uqdot'		forth
	display unsigned quad numeric output string.

 q.r		( q u -- )					'qdotr'		forth
	right aligned display signed quad numeric output string,
	pass 1-s complement fieldwidth u to appending a trailing blank

 uq.r		( uq u -- )					'uqdotr'	forth
	right aligned display unsigned double numeric output string
	pass 1-s complement fieldwidth u to appending a trailing blank

 s#.		( n -- )					'sdecdot'	forth
	pictured signed numeric decimal output

 #.		( n -- )					'decdot'	forth
	pictured unsigned numeric decimal output

 &.		( n -- )					'octdot'	forth
	pictured unsigned numeric octal output

 %.		( n -- )					'bindot'	forth
	pictured unsigned numeric binary output

 $.		( n -- )					'hexdot'	forth
	pictured unsigned numeric sedecimal output

 u.		( u -- )					'udot'		forth
	pictured unsigned sing numeric output

 ud.		( ud -- )					'uddot'		forth
	unsigned double numeric output

 ud.r		( ud n -- )					'uddotr'	forth
	unsigned double numeric output right aligned to n bytes field

 u.r		( u1 +u -- )					'udotr'		forth
	cnt and ptr to unsigned sing numeric output string
	right aligned to n bytes field, ready to {type}

 u?		( a -- )					'uques'		forth
	unsigned display content of cell at ptr a

 -- numeric stg input
	

 digit  	( c -- n tf | c ff )						forth
	tf: c is a digit, n := numeric value corresponding to c
	ff: c not a digit, value remains un-changed
	base = 256 assumed and no conversion if { @base 256 mod } = 0
	abiguous result if 256 > @base > 96

 number  	( p | p u -- dn | abort )	(v)		'number'	forth
	string to number conversion. - vectored by (number), re fig/ans words,
	actual xec mode dependent on ans/fig preference as set in "Makefile".
	default -re- {[number]} in {forth} voc.

 f-number	( p -- dn | abort )		(fg)		'fnumber'	fig
 number  	( p -- dn | abort )				'fnumber'	fig
	counted string to number conversion, f.i.g.-Forth mode.
	abort if leading char, after opt. prefices, not a currently valid digit.
	detailed spec. -re- {[number]} in {forth} voc.

 a-number	( p u -- dn | abort )		(a)		'anumber'	ans
 NUMBER  	( p u -- dn | abort )				'anumber'	ans
	counted string to number conversion.
	detailed spec. -re- {[number]} in {forth} voc.

 [number]	( p -- [dn|qn|cn] ff | 0. 1 )	(fg)		'bnumberb'	fig
	number conversion of chars at ptr p, until <bl> or low code ctrl char.
	f.i.g.-4th mode, otherwise identical -re- {[number]} in forth voc.

 [number]	( p +u -- dn|qn|cn| f )		(a)(v)		'abnumberb'	forth
	integer number conversion of up to +u chars at ptr p. ANS-style word.
	returns flag f = no. of remaining, unconverted chars in stg(p,u).
	ascii-numeric prefixed string terminated by ctrl chars or blank.
	
	stg may contain a base exponent mark, either the char corresponding to 
	the rsp. @base figure as converted w/ {h>a} or, up to decimal base the
	char "e" or "E". the exponent |exp|<128 can be fetched w/ -re- {edpl@} 
	and will automatically be taken into accont in 'ranum' input mode, only.
	stg can be prefixed by char(s) for a specific base value, re {a-base}.
	valid quad, double and sing numbers include '-ve zero'.
	
	modifiers for numeric stgs w/ optional sign & base praefix:
	{ big ..nn.. }
		for unlimited size counted integers -re- {nnumber}.
	{ quad ..nn.. }
		quad cells integer.
	{ sf ..nn.. } or, { \nn.. }
		praefix for rational number ordered pair,
		{ \nn.. } for a quad int while in persistent f.p. mode -re- {flt}.
	{ df ..nn..} or, { quad \..nn.. }
		next input is double rational number,
	{ qf ..nn..}, { sf ..nn.. }
		for quad and single rational number, rsp.
	
	dpl settings, 'nn' no. of digits after frac. marker:
		0xff80nnnn	counted, umlimited size integer
		0x000080nn	quad integer
		0x008000nn	rational number ('ranum'), cells pair
		0x008080nn	float, double ranum by pair of doubles
		0x008088nn	eight cells, quad ranum by pair of quads
		  -1		sing
		  000000nn	any other +ve is a double
	edpl@
		returns the optional, trailing exponent.

 convert	( dn1 ptr1 -- dn2 ptr2 flg )			'converta'	forth
	ANS-Forth mode, in {ans} and {forth} vocabularies.
 CONVERT	( dn1 ptr1 -- dn2 ptr2 )	(a:cx)		'converta'	ans
	interpret string at @ptr as number to radix @base. -re- {[number]}.

 convert	( dn1 ptr1 -- dn2 ptr2 flg )	(fg)				fig
	fig-Forth mode, dft in {fig} vocabulary, only. -re- {>number}.
	interpret string at @ptr as number to radix @base until 1st non-valid 
	char, leave accumulated double, ptr to after last valid char and flag.
	1-s complement of flag is length of digits string found valid.
	flag result such that {convert} could be continued after having the 
	terminating char analyzed and taken into account (i.e. flg:=flg+1).

 >number	( dn1|qn1 ptr1 u1 -- dn2|qn2 ptr2 u2 )	(v)(m,6) 'tonumber'	forth
	interpret string at @ptr as number to radix @base
	until 1st non-valid and no more than u1 char(s).
	leave remaining cnt and ptr. flag u2 := 0 if all chars converted.
	execute true address uot vector (>number), dft {[>number]}

 [>number]	( dn1|qn1 ptr1 u1 -- dn2|qn2 ptr2 u2 )		'btonumb'	hidden
	dft for {>number}, fetches quad integer immediately after {quad},
	quad flag in dpl: 80xx, w. (xx) for digits after fraction sign.
	-re- {sf}, {df}, {qf} for single or, {flt} permanent fp input mode.

 a-base  	( ptr1 u1 -- ptr2 u2 n )		(f6)	'abase'		forth
	ret base according to praefix to number, else ret current base.
	(almost) any sequence of praefices will do:
		-ve:	"{praefix}-nnn"	and, w/ the same effect
			"-{praefix}nnn"	(OTA-std permitting the 1st, only).
		e.g:	"-\&2.3"	double ranum -2.3 octal = -2,375 dec.
	n := lsw. (16-bit) corresponding radix value, sign flag in msw.
	valid prefices & corresponding radices:
		'%'	2		''	12
		'!'	4		'$'	16
		'@'	8 (OTA)		'0x'	16, w/ leading "-", only
		'&'	8		'"'	256  ascii, "- returns zero
		'#'	10		'^'	-64, convert to single ctrl char code
		'\'	-2,  2nd-ary praefix, fetch double 'ranum' (cells pairs fraction)
		'\'	quad integers modifier while in persistent ranum mode -re- {flt}.
	max-len +u adjusted according to praefix or, -ve to limit by 1st non-valid char
	NOTE: '^' praefix for a single ctrl-code, by next upper-case char, only.

=====================================================================;
 l4numconv.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4qdarith.inc>
--------------------------------------------------------------------------

	

----------------------------------------------------------------
-- mixed quad and double
	

 umd*		( ud1 ud2 -- uq3 )				'umdmul'	forth
	unsigned multiply doubles to quad

 md*		( d1 d2 -- q3 )			(4)		'mdmul'		forth
	signed multiply doubles to quad

 uqd*		( uq1 ud1 -- uq2 ud2 )		(4)		'uqdmul'	forth
	unsigned multiply quad by double, ret six cells prod.

 uq*		( q1 q2 -- q2 qovf )		(X)		'uqmul'		forth
	unsigned multiply quad by quad, ret quad prod & quad ovf = 8 cells product.
	does{ 8 nndup 3drop uqd* 6 nnswap drop 2sdrop uqd* 0. -3 2roll 8 n+ drop }

 q* 	 	( q1 q2 -- q2 qovf )				'qmul'		forth
	signed multiply quad by quad, ret quad prod & quad ovf = 8 cells product.

 umq^  	( u1 u2 -- uq3 )		((x))(4)	'umqpow'	forth
	unsigned raise sing u1 to the power of sing u2, leave quad result.
	max ca. 1,7*10^39, ret quad $ff..ff as overflow indicator.

 qsqrt  	( q1 -- q2 n3 )			((x))(4)			forth
	ret +ve square root of |q1|, n3 := 1|-1 = sgn(q1), 1 if q1=0
	q1 = q2*q2*n3+c | -1 < c < q2, j = [-1,1]
	q2 is nearest integer the sqare of which is lower or equal |q1|*n3.
	NOTE: {qsqrt} is different vs {nsqrt}, {dsqrt} wrt flag n3 =/= 0.

 uqm/mod	( +q1 ud2 -- ud3 uq4 )		(X)		'uqmbym'	forth
	unsigned divide quad +q1 by ud2, ret quad quotient uq4, double remainder ud3.
	div 0: ret ud3:=0, uq4:=-1; fast exit if dvd = 1
	(w/ shortcut to {uqd/mod} if qot would fit into 2 cells)

 ud/		( ud1 ud2 -- ud3 )				'udby'		forth
	unsigned divide doubles, leave qot

 ud/mod 	( ud1 ud2 -- ud3 ud4 )				'udbym'		forth
	unsigned divide doubles, leave qot ud4 & rmd ud3

 uqd/mod	( uq1 ud2 -- ud3 ud4 )				'uqdbym'	forth
	unsigned divide quad by double, ret rmd ud3, quot ud4
	div 0: ret ud4=qot := -1., ud3=rmd := uq1.lo
	(bit-wise div. from F-PC, R.L.Smith)

 df/mod  	( d1 d2 -- d3r d2q )				'dfbym'		forth
	floored division of doubles, double remainder and double quotient

 qdfm/mod	( q1 d2 -- d3r d2q )				'qdfmbym'	forth
	floored division of quad by double, double remainder and double quotient
	 Dividend Divisor   Quotient Remainder
	 -------- ------- | -------- ---------
	     10      7    |    1        3
	    -10      7    |   -2        4
	     10     -7    |   -2       -4
	    -10     -7    |    1       -3
	 dvs = 0 overflow values:
		dvd > 0    $7fff.ffff  $7fffffff
		dvd < 0    $8000.0001  $80000001
		dvd = 0        0.0001          0

 qfm/mod	( q1 d2 -- d3r q2q )		((x))		'qfmbym'	forth
	floored division of quad by double, leave double remainder and quad quotient
	

----------------------------------------------------------------
-- mixed quad and sing
	

 uqsm*  	( q1 n1 -- q2 ovf )		(f6)		'uqsmmul'	forth
	unsigned multiply quad by sing, leave quintuple prod, i.e. q2 & overflow

 uqsm/  	( q1 n2 -- n3 q4 )		(f6)		'uqsmby'	forth
	unsigned divide quad by sing, leave sing rmd n3 & quad quot.
	div by zero ret quot and rmd w. all bits set, i.e. max value.

----------------------------------------------------------------
-- quad

	

 qgcd		( q1 q2 -- q3 )			(4)		'qgcd'		forth
	returns the greatest common denominator q3 of the absolute value of two signed 
	quads. If either number is zero, returns the absolute value of the other one.

 uq/mod 	( uq1 uq2 -- uqr uqq )	((x))			'uqbym'		forth
	unsigned div quad uq1 by quad uq2, leave quad remainder (@nos) and quotient.
	div 0: ret uqr := -1, uqq = -1; fast exit if uq2=dvd = 1

 qmod   	( q1 q2 -- qr )		((x))			'qmod'		forth
	signed div quad by quad, leave quad remainder. -re- {q/mod}

 q/	 	( q1 q2 -- qq )		((x))			'qby'		forth
	signed div quad by quad, leave quad quotient. -re- {q/mod}

 q/mod  	( q1 q2 -- qr qq )	((x))			'qbym'		forth
	signed div quad by quad, leave quad remainder (@nos) and quotient.
	'round near zero' mode, sgn(qot) = sgn(dvd xOR dvs), sgn(rmd) = sgn(dvd).

 qf/mod  	( q1 q2 -- qr qq )				'qfbym'		forth
	floored, signed div quad by quad, leave quad remainder (@nos) and quotient.
	signed 'round near zero' division but, if qq < 0 ret qq:=qq-1, qr:=qr+q2.

 8not		( o1 -- o2 )					'not8'		hidden
	q2 := one-s complement of eight-cells item q1

 nos-4not	( q1 qx -- q2 qx )				'not4n'		hidden
	one's cpl of quad q1 @nos. (double ranum support)

 nos-qnegate	( q1 qx -- q2 qx )				'qnegaten'	hidden
	negate quad q1 @nos. (double ranum support)

 nos-q1+	( q1 qx -- q2 qx )				'q1pn'		hidden
	increment quad @nos by one. (double ranum support)

 3rd-q1+	( q1 qx qy -- q2 qx qy )			'q1pt'		hidden
	increment quad 3rd @tos by one. (uq/mod support)

 nos-q2/	( uq1 qx -- uq2 qx )				'qdiv2n'	hidden
	unsigned divide q1 @nos by 2.

 nos-q1-	( q1 qx -- q2 qx )				'q1mn'		hidden
	dec @nos quad q1 by one. (double ranum support)

 qsm+		( q1 n1 -- q2 )			(e)		'qsmplus'	forth
	add sign extended sing n1 to quad q1

 q+		( q1 q2 -- q3 )			(e)		'qplus'		forth
	add two quad numbers

 o+		( o1 o2 -- o3 )			(e)		'oplus'		hidden
	add two 8-cells numbers. 'ranum' support.
	(e: eflags from m.s. cells addition

 q-		( q1 q2 -- q3 )			(e)		'qsub'		forth
	subtract quad q2 from quad q1

 o-		( o1 o2 -- o3 )			(e)		'osub'		hidden
	subtract 8-cells o2 number from o1. 'ranum' support
	(e: eflags from m.s. cells subtraction

 onegate	( o1 -- o2 )					'onegate'	hidden
	negate eight-cells item

 o1+		( o1 -- o2 )					'o1p'		hidden
	increment eight-cells item by one

 q2/		( q1 -- q2 )					'qdiv2'		forth
	signed divide q1 by 2. 'round towards zero' mode.
	NOTE: correct result, including odd -ve figures (thus NOT ANS compliant).

 q1+		( q1 -- q2 )					'qonep'		forth
	increment quad by one

 q1-		( q1 -- q2 )					'qonem'		forth
	decrement quad by one

 uq2/		( uq1 -- uq2 )					'uqdiv2'	forth
	unsigned divide q1 by 2.

 nos-uq2/	( uq1 qx -- uq2 qx )				'uqdiv2n'	hidden
	unsigned divide q1 @nos by 2.

 3rd-uq2/	( uq1 qx qy -- uq2 qx qy )			'uqdiv2t'	hidden
	unsigned divide q1 3rd @tos by 2.

 qrshift	( q1 n -- q2 )							forth
	shift quad q1 right by +ve n bits, i.e. unsigned floored div by 2^n.
	no overflow result, q2 := 0 if unsigned n > 127

 qlshift	( q1 n -- q2 )							forth
	shift quad q1 left by +ve n bits, i.e. mul by 2^n.
	no overflow result, q2 := 0 if unsigned n > 127

 qslbits	( q1 -- q1 n )							forth
	ret no. n of bits by which +/- q1 can be shifted left w/o change of sign.

 nos-q2*	( q1 qx -- q2 qx )		(e)(m,0)	'qmul2n'	hidden
	multiply q1 @nos by 2.
	(e: C if ovf

 3rd-q2*	( q1 qx qy -- q2 qx qy )	(e)(m,0)	'qmul2t'	hidden
	multiply q1 3rd @tos by 2.
	(e: C if ovf

 q2*		( q1 -- q2 )			(e)(m,0)	'qmul2'		forth
	multiply q1 by 2.
	(e: C if ovf

 q1abs  	( q1 -- ~q1|q1 )						forth
	ret 1s-complement if q1 -ve

 4not		( q1 -- q2 )					'not4'		forth
	convert quad to one-s complement

 qabs		( q1 -- -q1|q1 )				'qabs'		forth
	negate if q1 -ve

 qnegate  	( q1 -- q2 )			(4)				forth
	negate quad (2-s complement)
	q2 := q1 if only signbit of q1 set.

 q+-		( q1 n2 -- q3 )					'qpm'		forth
	apply sign of n2 to q1, i.e. negate q if n < 0

 ?uqcmp	( uq1 uq2 - uq1 uq2 f )		(e)		'quqcmp'	forth
	unsigned compare quads, ret f: 0 if q1=q2, -1 if q2 u< q1, 1 if q2 u> q1.
	(e: Z if q2=q1, C if @tos u< @nos; ~C*NS*NZ if @tos u> @nos, ecx=sg(q1-q2)

 q=		( q1 q2 -- flg )		(e)(4)		'qeq'		forth
	tf if equal quads
	(e: Z if q1 = q2, ecx=sign cell of { q1 q2 - }

 q0=		( q -- flg )			(e)(4)		'qzeq'		forth
	tf if quad q = 0
	(e: Z if q = 0, ecx=sign cell

 o0=		( o -- flg )			(e)(4)		'ozeq'		hidden
	tf if eigth-cells int o = 0
	(e: Z if o = 0, ecx=sign cell

 ?q0=		( q -- q flg )			(e)		'qqzeq'		forth
	non-destructively test quad for zero, tf if quad q = 0
	(e: Z if q = 0, ecx = sign cell | NZ*(ecx<0): q<0, NZ*((ecx>0)+(ecx=0)): q>0

 qsgn		( q -- 1|0|-1 )			(e)(4)				forth
	ret signed unit of |q|
	(e: Z if q=0, ecx=sign cell

 q0>		( q -- flg )			(e)(4)		'qzgreat'	forth
	ret true flag if quad q > 0
	(e: NZ if q>0

 qu<		( uq1 uq2 -- flg )		(e)		'quless'	forth
	ret true flag if quad uq1 < uq2
	(e: ret ^C*^Z if q1 u< q2, Z if q1=q2

 qu>		( uq1 uq2 -- flg )		(e)		'qugreat'	forth
	ret true flag if quad uq1 < uq2
	(e: ret ^C*^Z if q1 u> q2 (tf), Z if q1=q2

 q<		( q1 q2 -- flg )				'qless'		forth
	ret true flag if quad q1 signed < q2

 q0<		( q -- flg )					'qzless'	forth
	ret true flag if quad q1 is -ve

 -4dup  	( q1 | 0  -- q1 q1 | 0 )			'qdup4'		forth
	 duplicate quad @tos if =/= zero.

 4dup		( q1 -- q1 q1 )			(x) 		'dup4'		forth
	duplicate quad
 4dup		( q1 -- q1 q1 )			 		'dup4f'		non-mmx

 4drop  	( q1 q2 -- q1 )			(m,5)		'drop4'		forth
	drop quad cells

 8drop  	( o1 o2 -- o1 )			(m,5)		'drop8'		forth
	drop top eight cells

 8sdrop 	( o1 o2 -- o2 )					'sdrop8'	forth

 8sdrop 	( q1 q2 -- q2 )					'sdrop8f'	non-mmx

 8swap  	( qv1 qv2 -- qv1 qv2 )				'swap8'		forth
	{ 8 nswap }, 8 cells per item swap

 4swap  	( q1 q2 -- q2 q1 )		(x) 		'swap4'		forth
	swap quads
 4swap  	( q1 q2 -- q2 q1 )		 		'swap4f'	non-mmx

 4sdrop 	( q1 q2 -- q2 )					'sdrop4'	forth

 4sdrop 	( q1 q2 -- q2 )					'sdrop4f'	non-mmx

 uqmax   	( uq1 uq2 -- uq3 )		((X))				forth
	ret uq3 := (uq1+uq2+|uq1-uq2|)/2

 uqmin   	( uq1 uq2 -- uq3 )		((X))				forth
	ret uq3 := (uq1+uq2-|uq1-uq2|)/2

 8dup		( n1..n8 -- n1..n8 n1..n8 )	(x)		'dup8'		forth
	duplicate top eight cells

 8dup		( ra1 ra2 -- ra1 r2 r1 r2 )			'dup8f'		non-mmx

 4over  	( q1 q2 -- q1 q2 q1 )		(x) 		'over4'		forth
	duplicate 2nd on stack quad to @tos
	( mmx mode w/ minor timing gain )
 4over  	( q1 q2 -- q1 q2 q1 )		 		'over4f'	non-mmx

 4sover  	( q1 q2 -- q2 q1 q2 )		(x)		'sover4'	forth
	does{ 4swap 4over }

 4sover  	( q1 q2 -- q2 q1 q2 )				'sover4f'	non-mmx
	does{ 4swap 4over }

 4rot   	( q1 q2 q3 -- q2 q3 q1 )	(x)		'rot4'		forth
	roll 3rd quad to @tos

 4rot   	( q1 q2 q3 -- q2 q3 q1 )			'rot4f'		non-mmx
	roll 3rd quad to @tos

 4rotd   	( q1 q2 q3 -- q2 q3 )		(x)		'rot4d'		forth
	fast aequivalent to { 4rot 4drop }.

 4rotd   	( q1 q2 q3 -- q2 q3 )				'rot4df'	non-mmx
	non-mmx aequivalent to { 4rot 4drop }.

 8sover 	( qv1 qv2 -- qv2 qv1 qv2 )	(x+x)		'sover8'	forth
	{ qvswap qvover }, 8 cells per item swap and over

 8sover 	( qv1 qv2 -- qv2 qv1 qv2 )			'sover8f'	non-mmx
	{ qvswap qvover }, 8 cells per item swap and over

 4-rot  	( q1 q2 q3 -- q3 q1 q2 )	(x)		'mrot4'		forth
	reverse roll quad @tos to 3rd

 4-rot  	( q1 q2 q3 -- q2 q3 q1 )	(4)		'mrot4f'	non-mmx
	reverse roll quad @tos to 3rd

 4roll  	( qn .. q1 q0 +n -- .. qn-1 .. q1 q0 qn ) (4)	'roll4'		forth
		( qn .. q1 q0 -n -- .. q0 qn .. q1 )

 8roll  	( on .. o1 o0 +n -- .. on-1 .. o1 o0 on ) (4)	'roll8'		forth
		( on .. o1 o0 -n -- .. o0 on .. o1 )

 8over  	( n1..n8 n9..n16 -- n1..n8 n9..n16 n1..n8 )(x)	'over8'		forth
	copy 2nd @tos eight cells

 8over  	( n1..n8 n9..n16 -- n1..n8 n9..n16 n1..n8 )	'over8f'	non-mmx
	copy 2nd @tos eight cells

 8pick  	( ..on..o1 o0 +n -- ..on..o1 o0 on )	(4)	'pick8'		forth
		( ..on..o1 o0 oo -n -- ..oo..o1 o0 )
	n>0: fetch (+n)-th item to tos. index n = 0 @tos.
	n<0: store @tos item to (-n)-th position, index 0 refers to item to store.

 4pick  	( ..qn..q1 q0 +n -- ..qn..q1 q0 qn )	(4)	'pick4'		forth
		( ..qn..q1 q0 qq -n -- ..qq..q1 q0 )
	n>0: fetch (+n)-th item to tos. index n = 0 @tos.
	n<0: store @tos item to (-n)-th position, index 0 refers to item to store.

 4@		( p -- uq )					'fetch4'	forth
	fetch quad at ptr p

 4!		( q ptr -- )					'store4'	forth
	store quad @nos to address pointed to by @tos

=====================================================================;
 l4qdarith.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4rational.inc>
--------------------------------------------------------------------------


 rational	( -- )				(X)(i)				root
	vocabulary for Rational Numbers opr ('real', 'ranum', 'vulgar numbers').
	
	The "rational" word-set provides basic arithmetic, logical, type conversion 
	and numerical in-/output routines for rational numbers. Basic routines from
		Vulgar Maths Words Version FSL1.1", Forth Scientific Library 
		Algorithm #46, by Gordon Charlton - gordon@charlton.demon.co.uk.
	adapted to 'lib4th' and (much) extended.
	(Find the original FSL text in lib4th source, "./doc/src/vulgar.fth").
	
	'sing' "v", 'double' "dv", 'quad' "qv" refer to a 'ranum' of the rsp size 
	of ea, the numerator and denominator; prefix 'v...' from 'vulgar'.
	
	A 'ranum' in this context is a single or multiple cells pair in the order
		Numerator Denominator -- , denominator @tos (nenner, divisor), 
	which is (almost) always a reduced fraction. The numerator is a signed integer, 
	and the denominator a non-negative integer. Zero is represented by (0,1).
	Numbers too large to be represented are indicated by the special value (0,0),
	which will propagate through a program. Most words in this suite are tolerant
	of the overflow indicator, with the exception of those that convert rational 
	numbers to other numerical data types. These are flagged in the listing.
	
	The data type "rational number" is also referred to by "fractional number", 
	if displayed as an integer and fraction or, by "floating point" number. 
	The term "ranum" will be used for either display type of a rational number.
	
	In the range of improper fractions (1,..) the difference between successive 
	representable 'ranums' increases as the absolute value of the fraction 
	increases; i.e. above |2^(bitsize-2)-1| only integers are representable.
	Range of single cell pairs  'ranums' is thus quite limited, double and quad 
	pairs sizes provided for more accurate ranges and intermediate calculations.
	
	Further, -re- {vsplit} is provided, which separates the fractional and the 
	integral part of a rational fraction. If the loss of precision associated 
	with large numbers is not acceptable vsplit can be used to deal with the 
	fractional component separately, thus maintaining absolute precision.

 hidden 	( -- )				(X)(i)		'rahidden'	rational
	{rational} sub-vocabulary for Rational Numbers, quad format and support.

 cons   	( -- )				(X)(i)		'racons'	rational
	{rational} sub-vocabulary, Rational Numbers' constants.

 float  	( -- )				(X)(i)				ans
	ans FLOATING and FLOATING EXT words, aliased/copied from -re- {rational} voc.
	'float' representation is 'double ranum', common 4-cells operations apply, 
	'double float' by quad cells pairs 'quad ranum' w/ 8-cells basic operations.
	-re- {flt}/{int} for persistent floats/integers numeric input modes.

	
-- constants, by cells pairs e.g. for rational numbers and/or {*/} etc.

 0dv		( -- dv )					'v0dv'		rational cons
	cons double ranum 0

 0qv		( -- dv )					'v0dv'		rational cons
	cons quad ranum (double float) 0

 1dv		( -- dv )					'v1dv'		rational cons
	cons double ranum 1

 1qv		( -- qv )					'v1qv'		rational cons
	cons quad ranum 1

 -1dv		( -- dv )					'vm1dv'		rational cons
	cons double ranum -1

 -1qv		( -- qv )					'vm1dv'		rational cons
	cons quad ranum -1

 2^(1/2)	( -- num den )					'casqr2n2'	rational cons
	1.41421356(2..)	+/- 1,5e-9
 2^(1/12)	( -- num den )					'casqr12n2'	rational cons
	1,059...	+/- 1,0e-9
 3^(1/2)	( -- num den )					'casqr2n3'	rational cons
	1,732050808...	+/- 0,5e-9
 10^(1/2)	( -- num den )					'casqr2n10'	rational cons
	3,162...	+/- 5,7e-9
 bernulli(v)	( n -- v )							rational cons
	1st eleven Bernulli numbers by index 0<n<12 (?, "Bernulli'sche Zahlen")
 c		( -- num den )					'cac'		rational cons
	2,997...	+/- 1,6e-9

 dv.e		( -- dv )					'caed'		rational cons
	2,7182818284(59) +/- 10^-12 (ref. Bronstein)
 dv.e^6	( -- dv )					'cae6d'		rational cons
	e to the power of six, ret dv := 403,42879349
 dv.e^10	( -- dv )					'cae10d'	rational cons
	e to the power of ten, ret dv := 22026,4657948
 euler-c	( -- num den )					'caec'		rational cons
	0,57721566(4901532)...
 euler(v)	( n -- v )							rational cons
	1st seven Euler numbers by index 0<n<8 (?: "Euler'sche Zahlen")
 k(t)		( -- num den )					'cakptp'	rational cons
	1,64676  CORDIC trigonometric correction factor (by 15 iterations)
 k(h)		( -- num den )					'cakphp'	rational cons
	0,8281593  CORDIC hyperbolic correction factor (by 15 iterations)
 lg(2)  	( -- num den )					'calg2'		rational cons
	0,301029995(...)
 lg(e)  	( -- num den )					'calge'		rational cons
	0,434294481(...)
 ln(2)  	( -- num den )					'caln2'		rational cons
	0,69314718(...)
 dv.ln(2)  	( -- dv )					'cdvln2'	rational cons
	0,69314718 +/- 10^11
 ln(10) 	( -- num den )					'caln10'	rational cons
	2,3025850930..
 dv.ln(10) 	( -- dv )					'cdvln10'	rational cons
	2,3025850930.. +/- 10^11
 pi		( -- num den )					'cacpi'		rational cons
	3,1415926536...	+/- 10^-10
 qv.2pi	( -- q2 )					'cqv2pi'	rational cons
	quad ranum cons 2*pi 6,2831853072...	+/- 10^-10 (in range of a sing)
 qv.2/3pi	( -- q2 )					'cqv23pi'	rational cons
	quad ranum cons 2*pi/3 2,09439510240...	+/- 10^-10 (in range of a sing)
 qv.pi/2	( -- q2 )					'cqvpi2'	rational cons
	quad ranum cons pi/2 1,5707963268...	+/- 10^-10 (in range of a sing)
 qv.pi/4	( -- q2 )					'cqvpi4'	rational cons
	quad ranum cons pi/4 0,7853981634...	+/- 10^-10 (in range of a double)
	pi/4 = Sa(n->oo) (-1)^(n+1)/(2n-1); n=1...k|k>>0, after 2 days: 0,785398164328770
 qv.pi/180	( -- q2 )					'cqvpi180'	rational cons
	quad ranum cons pi/180 0,0174532925...	+/- 10^-10 (in range of a double)

 qvrdv  	( -- qv )					'qvmdv'		rational cons
	max quad to {qvround}ding a quad to size of a double ranum.

 vovf		( -- v )							rational cons
	cons (+ve) overflow indicator

 dvovf  	( -- dv )							rational cons
	cons (+ve) overflow indicator.

 qvovf  	( -- qv )							rational cons
	cons (+ve) overflow indicator.

	
-- Literals

	

-- text input

 >double	( p u -- d n tf | 0. 0 ff )	(e)				rational
	translate string at p of length u to double number d in the current base
	and return n = @dpl and tf if conversion successful, else all zero and ff.
	fractional marker and, number prefices for sign and radix as w/ -re- {a-base}.
	stg may contain a base exponent mark, either the char corresponding to 
	the rsp. @base figure, e.g. as converted w/ {h>a}, or, at decimal base
	the char "e" or "E". the fetched rational number will then be multiplied 
	by @base raised to the power of |exp|<127, valid exponent -9 < exp < 10.
	tf if conversion successful or, stg(p,u) of zero length or fraction mark, only.
	ff indicates that an unvalid character was present in the string, in which case 
	d and n are the result of leading valid characters, if existent, else zero.
	NOTE: returns "TRUE" flag after SUCCESS, in contrary to any other conventional 
	      numeric conversion forth words - which may be a subject to change!
	(e: eflags reflect flag value, ecx:=p, edx:=u

 >quad  	( p u -- q n ff | q0 0 tf )					rational hidden
	fetch quad int or double ranum from stg(p,u); input modifiers apply as w/ {[number]}
	ret n := radix of current base and false if conversion successful, else true flag.
	max convertible figure e.g. 19 decimal, fractional+integral digits. -re- {>double}.
	valid decimal exponent in range -14 < exp < 19.

 >FLOAT 	( p u -- dv f )					'tofloat'	float
	convert stg(p,u) to a single 'float', i.e. double ranum.
	an empty stg, or all blanks, resulting to ovf indicator.
	valid, optional exponent in range -14 < exp < 19. -re- {>double}

 >DFLOAT 	( p u -- qv f )					'todfloat'	float
	convert stg(p,u) to a double 'float', i.e. quad ranum.
	an empty stg, or all blanks, resulting to ovf indicator.
	valid, optional exponent in range -21 < exp < 22. -re- {>double}

 dv>udv?	( dv -- +dv f)					'dv2udvq'	rational hidden
	return absolute value of signed double rational no. tf if dv was negative. 
	A double ranum is represented on the stack as sign*d.numerator +d.denominator.

 v>dv		( v1 -- v2 )					'v2dv'		rational
	expand v1 to double cells size.

-- Output

 #digits 	( -- n )			(kv)				forth
	n is the maximal number of digits to be displayed in the numerator or
	denominator of a rational number, when displayed in fractional format.

 PRECISION	( f1 -- f2 )			((kv))		'fprec'		ans float
	no. of displayable fractional digits, dpans EXT 12.6.2.2035
	by kernel value {#fplaces}

 #fplaces 	( -- n )			(kv)		'fprec'		rational
	returns the maximal number of fractional digits to be included in the 
	f.p. numeric output string by #vf. reads the kernel-value {#prec}.

 SET-PRECISION  ( n -- )							ans float
	set no. of displayable f.p. mode fractional digits, dpans EXT 12.6.2.2035

 #fround	( -- n )			(kv)		'hfround'	rational
	the number of f.p. fractional digits, rounded towards zero by -re- {dvfround}.

 #n!v  	( -- n )			(kv)		'snfv'		rational hidden
	max integer + 1 for which a vsing factorial can be calculated w/o loss praecision.

 #dp		( -- c )			(kv)		'vpoint'	forth
	char c to insert as the fraction marker in floating point format, dft ",".

 truncation	( -- n )			(kv)		'vtrunc'	rational
	returns TRUE if trailing zeroes will be truncated when displaying 
	a rational number in floating point format.

 fdelim  	( -- c )					'fdelim'	rational hidden
	ret the char to insert as the delimiter between integral and fractional 
	part in fractional format. reads kernel-value {#fd}.

 >ch		( p u c -- n )					'gtch'		rational hidden
	search stg(p,u) for character c. If it is present then n is the position of the
	first occurrence of ch in the string. If it is not present then n is equal to u.

 -zeroes	( p u1 -- p u2 )				'mzeroes'	rational
	the string at addr of length n1 is stripped of trailing "0"s, returning a
	string of length n2. If there is no point in the string no stripping takes
	place. At least one character will remain after the point.

 digits>	( -- u )					'vdigitsgt'	rational hidden
	u is the largest number that can be represented in the current base by 
	not more than {digits} number of digits.
	to preventing very odd values {digits} will be truncated to less than 256
	which, if {pad-size} not set to a value below default will always be safe.
	

-- double size rational numbers

	
-- defining 

 dvliteral	(C: dv -- ) (X: -- dv )						rational
	-re- 4literal

 dvconstant	ccc(C: dv -- ) (X: -- dv )					rational
	-re- {4constant}

 dvinteger	ccc(C: dv -- ) (X: -- dv )					rational
	double ranum modifiable constant (two cells L4 variant of a {value}).
	synonym to -re- {4integer}.

 dvvariable	ccc(C: -- ) (X: -- p )						rational
	-re- {4variable}

	
-- Memory

 dv@		( p -- dv ) 					'dvfetch'	rational
	fetch dv from memory at p. -re- {4@}.

 dv!		( dv p -- ) 					'dvstore'	rational
	store dv to memory at p. -re- {4!}.

	
-- Stacks

 dv-rot  	( dv1 dv2 dv3 -- dv3 dv1 dv2 )			'dvmrot'	rational
	-re- {4-rot}
 dvdrop  	( dv1 -- dv1 dv1 )						rational
	-re- {4drop}
 dvdup  	( dv1 -- dv1 dv1 )						rational
	-re- {4dup}
 dv2dup  	( dv1 dv2 -- dv1 dv2 dv1 dv2 )					rational
	-re- {8dup}
 dvover  	( dv1 dv2 -- dv1 dv2 dv1 )					rational
	-re- {4over}
 dvpick  	( ... n -- ... dvn )						rational
	-re- {4pick}
 dvrot  	( dv1 dv2 dv3 -- dv2 dv3 dv1 )					rational
	-re- {4rot}
 dvroll  	( ... n -- ... dvn )						rational
	-re- {4roll}
 dvswap  	( dv1 dv2 -- dv2 dv1 )						rational
	-re- {4swap}
	quad cells opr. apply to double rational numbers.

 dvdepth	( -- n )							rational
	aequivalent to the number of double ranums in data-stack.

	
-- arithmetics

 dvoverflow	( dv -- f )							rational
	tf if dv was the overflow indicator

 dvround 	( dv1 +dn -- dv2 )						rational
	returns an approximation to the rational number dv1 such that neither  
	the numerator nor the denominator of its fractional part exceeds the 
	+ve integer dn.

 dvfround 	( dv1 -- dv2 )			(4)				rational
	returns an approximation to the rational number dv1 such that the fractional 
	part rounded to {#fround} digits. simple rounding algorithm which increments
	last digit by one if next would be greater or equal to 0,5 * rounding factor:
	{ dvsplit base@ #fround u^ d>dv 4sover dv* df 0,5 dv+ dv>floor dvswap dv/ dv+ }
	noop if (kernel-)value {#fround} < 0.

 dvcmp  	( dv1 dv2 -- dv1 dv2 f )	(e)				rational
	leave signum of ranum doubles subtraction.
	(e: eflags reflect signum

 dvsgn  	( dv -- n )			(e)				rational
	ret sing signum of dv.
	(e: eflags reflect signum

 dvmin  	( dv1 dv2 -- dv3 )						rational
	ret dv3 the smaller of dv1,dv2.

 dvmax  	( dv1 dv2 -- dv3 )						rational
	ret dv3 the greater of dv1,dv2.

 #dv		( dv -- 0.0 )					'sharpdv'	rational
	append signed double ranum dv to the numeric output string:
	  If dv is zero append "0".
	  If dv has an integral component but no fractional component, append that
	        number.
	  If dv has a fractional component but no integral component append "a/b"
	        where a is the numerator, and b the denominator.
	  If dv has both a an integral and a fractional component append "a b/c"
	        where a is the integral component, b the numerator and c the
	        denominator of the fractional component. There is a delimiting char
	        between the integral and fractional components,-re- {#fd}, {fdelim}.
	Sign applies to the entire figure; conversion according to current @BASE.
	Leave double zero, after conversion.

 #dvf		( +dv -- 0 0 )					'sharpdvf'	rational
	append the positive ranum +dv to the numeric output string as a	floating 
	point number w/ the current value of {base}. That is to say, the integral 
	component, followed by a marker char -re- {#dp}, the "decimal point", 
	followed by as many digits as specified by -re- {fplaces} w/ no rounding. 
	Returns 0 0 for consistency with other numeric strings conversion words. 

 <#dv#> 	( dv -- p u )					'ltdvgt'	rational
	Signed convert double ranum to fractional format stg.
	Returns the string(p,u) representing the rational number dv. The string 
	is as described in -re- {#dv}, but will have a preceding minus sign if 
	dv was negative. If dv is the overflow indicator, returns stg "Overflow".

 <#dvf#>	( dv -- p u )					'ltdvfgt'	rational
	-re- {#dvf}, signed convert -re- {dvfround}ed double ranum to floating pt stg.

 df.j		( dv n1 n2 -- )					'dvdotfj'	rational
	display double ranum dv according to the rules described in -re- {#dvf},
	padded w/ up to n1 leading and up to n2 trailing blanks, none if -ve.

 df.		( dv -- )					'dvdotf'	rational
	display a rational number in floating point format as w/ -re- {df.j}
	but without left or right justification, and with one trailing space.

 dv.j		( dv n1 n2)					'dvdotj'	rational
	display rational number dv in fractional format, as described in <#dv#>,
	padded w/ up to n1 leading and, up to n2 trailing spaces, none if -ve.

 dv.		( dv -- )					'dvdot'		rational
	display a ranum in fractional format as described in dv.j but, 
	w/o left or right justification and, with one trailing space.

 dvsimplify	( dv1 +dn -- dv2 )		(4)				rational
	returns approximation to the rational number dv1 such that neither the
	numerator nor the denominator of the fractional component exceeds dn.

 dvreduce	( dv -- dv)			(4)				rational
	normalises double ranum by greatest common divisor of numerator and denominator.

 s>dv		( n -- dv )					's2dv'		rational
	signed promote sing integer to double ranum equivalent. n --> n s->d 1. =: dv.

 d>dv		( dn -- dv )					'd2dv'		rational
	promote double integer to double ranum equivalent. dn --> dn 1. =: dv.

 dv>d		( dv -- d )					'dv2d'		rational
	return the floored, integral component of ranum dv as signed integer d.

 dv>s  	( dv -- n )					'dv2n'		rational
	return the m.s. signed integral component of ranum dv as signed single integer n.

 dv>dn  	( dv -- d )					'dv2dn'		rational
	return the m.s. signed integral component of ranum dv as signed integer d.

 dvsplit 	( dv1 -- dv2 dv3 )						rational
	floored integral dv2 and (non-negative) fractional component dv3 of ranum dv1. 
	w/ Floored rounding. word is tolerant of the overflow condition.

 dvfrac  	( dv1 -- dv2 )							rational
	return the fractional component of dv1 as non-negative dv2.
	w/ Floored rounding. word is tolerant of the overflow condition.
 dv>floor	( dv1 -- dv2 )					'dv2floor'	rational
	double ranum to floored integral value

 dv>int	( dv1 -- dv2 )					'dv2int'	rational
	round float to nearest integral value

 FROUND	( dv1 -- dv2 )							float
	round float to nearest integral value

 1/dv		( dv1 -- dv2 )					'dvrecip'	rational
	ret dv2 the reciprocal of dv1. 

 dv+-		( dv1 n -- dv2 )				'dvpm'		rational
	negate dv1 if n < 0

 dvnegate	( dv -- dv )			(m,10)(e)			rational
	negate dv1
	(e: eflags reflect result of numerator negation

 dvabs  	( dv -- |dv| )							rational
	negate dv if -ve

 dv0=		( dv -- f )			(e)		'dvzeq'		rational
	tf if dv is zero
	(e: Z if dv=0, ecx=sign cell

 dv~		( dv1 dv2 -- f )				'dvaeq'		rational
	tf if dv1, dv2 approximately (within dv accuracy) equal or, if |dv1-dv2| = ovf.

 dv=		( dv1 dv2 -- f )				'dveq'		rational
	tf if d1, dv2 exactly equal.

 F~		( f1 f2 f3 -- flg )				'faeq'		float
	should check for approximate equality according to dpans, 12.6.2.1640.
	apparently, w/ f1=test and f2=expected exact result:
		+ve: f3=abs. tolerance, f2-f3 < f1 < f2+f3.
		-ve: f3=factor of how much f1 may deviate from f2, 
		     (f1-f2)*|f3| < f2 < (f1+f2)*|f3|	-?-
	-re- {dv~} for an alternative approach.
 --
				       |r1-r2|
	r3>0: |r1-r2|<r3;	r3<0: --------- < |r3| = |r1-r2|<|r3*(|r1|+|r2|)|
				      |r1|+|r2|
 --
	(I do not understand a word of that silly dpans94 description,
	(section 12.6.2.1640; thus just providing F~, left un-tested, 

 dv<		( dv1 dv2 -- f )		(4)		'dvlt'		rational
	tf if dv1 signed smaller than dv2.

 dv>		( dv1 dv2 -- f )		(4)		'dvgt'		rational
	tf if dv1 signed greater than dv2.

 dv0<		( dv -- f )			(m,15)(e)	'dvzlt'		rational
	tf if dv is -ve.
	(e: S reflects result

 dv2*		( dv1 -- dv2 )					'dv2mul'	rational
	multiply dv1 by 2.

 dv2/		( dv1 -- dv2 )					'dv2div'	rational
	divide dv1 by 2.

 dvm*		( dv dv -- qv)					'dvmmul'	rational
	multiply two double ranums, generating quad result.

 dvm/		( dv1 v2 -- dv3 )				'dvmby'		rational
	divide double dv2 by sing v2 giving double quotient dv3.

 dv/		( dv1 dv2 -- dv3 )				'dvby'		rational
	divide dv1 by dv2 giving quotient dv3.
	div-0: ret +/- max or, ret 1 if dv1=0.

 dv*		( dv dv -- dv)					'dvmul'		rational
	multiply two doubles.

 dv1+		( dv1 -- dv2 )					'dvonep'	rational
	add 1 to dv1

 dv1-		( dv1 -- dv2 )					'dvonem'	rational
	subtract 1 from dv1

 dv-		( dv1 dv2 -- dv3 )				'dvsub'		rational
	subtract dv2 from dv1.

 dv+		( dv1 dv2 -- dv3 )				'dvplus'	rational
	add two double ranums; fast (i.e. less slow), trivial case if den1 = den2.

	
	
-- quad (and intermediate) size rational numbers for doubles support
	

 qv>dv  	( qv -- dv )					'qv2dv'		rational
	returns double which most closely approximates quad ranum.
	ret ovf indicator (0,0) if qv doesn't fit into dv.

 qvreduce	( qv -- qv)			(4)				rational hidden
	reduce quad ranum by greatest common divisor of numerator and denominator.

 dv>uqv?	( dv -- +qv f)					'dv2uqvq'	rational hidden
	return absolute quad value of signed double rational no. tf if dv was negative. 
	A ranum is represented on data-stack as ( sign*|numerator| |denominator| ).

	
-- Memory, quad ranum

 qvinteger	ccc( qv -- )(X: -- qv )						rational hidden
	quad ranum integer; modifiable constant (four cells L4 variant of a {value}).

 qv@		( p -- dv ) 					'qvfetch'	rational hidden
	fetch qv from memory at p.

 qv!		( dv p -- ) 					'qvstore'	rational hidden
	store qv to memory at p.

 FLOAT+	( p1 -- p2 )			(m,3)		'floatp'	ans float
	add size of a single float (16) to ptr p1, dpans 12.6.1.1555

 DFLOAT+	( p1 -- p2 )			(m,3)		'dfloatp'	ans float
	add size of a double float (32) to ptr p1

	
-- Stacks, quad ranum

 qvrot	( qv1 qv2 qv3 -- qv2 qv3 qv1 )	(x)(4)				rational hidden
	roll 3rd @tos to tos.

 qv-rot 	( qv1 qv2 qv3 -- qv3 qv1 qv2 )	(x)(4)		'qvmrot'	rational hidden
	roll @tos to 3rd @tos.

 qv2dup  	( qv1 qv2 -- qv1 qv2 qv1 qv2 )					rational hidden
	duplicate top two quad ranums

 qvpick 	( qvn .. n -- .. qvn )		8pick				rational hidden
	pick a quad ranum, i.e. 8 cells per item +/- pick
 qvroll 	( qvn .. qv1 n -- .. qv1 qvn )	8roll				rational hidden
	roll a quad ranum, i.e. 8 cells per item +/- roll
 qvswap 	( qv1 qv2 -- qv1 qv2 )		8swap				rational hidden
	{ 8 nswap }, swap 8 cells items
 qvover 	( qv1 qv2 -- qv2 qv1 qv2 )	8over				rational hidden
	pick @nos to tos
 qvdup  	( qv -- qv qv )			8dup				rational hidden
	duplicate quad ranum @tos
 qvdrop  	( qv -- )			8drop				rational hidden
	discard top quad ranum
 qvnegate	( qv1 -- qv2 )			nos-qnegate			rational hidden
	negate quad ranum qv1
 qvsover	( qv1 qv2 -- qv2 qv1 qv2 )	8sover				rational hidden
	{ qvswap qvover ), 8 cells per item swap and over
	NOTE: qvnegate, qvsover, qvdup, etc. are synonymous to the rsp. operations 
	for eight-cells items. a quad ranum is a pair of quad integers, thus any 
	quad or eight-cells integer stack-opr. apply.
	re the rsp. aliased word for some further explanation of how to operate.
	(all of which involve the mmx registers if L4 was compiled w/ "__MMX" def'd)

 v>qv		( v1 -- qv2 )					'v2qv'		rational
	signed expand v1 to double cells size.

 dv>qv  	( dv1 -- qv2 )					'dv2qv'		rational
	signed expand dv1 to quad qv2.

 dv>uqv  	( dv1 -- qv2 )					'dv2uqv'	rational hidden
	unsigned expand dv1 to quad qv2.

 s>qv		( n -- qv )					's2qv'		rational
	signed convert single integer to quad ranum

 d>qv		( dn -- qv )					'd2qv'		rational hidden
	signed convert double integer to quad ranum

 q>qv		( qn -- qv )					'q2qv'		rational hidden
	signed convert quad integer to quad ranum

 n>qv		( n.N -- qv )					'n2qv'		rational hidden
	truncate/modify/signed extend counted integer to quad ranum.

 qv>fq  	( qv -- q )			(4)		'qv2q'		rational hidden
	ret floored signed quad integral part of quad ranum.

 qv>s  	( qv -- n )					'dv2n'		rational hidden
	return the m.s. signed integral component of ranum qv as single integer n.

 qv>d  	( qv -- d )					'dv2dn'		rational hidden
	return the m.s. signed integral component of ranum qv as double integer d.

 qv>q  	( qv -- q )					'dv2dn'		rational hidden
	return the signed integral component of ranum qv as quad integer.

 qvsplit 	( qv1 -- qv2 qv3 )						rational hidden
	floored integral qv2 and (non-negative) fractional qv3 component of qv1. 
	w/ Floored rounding, i.e. v1 = v2 + v3 and assuming +ve v3 is always valid. 

 qvfrac 	( qv1 -- qv2 )			(4)		'qvfrac'	rational hidden
	ret +ve fractional part of qv1, remainder of floored div'n.

 qvabs  	( qv1 -- qv2 )							rational hidden
	negate qv1 if -ve

 qv>uqv?	( qv1 -- qv2 f)					'qv2uqvq'	rational hidden
	return absolute value of signed quad ranum. tf if qv1 was negative. 

 qvdround	( qv1 -- qv2 )			(X)				rational hidden
	returns approximation to qv1 such that qv2 fits into double ranum range.

 qvround 	( qv1 +qn -- qv2 )		(X)				rational hidden
	returns an approximation to the rational number qv1 such that neither  
	the numerator nor the denominator of its fractional part exceeds the 
	positive integer +qn. abort w/ addressing mode error if -ve den of qv1.

 qvsimplify	( qv1 +qn -- qv2 )		(4)				rational hidden
	returns approximation to the rational number qv1 such that neither the
	numerator nor the denominator of the fractional component exceeds qn.

 qvsqrt 	( qv1 -- qv2 )							rational hidden
	qv2 := sgn(qv1) * square root of quad ranum |qv1|.
	for instance, accurate within 19 integral plus fractional decimal digits.
	apply 'bignum' words to num/den separately for unlimited, higher range and 
	praecision:
		scale by common factor as great as possible w/o overflowing into 
		sign bit of denumerator, get square roots of num and den, reduce.

 qv2*		( qv1 -- qv2 )					'qv2mul'	rational hidden
	fast multiplication by two.

 qv2/  	( uqv1 -- qv2 )					'qv2div'	rational hidden
	unsigned divide quad ranum by two.

 1/qv  	( qv1 -- qv2 )					'qvrecip'	rational hidden
	reciprocal

 qv/		( qv1 qv2 -- qv3 )				'qvdiv'		rational hidden
	divide quad ranums

 qv*		( qv1 qv2 -- qv3 )				'qvmul'		rational hidden
	multiply quad ranums

 qv-		( qv1 qv2 -- qv3 )				'qvsub'		rational hidden
	subtract quad ranum qv2 from qv1.

 qv+		( qv1 qv2 -- qv3 )				'qvplus'	rational hidden
	add quad ranums

 qv1+		( qv1 -- qv2 )					'qvonep'	rational hidden
	increment qv1 by one

 qv1-		( qv1 -- qv2 )					'qvonem'	rational hidden
	decrement qv1 by one

 qvcmp  	( qv1 qv2 -- qv1 qv2 f )	(e)				rational hidden
	leave signum of ranum doubles subtraction.
	(e: eflags reflect signum

 qvsgn  	( qv -- n )			(e)				rational hidden
	ret sing signum of qv.
	(e: eflags reflect signum

 ?qv0=  	( qv -- qv f )			(e)		'qqvzeq'	rational hidden
	tf if qv is zero or overflow indicator.
	use additional test w/ {?q0=} to determine whether ovf(tf) or valid zero(ff) value.
	(e: Z if qv=0 and tf, else NZ; edx:=sign cell

 qv=		( qv1 qv2 -- f )		(e)		'qveq'		rational hidden
	tf if dv1, qv2 (within qv accuracy) equal or overflow.
	(e: Z if qv=0 and tf

 qv~		( qv1 qv2 -- f )		(e)		'qvaeq'		rational hidden
	tf if dv1, qv2 approximately equal or, overflow condition met.
	(e: Z if qv=0 or ovf, and tf

 -qvround	( qv1 -- qv2 )					'mqvround'	rational hidden
	round quad ranum if numerator or denumerator out of range for double arithmetics
	normalize, i.e. reduce the fraction, otherwise.

 dv^s   	( dv1 +n -- dv2 )				'dvpovs'	rational
	raise dv1 to the power of non-negative single integer n. 
	dv2 := ovf if n < 0 or result out of range.

 qv^s   	( qv1 +n -- qv2 )				'qvpovs'	rational hidden
	raise qv1 to the power of non-negative single integer n. 
	qv2 := ovf if n < 0 or result out of range.

 s>dvfactorial	( n -- dv )					's2dvfac'	rational
	dv := n!, -1<n<21; dv := 0 if not in range of a double ranum.
	(quad: n -- { s>nfactorial dup 5 < if n->q else ndrop 0qv endif } -- qv )

	
 -- irrationale zahlen, transzendente fu
	(ref to source texts & formulae in "l4rational.inc")
	

 dvsqrt  	( dv1 -- dv2 )							rational
	dv2 := square root of double ranum |dv1| * sgn(dv1).
	accuracy ok w/ less than 10 decimal digits, -re- {qvsqrt} for higher praecision.

 lg(dv) 	( dv1 -- dv2 )			(4)		'flog'		rational
	decimal logarithm of dv1, by dv2 := ln(dv1)/ln(10)

 FLNP1	( f1 -- f2 )			(4)				float
	f2 := ln (f1+1) dpans EXT 12.6.2.1554 -	not overly useful:
	ln(dv) is very accurate, thus FLNP1 exactly equal to the rsp result from FLN.

 ln(dv)  	( dv1 -- dv2 )					'lndv'		rational
	dv2 := ln dv1; dv1 > 0, otherwise ret overflow indicator, -re- {ln(qv)}.

 ln(qv)  	( qv1 -- qv2 )					'lnqv'		rational hidden
	qv2 := ln qv1; qv1 > 0, otherwise ret overflow indicator.
	accurate to 12(+) fractional+integral decimal digits in range 0<qv<10^11.
	(bj) calculated w/ infinite product to highest possible accuracy within 
	range of quad ranum; terminated at ovf or, x^(1/2^n) == x^(1/2^(n-1)).
	-:-
		            _oo_       2
		ln x = (x-1)|  | -------------, 0<x<oo
			     n=1 x^(1/(2^n))+1

 FEXPM1	( f1 -- f2 )							float
	f2 := e^(f1)-1, dpans EXT 12.6.2.1516 - {FEXP} always more accurate (and faster)

 e^dv		( dv1 -- dv2 )					'epowdv'	rational
	returns approximation to e^dv1, -re- {e^qv}.
	tested in range -43,6 < dv1 < 43,6, accurate within min. +/- 10^-10.

 e^qv		( qv1 -- qv2 )					'epowqv'	rational hidden
	returns approximation to e^qv1, tested in range  -43,6 < qv1 < 43,6.
	max. deviation +/- 10^-9, best results with |qv|<6, deviation < 10^-10.
	-:-
			-- x^n
		e^x   = >  ---, x >= 0
			--  n!
	numeric accuracy limited by the last term x/n in
		x^n   x^(n-1)    x
		--- = ------- * ---
		 n!    (n-1)!    n
	which terminates the series if x/n cannot be resolved to =/= 0 within 
	range of +ve quad ranums and, by max. four cells range factorial, n=33.

 10^dv  	( dv1 -- dv2 )			(4)		'powdv10'	rational
	raise ten to the power of dv1.

 dv^    	( +dv1 dv2 -- dv3 )		(4)		'dvpowdv'	rational
	dv3 := +ve float or -ve integral dv1 to the power of dv2; dv3 := 1 if dv1 = 0.
	ambiguous result if -ve dv1 is not an integer, -re- {re,im(v)}.
	-re- {qv^}, a^x = e^(x ln a); a=0 | a^x := 1

 qv^    	( +qv1 qv2 -- qv3 )		(4)		'qvpowdv'	rational hidden
	qv3 := +ve float or -ve integer qv1 to the power of qv2; qv3 := 1 if qv1 = 0.
	exact result within up to 12 decimal digits, integer + fractional part.
	for -ve dv1 get sign of real part and imaginary unit w/ -re- {re,im(v)}, then
	procede w/ abs(qv1), apply 're' value and use sign of 'im' as appropriate.
	currently, {re,im(v)} n.i, ambiguous result if -ve dv1 is not an integer.
	-:-
		a^x = e^(x ln a); a=0 | a^x := 1

 re,im(^)	( dv1 dv2 -- |dv1| dv2 n1 n2 )			'reimp'		reational
	n.i.
	ret |dv1|, n1 sign of dv1^dv2 and n2 = j, for imaginary result of -re- {^dv}.
	-:-
	re Htte I pg 61:
		             2k pi         2k pi
		1^(-n) =cos ------ + j sin ----- = e^(2k pi j/n); k=0,...,n-1
		               n             n    
		             pi(2k+1)         pi(2k+1)
		-1^(-n)=cos -------- + j sin --------; k=0,...,n-1
		                n                n    

 deg>rad	( dv1|f1 -- dv2|f2 )				'deg2rad'	rational ans float
	convert to radians.

 rad>deg	( dv1|f1 -- dv2|f2 )				'rad2deg'	rational ans float
	convert to sexagesimal degrees.

 tg(dv)	( dv1 -- dv2 )			(4)		'tgdv'		rational
	tangens, by tg(x) = sin(x)/cos(x)

 tg(qv)	( qv1 -- qv2 )			(4)		'tgqv'		rational hidden
	tangens, by tg(x) = sin(x)/cos(x)

 sincos(dv)	( dv1 -- dv2 dv3 )		(4)		'sincosdv'	rational
	dv2 := sin(dv1), dv3 := cos(dv1)

 sincos(qv)	( qv1 -- qv2 qv3 )		(4)		'sincosqv'	rational hidden
	qv2 := sin(qv1), qv3 := cos(qv1)

 sin(dv)	( dv1 -- dv2 )			(4)		'sindv'		rational
	sinus, -re- {sin(qv)}.

 cos(dv)	( dv1 -- dv2 )			(4)		'cosdv'		rational
	cosinus, -re- {cos(qv)}.

 sin(qv)	( qv1 -- qv2 )			(4)		'sinqv'		rational hidden
	ret qv2 sinus of qv1 in rad, by sin(x)=cos(x-pi/2).

 cos(qv)	( qv1 -- qv2 )					'cosqv'		rational hidden
	ret qv2 cosinus of qv1 in rad.
	        --       x^2n          x^2n     x^(2n-1)     x^2
	cos x = > (-1)^n -----; x(n) = ----- = --------- * ---------; n=1..33(or ovf)
	        --       (2n)!         (2n!)   (2(n-1))!   2n*(2n-1)
	numeric accuracy limited by the last term, x(n), which terminates the series 
	if x^2n/(2n)! cannot be resolved to =/= 0 within the range of +ve quad ranum;
	and by the max. factorial representable w/ four cells, n! = 33!.

 FATAN2 	( f1 f2 -- f3 )			(4)				ans float
	f1/f2 = tg f3, i.e. f3 := arc tg (f1/f2), dpans EXT 12.6.2.1489 
	ret pi/4 if f1=f2=0

 atg(dv)	( dv1 -- dv2 )					'atgdv'		rational
	ret dv2 arcus tangens of dv1 in rad. -re- {atg(qv)}.

 atg(qv)	( qv1 -- qv2 )					'atgqv'		rational hidden
	ret qv2 arcus tangens of qv1 in rad.
	         pi   --            m^n       x-1
	atg x = --- + >  (-1)^(n+1) ----, m = ---; x=0,x>0; (Htte I)
	         4    --            2n-1      x+1
	numeric accuracy limited by the last term, which terminates the series
	if either the n-th summand is zero within accuracy of a quad ranum or, 
	the running index excedes the (arbitrarily chosen) maximum of n = 255.

 asin(dv)	( dv1 -- dv2 )			(4)		'asindv'	rational
 fasin  	( dv1 -- dv2 )							ans float
                               x
	arc sin x = arc tg -------------
	                   (1-x^2)^(1/2)

 acos(dv)	( dv1 -- dv2 )			(4)		'acosdv'	rational
 facos  	( f1 -- f2 )							ans float
                         sqrt(1-x^2)
	arc cos x = arc tg -----------
	                       x
	

 -- hyperbelfunktionen
	

 FSINH	( f1 -- f2 )							ans float
	hyperbelsinus, dpans EXT 12.6.2.1617
	         e^x - e^(-x)   1          1 
	sinh x = ------------ = - ( e^x - --- )
	              2         2         e^x  

 FCOSH	( f1 -- f2 )			(4)				ans float
	hyperbelcosinus dpans94 EXT 12.6.2.1494
	                 1            1 
	f2 := cosh f1 =  - ( e^f1 + ---- )
	                 2          e^f1  

 FACOSH	( f1 -- f2 )			(4)				ans float
	area cosh, f2:=ln(f1-sqrt(f1^2-1)), dpans EXT 12.6.2.1477
	                sqrt(x^2-1)
	arcosh = artanh ----------- = ln(x-sqrt(x^2-1)); |x| > 1
	                     x

 FASINH	( f1 -- f2 )			(4)				ans float
	area sinh, dpans EXT 12.6.2.1487 
	                      x 
	 arsinh = artanh -----------
	                 sqrt(x^2+1)

 FATANH	( f1 -- f2 )			(4)				ans float
	area tanh, dpans EXT 12.6.2.1491 
	           1      1+x
	artanh x = - ln ( --- ), |x| < 1
	           2      1-x

 DFATANH	( df1 -- df2 )			(4)				ans float
	area tanh, dpans EXT 12.6.2.1491 
	           1      1+x
	artanh x = - ln ( --- ), |x| < 1
	           2      1-x

 FTANH	( f1 -- f2 )			(4)				ans float
	hyperbeltangens, dpans EXT 12.6.2.1626 
	         e^x - e^(-x)   e^2x-1
	tanh x = ------------ = ------
	         e^x + e^(-x)   e^2x+1

 dv>ieee 	( f1 -- dn )					'f2ieee'	rational
 F>IEEE 	( f1 -- dn )					'f2ieee'	ans float
	convert floating pt. (double ranum) to IEEE 754 normalized 'double real' format.
	simple rounding method, increment significand by one if bit next to l.s.b set.
	f1 = +/- infinity represented by num=0 and den=0 or $80..00 (sign bit set), rsp.

 ieee>dv 	( dn -- f1 )					'ieee2f'	rational
 IEEE>F 	( dn -- f1 )					'ieee2f'	ans float
	convert IEEE 754 normalized 'double real' to floating pt. (double ranum) format.
	valid f1 within range of a double ranum, overflow indicator otherwise.
	"negative zero" as (00..00/$80...00) which propagates zero to any other opr.
	any "nan" patterns return the overflow indicator (00/00).
	"signed infinity" returns +/- maximum.

	
 -- quad numeric output
	

 qv.		( qv -- )					'qvdot'		rational hidden
	display quad ranum in fractional format (auxilary word, not error free)

 qf.		( qv -- )					'qfdot'		rational hidden
	display quad ranum in floating pt format (auxilary word, not error free).

 qf.j		( qv n1 n2 -- )					'qfdotj'	rational hidden
	l/r justified display quad ranum in floating pt format (auxilary word).

 df#.		( dv -- )					'dfdecdot'	rational
	display dv in f.p. format at decimal base

 qf#.		( qv -- )					'dfdecdot'	rational hidden
	display qv in f.p. format at decimal base

 REPRESENT	( f1 p u -- n flg1 flg2 | xx xx 0 )		'frepresent'	rational ans float
	decode rational number, dpans 12.6.1.2143:
	sto characters representation of f1, integral and #fplaces length fractional 
	parts w/o trailing zeroes, w/ implied fractions' marker after 1st character 
	plus n places, to buffer(p,u), leave base-10 exponent n, 
	flg1 := tf if f1 <0, else 0 and, flg2 := tf for a valid result, 0 otherwise.
	NOTE: n is aequivalent to @dpl by numeric input and, in contrary to the 
	dpans description of REPRESENT, conversion follows current @base setting.
	buffer(p,u) size should be at least 4 chars, ret false flg2, otherwise.
	ambiguos condition if f1 is overflow indicator and p = u = 0: flg2 := 1.

	
 -- program flow by double ranum, FOR/NEXT loop
	

 (for)  	( f1 -- )(R: -- f1 f2 f3 )			'pforp'		novoc
	runtime introducing a FOR [ FROM ] [ STEP ] ... NEXT loop
	set initial looping range = limit = f1 (item type of 'double ranum').
	pushes loop limit dv1 to the return-stack, plus defaults of
		start = initial loop index = f3 := 0, step = f2 := 1.
	data on returnstack in little endian order, suitable to F@, F! wrt RP@.
	-re- {@NX} for orderly access to any levels loop ctrl. data structures.

 (from) 	( dv -- )(R: dv1 dv2 dv3 -- dv1 d2 dv3' )	'pfromp'	novoc
	modifies loop start dv3 (initial lop index) in returnstack to dv from data-stack.
	loop limit remains unchanged, -re- {(+from)}.

 (+from) 	( dv -- )(R: dv1 dv2 dv3 -- dv1' d2 dv3' )(X)	'ppfromp'	novoc
	modifies loop start dv3 := dv and limit dv1 := dv3+dv from data-stack; i.e.
	looping range incremented by dv, from pre-set start to by dv displaced limit.

 (step) 	( dv -- )(R: dv1 dv2 dv3 -- dv1 d2' dv3 )(X)	'pstepp'	novoc
	modifies loop stepping dv2 in returnstack to dv from data-stack.
	exchanges limit and initial index if dv -ve.

 (next) 	( -- )(R: dv1 dv2 dv3 -- ) 	(X)		'pnextp'	novoc
	terminates a FOR [ FROM ] [ STEP ] ... NEXT loop

 LIM		( -- f1 )			(X)		'flim'		rational ans float
	get innermost FOR-loop limit.

 END		( -- )				(m,)		'fend'		rational ans float
	leave innermost FOR-loop at next xec of NEXT,
	{END} executes like f.i.g-style {leave}, leaving the loop at next NEXT.
	(forced termination by storeing the overflow indicator to STP value)

 !INC		( f1 -- )(R: dv1 dv2 dv3 -- dv1 d2 f1 )		'sinc'		rational ans float
	store f1 from data-stack to innermost FOR-loop increment

 INC  	( -- f1 )			(i)(X)		'fstep'		rational ans float
	get innermost FOR-loop increment

 IDX		( -- f1 )(R: dv1 dv2 dv3 -- dv1 d2 f1 )	(X)	'fidx'		rational ans float
	push innermost FOR-loop index dv1 to data-stack, 
	loop index in a { FOR .. NEXT } loop.

 !IDX		( f1 -- )(R: dv1 dv2 dv3 -- dv1 d2 f1 )		'sidx'		rational ans float
	store f1 from data-stack to innermost FOR-loop index
	loop index in a { FOR .. IDX .. NEXT } loop.

 @NX		( n1 -- p )					'fnx'		rational ans float
	get ptr p to indexed, n1-th level nested FOR-loop index. n1 = 0 for innermost loop.
	running index: n1 @NX F@, increment: n1 @NX FLOAT+ F@, limit: n1 @NX DFLOAT+ F@.
	can be used at runtime to modifying e.g, the loop increment:
		{ inc fdup f* inc f- 0 dv>n @nx float+ f! }

 NX		( n1 -- f1 )							rational ans float
	n1-th level nested FOR-loop index.
	n1 = 0 refers to innermost level, as { IDX }.

 FOR		(C: -- p f )(X: f1 -- )		(i)				rational ans float
	introducing a FOR [ FROM ] [ STEP ] .. [ IDX ][ nn NX ] .. NEXT loop.
	cpl: leaves back-ptr p for resolution by NEXT and control flag f.
	xec: -re- {(for)} runtime code
	further, related words -re- {INC}, {LIM}, {END} and the rsp. "!" and "@" variants.

 FROM		(C: p1 f -- p2 f )(X: f1 -- )	(i)				rational ans float
	immediately after {for} or {step}, modifies loop start to f1 from data-stack.
	cpl: checks flg f, modifies back-ptr p to pointing to immediately after {FROM}.
	xec: runtime code, -re- {(from)}

 +FROM  	(C: p1 f -- p2 f )(X: f1 -- )	(i)		'pfrom		rational ans float
	immediately after {for} or {step},
	set FOR-loop start index := dv and limit := limit + dv, limit := FOR-arg + dv.
	cpl: checks flg f, modifies back-ptr p to pointing to immediately after {+FROM}.
	xec: -re- runtime code, "(+from)"

 STEP		(C: p1 f -- p2 f )(X: f1 -- )	(i)				rational ans float
	immediately after {for} or {from}, {+from}, modifies loop increment to dv.
	cpl: checks flg f, modifies back-ptr p to pointing to immediately after {STEP}.
	xec: -re- runtime code, "(step)"

 NEXT		(C: p f -- )			(i)				rational ans float
	terminates a FOR [ FROM ] [ STEP ] ... NEXT loop
	cpl: checks flg f, resolve backward ptr.
	xec: -re- runtime code, "(next)"

 D>F		( dn -- f1 )			d>dv		'dtof'		ans float

 DF>F		( df1 -- f1 )			qv>dv		'dftof'		ans float

 F!		( p -- )			dv!		'fstore'	ans float

 F*		( f1 f2 -- f3 )			dv*		'fmulf'		ans float

 F2*		( f1 f2 -- f3 )			dv2*		'f2mul'		ans float

 F+		( f1 f2 -- f3 )			dv+		'fplus'		ans float

 F-		( f1 f2 -- f3 )			dv-		'fsubf'		ans float

 F/		( f1 f2 -- f3 )			dv/		'fby'		ans float

 F2/		( f1 f2 -- f3 )			dv2/		'f2by'		ans float

 F1+		( f1 -- f2 )			dv1+		'fonep'		ans float

 F1-		( f1 -- f2 )			dv1-		'fonem'		ans float

 F0<		( f1 -- f2 )			dv0<		'fzlt'		ans float

 F0=		( f1 -- f2 )			dv0=		'fzeq'		ans float

 F<		( f1 -- f2 )			dv<		'flt'		ans float

 F>D		( f1 -- dn )			d/		'ftod'		ans float

 F>DF		( f1 -- df1 )			dv>qv		'ftodf'		ans float

 F@		( p -- f1 )			dv@		'ffetch'	ans float

 FCONSTANT	ccc( f1 -- )(X: -- f1 )	(i)	dvconstant	'fcons'		ans float

 FDEPTH	(  -- n )			dvdepth				ans float

 FDROP	( f1 -- )			4drop				ans float

 FDUP		( f1 -- f1 f1 )			4dup				ans float

 F2DUP	( f1 f2 -- f1 f2 f1 f2 )	8dup				ans float

 DF2DUP	( df1 df2 -- df1 df2 df1 df2 )	qv2dup				ans float

 FLITERAL	( f1 -- )		(i)	dvliteral			ans float

 FLOOR	( f1 -- f2 )			dv>d				ans float

 FMAX		( f1 -- f2 )			dvmax				ans float

 FMIN		( f1 -- f2 )			dvmin				ans float

 FNEGATE	( f1 -- f2 )			dvnegate			ans float

 FOVER	( f1 -- f2 )			dvover				ans float

 DFOVER	( df1 -- df2 )			qvover				ans float

 FROT		( f1 f2 f3 -- f2 f3 f1 )	dvrot				ans float

 DFROT  	( df1 df2 df3 -- df2 df3 df1 )	qvrot				ans float

 FPICK  	( f1 ... n -- ... f1 )		dvpick				ans float

 DFPICK  	( df1 ... n -- ... df1 )	qvpick				ans float

 FSWAP	( f1 f2 -- f2 f1 )		dvswap				ans float

 DFSWAP	( df1 df2 -- df2 df1 )		qvswap				ans float

 FVARIABLE	ccc( -- )(X: -- p )	(i)	dvvariable	'fvari'		ans float

 DF!		( qv p -- )			qv!		'dfstore'	ans float

 DF@		( p -- f1 )			qv@		'dffetch'	ans float

 F^		( f1 -- f2 )			dv^		'fpow'		ans float
 F**		( f1 -- f2 )			dv^		'fpow'		ans float

 F.		( f1 -- )			df.		'fdot'		ans float

 DF.		( df1 -- )			qf.		'dfdotf'	ans float

 fabs		( f1 -- f2 )			dfabs				ans float

 FACOS	( f1 -- f2 )			acos(dv)			ans float

 FALOG	( f1 -- f2 )			10^dv		'falogf'	ans float

 FASIN	( f1 -- f2 )			asin(dv)			ans float

 FATAN	( f1 -- f2 )			atg(dv)				ans float

 FCOS		( f1 -- f2 )			cos(dv)		'fcosf'		ans float

 FE.	( f1 -- f2 )				f.				ans float
	preliminary, non-standard substitute

 FEXP		( f1 -- f2 )			e^dv				ans float

 FLN		( f1 -- f2 )			ln(dv)				ans float

 FLOG		( f1 -- f2 )			lg(dv)				ans float

 FS.		( f1 -- f2 )			f.				ans float
	preliminary, non-standard substitute

 FSIN		( f1 -- f2 )			sin(dv)		'fsinf'		ans float

 FSINCOS	( f1 -- f2 )			sincos(dv)	'fsc'		ans float

 FSQRT	( f1 -- f2 )			dvsqrt		'fsqrtf'	ans float

 FTAN		( f1 -- f2 )			tg(dv)				ans float

 SF!		( f1 p -- )			dv!		'sfstore'	ans float

 SF@		( p -- f1 )			dv@		'sffetch'	ans float

 SFALIGN	( p1 -- p2 )			falign				ans

 SFLOAT+	( p1 -- p2 )			float+		'sfloatp'	ans

================================================================
 l4rational.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4rstack.inc>
--------------------------------------------------------------------------


--------------------------------------------------------------------
--  returnstack
	push/pop to returnstack adds/subtracts <kref> value
	2>r, r> r> cannot be used to swap cells! re {rswap}.

 rp!		( -- )				(fg)		'rpstore'	forth
	reset returnstack to @r0 from @r0. - f.i.g.-mode
	return to caller, other returnpoints cleared.
	pushes return to {quit} below tor, for safety.

 RP!		( p -- )			(a:c)		'arpstore'	ans
	reset returnstack to kref'd p. - ANS mode
	return to caller, other returnpoints cleared.
	(e: flags unchanged)

 >rr		( nn -- nn )( rp: -- nn )	(f6)(m,4)	'torr'		forth
	push duplicate tos item to returnstack

 >r		( nn -- )( rp: -- nn )		(M,9)		'tor'		forth
	push cell from tos to tor
	(e: flags unchanged)

 r>		( -- n )(R: n -- )		(m,4)		'rfrom'		forth
	pop cell ftom tor to tos

 r+!		( n -- )(R: n1 -- n2 )		(m,8)		'rps'		forth
	add n to @tor
	(e: flags after addition)

 r>>r		( n1 -- n2 )(R: n2 -- n1 )	(m,14)		'rxchg'		forth
	exchange cells on tos and on tor

 rp@		( -- a )			(fg)(m,5)	'rpfetch'	forth
	fetch returnstack ptr
	programs should not access returnstack by address!

 i		( -- nn )(R: nn -- nn )  	(m,6)				forth
	copy loop index to tos
 r		( -- nn ) (R: nn -- nn )	(m,6)				forth
 r@		( -- nn ) (R: nn -- nn )			'r'		forth
	duplicate & push top item from returnstack to datastack

 j		( -- n2 )(R: n1 n2 -- n1 n2 )	(m,7)				forth
	copy next outer loop index to tos

 ni		( ni -- nx )(R: nx .. nn -- nx .. nn )	(h4)(m,5)		forth
	copy ni-th outer loop index to tos, cnt begins w. zero for {i}

 li		( ni -- nx )(R: nx .. nn -- nx .. nn )	(h4)(m,5)		forth
	copy li-th outer loop limit to tos, cnt begins w. zero for innermost loop.

 rdrop  	(R: n1 -- )			(f6)(m,3)			forth
	drop cell from return-stack

 rswap  	(R: n1 n2 -- n2 n1 )						forth
	swap cells on return-stack

 !r		( p -- )(R: n -- )		(m,8)		'storer'	hidden
	store kref(n) - n+KR - to ptr p, remove both from rsp. stacks.

 r+		( -- n )			(f6)(m,)	'rplus'		hidden
	! while compiling and, for 2nd level compiling words, only !
	fetch n from code-space and advance beyond cell where next level return-ptr 
	points to; i.e. pass an execution token - or other data - to next level word.
	does{ r> r> dup cell+ >r swap >r @ }
	e.g, to passing different execution tokens to a generalized frame-word:
		: frame ..words..  r+ execute  ..words.. ;
		: caller ... frame [ ' .s 4, ] ... ; 
	then, {caller} will execute {frame} with the tick-ed {.s} in between.

-----------------------------------------------------------------------
--  doubles
	cell order always(!) little endian, l.s.cell @tor,
	maintained by store+increment PS and decrement+store RS.

	for ANS-Forth compliance, the only exceptions being the ordered 
	double cells storeing/fetching words 2@, 2!, 2>R, 2R@, 2R>, which by
	that standard were justified with some silly tricks programmery, 
	combining push/pop with an implied swap was 'natural programming..' 
	to those highly admired, deeply respected, "experts"...
	L4 mode:
		2>r and >r >r	PS:[ n2 n1 -- ]top - RS:[ -- n1 n2 ]top
		2r@		PS:[ -- n2 n1 ]
	ANS mode:
		2>r		PS:[ n2 n1 -- ]top - RS:[ -- n2 n1 ]top
		>r >r		PS:[ n2 n1 -- ]top - RS:[ -- n1 n2 ]top
	
	
 2R>		(R: n1 n2 -- )( -- n2 n1 )	(m,11)		'arfrom2'	ans
	in reversed cells order pop double from tos to returnstack,
	use w/ {ans} words 2>R and 2R@.
	DPANS94 17.6.2.0340: @tos corresponds to @tor, cells order on RS reversed.
	DPANS94  A.6.2.0340: justification of cells order is plain nonsense...
	ANS-mode push/pop vs l4/4th is { swap 2>r .. 2r@ swap ..  2r> swap }

 2R@		(R: n1 n2 -- )( -- n2 n1 )			'ar2f'		ans
	copy double from tos to returnstack - in reversed cells order! 
	use w/ {ans} words 2>R and 2R>. ANS-mode push/pop vs l4/4th -re- {2R>}

 2>R		( n1 n2 -- )(R: -- n2 n1 )			'ator2'		ans
	in reversed cells order push double from tos to returnstack,
	use w/ {ans} words 2R@ and 2R>. ANS-mode push/pop vs l4/4th -re- {2R>}

 2>r		( d -- )(R: -- d )				'tor2'		forth
	push double from tos to returnstack, PS: n1 n2 -- RS: -- n1 n2
	F8: runtime of {do}, does{ >r >r }

 2>rr		( d -- d )(R: -- d )		(m,10)		'torr2'		forth
	copy double from data-stack to to return-stack,	{ 2dup 2>r }.

 2r>		( -- d )(R: d -- )		(m,11)		'rfrom2'	forth
	does{ r> r> }

 2r>>2r  	( d1 -- d2 )(R: d2 -- d1 )			'r2xchg'	forth
	exchange doubles on tos and on tor

 2r		( -- d ) (R: d -- d )		(m,9)		'r2'		forth
	copy double from returnstack to datastack, does{ r> r over >r }.
	NOTE: consistent, little endian cells & bytes order; -re- {2R@} ANS-voc.

 2rdrop  	(R: n1 n2 -- )			(f6)(m,3)	'rdrop2'	forth
	drop a double from return-stack

 2rswap  	(R: d1 d2 -- d2 d1 )		(m,20)(X)	'rswap2'	forth
	swap doubles on return-stack (macro w/ __MMX mode, only)

 4>r		( q -- )(R: -- q )				'tor4'		forth
	push quad from tos to returnstack, PS: n1 n2 n3 n4 -- RS: -- n1 n2 n3 n4

 4r>		( -- q )(R: q -- )				'rfrom4'	forth

 4r		( -- q ) (R: q -- q )				'r4'		forth
	copy double from returnstack to datastack, does{ r> r over >r }.
	NOTE: consistent, little endian cells & bytes order; -re- {2R@} ANS-voc.

 4rdrop  	(R: q -- )			(f6)(m,3)	'rdrop4'	forth
	drop four cells from return-stack

 m>r		( p n -- )(R: -- n1..nn )			'mtor'		forth
	little-endian fetch n bytes(!) to tor, leaving data @RS un-changed,
	restore true figures w. {4th>abs} when fetched back with {r>}, etc.

 r>m		( p n -- )(R: n1..nn -- )			'rtom'		forth
	little-endian store n bytes(!) from tor to memory location p,
	beginning w. cell aligned n1; sto by true values.

=====================================================================;
 l4rstack.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4sighnd.inc>
--------------------------------------------------------------------------


================================================================
 -- signal handlers & setup

	

 sighnd-size	( -- n )					'sighsz'	linux
	(unified) size of a signal handler definition block. -re- uvari {(sighnd)}.

 <isegf>
	signal handlers setup in dataspace, from relative ptrs, 
	after system set up, before input mode determination and entry into hi-level 4th
 
  signals (checked w. 2.2.14-rtl2.0 debian2.2/rtlinux, 2.4.16 and, 2.2.5 redhat6.0)
	leaves the pc of where the signal was triggered on stack, (apparently) 
	at @{@{tos+8}+19*4} which can be used to job control and debugging.

 sgb		( -- )				(k)(r)		'rsigb'		novoc
	terminating/recovering signals hnd

 sgt		( -- )				(k)(r)		'rsigt'		novoc
	messaging and rt-signals hnd, job continuing

 <quits>
	sigquit, restart by <CTR"\"> key	- n.i., endless loop, either variant.. -

 <rfpesig>
	recovery from division-'fault'

 <rsegalarm>	( -- )				(k)		'rsegalrm'	novoc
	saves all regs and executes deferred {(alarm)} by redirected 
	SIGALRM handler, dft { .rs [s] }.
	stack-ptr unsafe:
		e.g, though all regs saved w/ <pushad/popad> instr
		{words} drops one cell, while {vlist} is ok... -?-

=====================================================================;
 l4sighnd.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4smem.inc>
--------------------------------------------------------------------------

================================================================
 -- memory

----------------------------------------------------------------
 -- access mode & flags

 prot-r  	( -- n )			(c)(m,6)	'protr'		linux
	enable reading memory access, OR-able flag to {mprotect}

 prot-w  	( -- n )			(c)(m,6)	'protw'		linux
	enable writing memory access, OR-able flag to {mprotect}

 prot-x  	( -- n )			(c)(m,6)	'protx'		linux
	enable executing memory access, OR-able flag to {mprotect}

 page-size	( -- n )			(c)(m,6)	'pagesize'	linux
	Linux PAGE_SIZE system cons (4K w/ kernel 2.2.xx)

 mprotect	( a n1 n2 -- er )		(s)		'mprot'		linux
	set memory access mode, range n1 at true address a, access mode n2.
	range and address expected page aligned. disabled for linux user "root".
	syscall -re- man (2) mprotect
	

----------------------------------------------------------------
 -- common resources access routines -:preliminary:-
	caller should not store KR (ebx reg.) to RS immediately prior
	to call to one of below basic resources related calls.

 --
 <rel4hnd>	( -- )				(k)
	push flag to notify that ptr rel kref passed into hnd routine to RS,
	should be called immediately before call to handler opr as of open/close/io.
	data-stack, regs & eflags preserved
	
 <utlink>
	link rel. ptr to linked list
 <utunlink>
	unlink rel. ptr from linked list

	
 ----------------------------------------------------------------
 -- basic handler access
	receiving args and returning result in data-stack,
	args passed to/received from handler routines by regs eax,ecx
	
 -- common to all routines:
	in:
		eax	data input
		@tos	2ndary data input from data-stack
	out:
		eflags	Z or, error condition: NC & NZ, eax "above" -4096 (i.e. unsigned greater)
		eax	multiple args: 0 or error code, single arg: error code or return value
		@tos	optional, other return values
	

 hndopen	(u1 a1 -- a2 er )		(k)
	allocate system resource by handler base address a1 and specific data u1
	ret a2 adress of item definition block and er error code.

 hndclose	( a -- 0 | er )			(k)
	call de-location routine of a device handler
	by a address of beginning of heaphead struc.

 hndio  	( a1 n1 -- a2 er )		(k)
	perform an operation coded by n1 on data item pointed to by p1
	eax=n1, TOS(1)=a1, edx=op-code

----------------------------------------------------------------
 -- resource specifc routines - access by reg's, only, no data-stack opr
	
	common to all routines:
	in:
		eax	data input
		ecx,edx	2ndary data input
	out:
		eflags	error condition: NC & NZ, eax "above" -4096 (i.e. unsigned greater)
		eax	multiple args: error code, single arg: errorc code or return value
		ecx,edx	optional, other return values
	

 system memory
	

 mmrechp	<eax:a -- eax:er>
	pass memory back to system heap, store new memtop to (top)
 i:	eax	heaphead
 o:	eax	er

 mmalloc	<eax:n -- eax:er ecx:hphead>	(k)
	allocate +n bytes of r/w/x enabled memory in system heap (.bss),
	ret address of bottom of allocated area, error if 0 > er > -4096
	new memtop stored to (top).
 i:	eax	n
 o:	eax	heaphead | ernum

 mmresiz	<ecx:a1 eax:u -- ecx:a2 eax:er>	(k)
 i:	eax	new size
	ecx	address of header of block to resize
 o:	eax	new top | er
	ecx	(new) hphead

--------------------------------------------------------------------------------
 -- 4th host system memory words

	

 ?resize	( n -- )					'?resizem'	forth
	-re- {resize} if {allot}ting n bytes would leave less than PAGE_SIZE 
	of free data-space; - does not {allot} but, is called by {allot}.

 resize  	( p1 u -- p2 er )		(a:m)		'resizem'	forth
	provided for top block, only:
	new memtop stored to (top), error if 0 > er > -4096
	p1 ptr to after heap-header of top {allocate}d block.
	example: { (bot) @ abs>4th dup headhead-size + swap @ 4000 + resize 0if }.
	No garbage collection - which lib4th, if efficiently used, does not require, 
	e.g, due to it's extended LOCALS and BLOCK words -re- {local:}, {ibbuf} &c.

 allocate	( u -- p 0 | p er )		(a:m)		'allocatem'	forth
	allocate u bytes of memory in system heap (.bss section), aligned to multiples 
	of Linux PAGE_SIZE, minimum is PAGE_SIZE = 4Kb (for Linux-2.2.+ and 2.4.+).
	ret ptr p to beginning of free space, after heap header.
	new memtop stored to (top), error if 0 > er > -4096
	{d-top} remains unchanged! adjust if extension of program dataspace intended,
	new top of data-memory is { p heaphead-size - dup @ + }, which then can be
	stored to {d-top} to make it available to the rsp. words.
	-re- LOCALS wordsets, {locals|} &c, for temporary buffers allocation, 
	-re- {ibbuf} and BLOCK words, for an alternate/supplemental allocation scheme.

 free		( p -- er )			(a:m)(e)	'freem'		forth
	assign {allocate}d top memory block p back to system heap (.bss section)
	ok if p was top block new memtop stored to (top), error if 0 > er > -4096
	{d-top} adjusted to { p heaphead-size - } if new top below old.
	p is ptr to after heap structure data, as returned by {allocate}.
	(e: Z after success, S on error, ENOBUFS if ptrs not suitable

 heaphead-size ( -- n ) 			(c)		'hpheads'	linux
	size of heap header (16/8 bytes = 4/2 cells)
	allocated: [ len ][ handler ][ pid ][ flagptr ][ ..memory.. ]
	free:	   [ len ][ next block ][ ..memory.. ]

 top-mblock	( -- p )					'topmblock'	forth
	find ptr to beginning of top {allocate}d memory block,
	p := "free space" posn, after heap-header, initially = @c0.

 bufhead-size	( -- )				(kv)		'bufheadsz'	blkfile
	default size of a block buffer header (by kernel).

 blkhead-size	( -- )				(kv)		'blkheadsz'	blkfile
	default size of a per screenfile-block header in block of screenfile buffers.

 fgb		( ix -- ix )			(k)				novoc
	buffer blocks forget handler

 ibbuf  	( -- )								blkfile
	set-up a block of screenfile block buffers.
	a buffers' block is of {page-size} bytes, beginning at page-aligned true 
	address which thus may be used to store a minimal, {mmap}ed item.
	constitutes a quasi-nameless word (name is a <nul> byte) w/ forget-handler 
	such, that buffer blocks removeable by {iforget} per uot-index of the rsp 
	buffer or with {forget} of any older regular word.
	
	block of block-/screenfile buffers, header at 8-aligned address:
		struc blkbuf  [ link ][ reserve ][ channel ][ #blocks ]
	00: .l	circular link, pc-rel disp to next blockptr, zero if 
		no other block exists; initial ptr in -re- {block-lk}, 
		linkage such that {block-lk} disp pointing to 1st, further 
		linkfields to the rsp latest and, last to 1st buffer block:
		block-lk->[ oldest->most recent->previous->..->next to oldest ]
	04: .u	- till unused -
	08: .c	file channel the rsp buffer is assigned to
	0c: .b	no. of blocks in this buffer
	10: .f	#blocks(4) buffer-headers follow:
		struc blkhead [ updt|blk# ][ disp ]
		00: .u: update-flag(bit#31) ORed w/ block-number
		04: .d: pc-rel disp-to-blk
	next buffer in chain ( -- p f ), f=/=0 if next buffer found:
		{ block-lk @ begin dup @ over swap + dup rot - ... }
	-re- {buffer}, {block}, {blk>lnk}, {buf>lnk}, {blk>head}, {buf>head} &c.
	data/code structures re file <inc/l4struc.inc>.

=====================================================================;
 l4smem.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4sorder.inc>
--------------------------------------------------------------------------


================================================================
-- search order
	unless mentioned all vocabularies belong to {root},
	{root} vocabulary is sub-vocabulary of itself.
	lib4th supplied vocabularies are set "immediate".

	

 forth-wordlist ( -- wid )			(a:v)		'forthwl'	root

 root-wordlist ( -- wid )			(a:-)		'rootwl'	hidden

 idx>wid	( ix -- wid | 0 )				'idx2wid'	hidden
	convert vocabulary name's index to wordlist identifier

 dvo						(X)(k)		'dovoc'		novoc
	vocabulary runtime routine, executed by a vocabulary defn:
	save previous current in {ocurrent}, drop previous {ocurrent},
	store wid = voclink ptr of called voc to {current}.

 novoc  	( -- )				(i)				system
	inactive, dummy vocabulary for debugging purposes, sub-vocabulary of {system},
	list of words for kernel access, only, named to supporting {see} output and 
	w/ header data for internal, redirectably compiling (i.e. by ix) purposes.
	{novoc} is a noop. words linked to a pseudo-'wordlist' which should not be 
	accessed; the rsp words glossary entries will be displayed w/ { help name }.
	if activated - w/ some applied magic - would most certainly crash the system!

 root		( -- )				(X)(i)				root
	the basic vocabulary which can't be excluded from search order, where it 
	will be searched last if not explicitely included. contains the words 
	essential to enabling orderly access to the forth system. 
	-re- {only} resets search order to no other vocabulary but {local} and {root}.

 linux  	( -- )				(X)(i)				root
	vocabulary providing words for host system access which are not defined 
	in a(ny) Forth standard. linux system calls and system specific constants.

 forth  	( -- )				(X)(i)				root
	most commonly used and, all ANS-Forth words as described in "dpans94" doc.

 bignum  	( -- )				(X)(i)				forth
	vocabulary for opr on counted signed integers.
	a 'counted integer' is a contiguous group of little endian ordered bits in 
	multiples of cell-size w/ sign bit at m.s. position (top address), in 2-s 
	complement notation, and a count cell, bearing the no. of the rsp. cells.
	located in data-stack w/ count cell @tos or, in memory w/ count cell at l.s. 
	address, for fast data access. -re- {n@} &c.
		Notation:	( .n.N )	count N of cells n(0..N)
	(genuine, new implementation, no "Art"work, nothing copied from nowhere...)

 hidden  	( -- )				(X)(i)				root
	vocabulary, words which support but aren't standard words.

 testvoc	( -- )				(X)(i)				hidden
	vocabulary for testing purposes

 non-mmx  	( -- )				(X)(i)				forth
	non-mmx substitutes vocabulary.

 ans		( -- )				(X)(i)				forth
	{forth} sub-vocabulary,
	ans-4th specific supplementary words to {forth} wordlist.

 fig		( -- )				(X)(i)				forth
	{forth} sub-vocabulary 
	f.i.g.-4th specific supplementary words to {forth} wordlist.

 editor  	( -- )				(X)(i)				fig
	the f.i.g-Forth screenfile editor, {fig} sub-vocabulary.
	some words homononymous to other, Forth words! e.g. {R}, {I}, {J}.
	      B         backup cursor by length of text in pad
	      C {text}  copy in the following text at cursor posn
	( n ) D         remove line no. ( n ), put it to pad
	( n ) E         blank line no. ( n )
	      F {text}  find following text
	( n ) H         hold line no. ( n ) in pad
	( n ) I         insert line no. ( n ) from pad
	      L         list current screen,
	      	L+,L-,L#    next, previous, by number.
	( n ) M         move cursor by ( n ) chars, show line & cursor
	      N         find next occurence of text ( after f )
	( n ) P {text}  put text until <enter> on line no. ( n )
	( n ) S         spread at line no. ( n ), insert an empty line
	( n ) R         replace line no. ( n ) with text from pad
	( n ) T         type line no. ( n ) and hold it in pad
	      X {text}  delete the following text
	( n ) CLEAR	clear scr no. n, append to file if appropriate
	( n ) DELETE	delete n chars backwards
	( n1 n2 ) COPY	copy screen n1 to n2
	      flush	save updated, modified buffers
	( n ) .LINE	display line no. n of current screen
	      TEXT {text} to pad
	      TILL {text} delete from cursor till {text} end
	      TOP	cursor to top left of current screen
	( p u ) using	open file to be used w/ screenfile words
	      where	(n.i.)

 blkfile  	( -- )				(X)(i)				forth
	sub-vocabulary of {forth}
	block-files specific supplementary words to {forth} wordlist.

 vt	  	( -- )				(x)(i)				forth
	vocabulary, vt..-sequences for console appearance & control.
	ctrls can also be sent as strings { ." \33..." }, etc. -re- {[etype]}.

 assembler	( -- )				(x)(i)				root
	vocabulary, native code compiling support

 tools  	( -- )				(x)(i)				forth
	non-standard debugging (and other) utilities vocabulary

 local  	( -- )				(x)(i)				hidden
	local memory support vocabulary, temporary local names & memory ref-s
	{local} will always be searched 1st and cannot be excluded from search order.

 compiler	( -- )				(x)(i)				root
	vocabulary, non-standard compiler control.

 system  	( -- )				(x)(i)		'systm'		root
	vocabulary, highly host and system specific words, not for common access.

 util   	( -- )				(X)(i)		'utility'	forth
	vocabulary, forth utility words (for app's).

 [locdef]					(4)		'blocdefb'	hidden
	support for the {(locals)} definition; cpl { also local definitions }.

 definitions					(a:s)(X) 			root
	set current to context vocabulary, 
	store old in ocurrent for restauration by {prevdef}.
	does { current ocurrent @! context current @! }

 prevdef	( -- )				(f6)(X) 			root
	restore previous current from {ocurrent}.

 rvoc		( -- )				(i)(f6)(X) 			root
	restore previous context from {ocontext}.

 only		( -- )				(i)(a:sx)(X)			root
	reset search order to only {root} in {context}.

 also		( -- )				(i)(a:sx)(x)			root
	push ocontext, duplicate context into ocontext
	push is move all one item down and store new to hi address.
	stack size is 2+{#vocs} items (dft:2+16).

 previous	( -- )				(i)(a:sx)(x)			root
	copy @{ocontext} to {context}, pop top item from vocstack to {ocontext}.

 get-current	( -- wid )			(a:v)		'gcurrent'	root
	fetch {current} wordlist identifier.

 set-current	( wid -- )			(a:v)		'scurrent'	root
	tore {current} wordlist identifier.

 get-vocflags	( -- wfl..wfl n )		(l4)		'gvocflags'	hidden
	complements {get-order} by fetching vocabulary flags

 get-vocs	( -- wfl n wid.. n )		(l4)		'getvocs'	root
	fetch all wid-s and voc.-flags currently in stacked search order.

 GET-ORDER	( -- wid .. wid n )		(a:v)		'gorder'	ans
	get stacked vocabularies identifiers and count. this list 
	includes {context} and {ocontext}, @context top wid on stack
	the list can be preserved w/ a bignum {ninteger}
		{ GET-ORDER also bignum ninteger -name- previous }
	for restoration w/ { -name- SET-ORDER }.
	ANS-4th; -re- {get-vocs}, {set-vocs} for a more complete version.

 set-order	( wid ... n -- )		(a:v)		'sorder'	root
	store list of n vocabulary identifiers to stacked search order.
	includes {context} and {ocontext}, vocflags remain unmodified.
	abort if false count/unsufficient data on stack

 set-vocs	( wfl.. m wid.. n -- )				'setvocs'	root
	restore search-order(wid,n) and voc-flags(wfl,m)
	abort if false count/unsufficient data on stack

 set-vocflags	( -- wfl .. wfl n )				'svocflags'	hidden
	complements {set-order} by storing vocabulary flags
	abort if false count/unsufficient data on stack

 order  	( -- )				(4)(a:v)			root
	display current, context, previous context 
	and stacked search order vocabularies.

 vocs		( -- )				(4)(f6)				root
	display names of all vocabularies

 order? 	( ix | lfa -- n | -1 )				'orderq'	forth
	ret item number wrt {current} of voc by ix in voc-stack, -1 if not found.
	n points to the rsp. ptr into vocstack by { ' name order? -8 * current + }.
	ix = -1 to finding the actual bottom of vocstack, ret -1 if no space left.
	-re- {WORDLIST?} for ref by wid.

 WORDLIST?	( wid -- n | -1 )				'wordlq'	ans
	item number wrt {current} of wordlist by wid in search order, -1 not found.
	n is index into vocstack, by { ' name idx>wid WORDLIST? -8 * current + }.
	wid = 0 to finding the actual bottom of vocstack, ret -1 if no space left.
	-re- {order?} for ref by ix or lfa.

=====================================================================;
 l4sorder.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4sranum.inc>
--------------------------------------------------------------------------


 0v		( -- v )					'v0v'		rational cons
	cons sing ranum 0

 1v		( -- v )					'v1v'		rational cons
	cons ranum 1

 -1v		( -- v )					'vm1v'		rational cons
	cons ranum -1
 e^6   	( -- v )					'cae6'		rational cons
	e to the power of ten, ret v := 403,42879349
 e		( -- num den )					'cae'		rational cons
	2,7182818284(5)... +/- 10^-10, e = lim (1+1/n)^n
					   n=1->oo
 e^10		( -- v )					'cae10'		rational cons
	e to the power of ten, ret v := 22026,4657948

	
-- Literals

 vliteral	( v -- )			(i)				rational
	compile/interpret rational number v as a double literal.

 vconstant	( -- v )							rational
	-re- {2constant}

 vinteger	( -- v )							rational
	-re- {2integer}

 vvariable	( -- p )							rational
	-re- {2variable}

 vreduce 	( v1 -- v2 )							rational
	reduces a ranum by greatest common divisor of numerator and denominator.

 ud>n?  	( ud -- +n f)					'ud2nq'		rational hidden
	converts unsigned double ud to non-negative single +n. 
	tf if conversion failed.

 vnormal 	( dv -- v )			(x)				rational hidden
	return the normalised ranum which most closely approximates the signed 
	double rational number passed to it. Returns 1 0 if the double was too 
	large and positive to be represented or -1 0 if too large and negative. 
	Numbers too small to be represented are rounded to zero (0 1).
	
	Works by generating approximations from successive numbers in the continued
	fraction expansion of dv, until no more numbers are available, or overflow
	occurs.
	The 1st number in the continued fraction expansion is the integral component 
	and the next the integral component of the reciprocal of the fractional 
	component and so on. The continued fraction of any rational number terminates 
	when the fractional component becomes zero.

 small? 	( dv -- f )							rational hidden
	returns TRUE if double ranum dv can be normalised by "normal", rather than
	the slower "vnormal".

	
-- Arithmetic

 v-		( v1 v2 -- v3 )					'vsub'		rational
	subtract v2 from v1.

 v+		( v1 v2 -- v3 )					'vplus'		rational
	add two ranums using naive algorithm, 
	generating double length result, then round to single.

 dv>v		( dv -- v )					'dv2v'		rational
	returns the ranum that most closely approximates the unnormalised  
	ranum dv. If overflow is detected (denominator is zero) action is 
	taken to ensure the overflow indicator 0 0 is returned.

 v/		( v1 v2 -- v3 )					'vby'		rational
	divide v1 by v2 giving quotient v3.

 v*		( v v -- v)					'vmul'		rational
	multiply two ranums using naive algorithm, generating double length 
	result, then round to single.

 vsgn		( v -- -1 | 0 | 1 )		(m,)		'vsgn'		rational
	ret sing signum of a ranum

 v+-		( v1 n -- v2 )			(m,)		'vpm'		rational
	negate v1 if n < 0

 vnegate	( v -- v )			(m,)				rational
	return { ranum -1 * }. The sign bit is in the numerator.

 vabs		( v -- |v| )			( m, )				rational
	return absolute value of ranum argument.

 1/v		( v -- v )			(m,)		'vrecip'	rational
	the reciprocal of a ranum.

 v1+		( v1 -- v2 )					'vonep'		rational
	increment v1 by one

 v1-		( v1 -- v2 )					'vonem'		rational
	decrement v1 by one

 v2*		( v1 -- v2 )					'v2mul'		rational
	multiply v1 by 2

 v2/		( v1 -- v2 )					'v2div'		rational
	divide v1 by 2

	
-- Comparison

 v0<		( v -- f)			(m,)		'vzlt'		rational
	flag is TRUE if v is negative.

 v~		( v v -- f )					'vaeq'		rational
	tf if the two ranum arguments are approximately equal.
	The difference between two ranums may be less than the smallest ranum that
	is representable with a single cell denominator. In this instance the two
	ranums may be reasonably described as approximately equal.

 v0=		( v -- f )					'vzeq'		rational
	flag is true if v is zero.

 v=		( v1 v2 -- f )					'veq'		rational
	tf if v1, v2 exactly equal.

 v>		( v1 v2 -- f )					'vgt'		rational
	tf if v1 greater than v2.
	Returns FALSE if either	argument is the overflow condition.

 v<		( v1 v2 -- f )					'vlt'		rational
	tf if v1 less than v2. 
	Returns FALSE if either argument is the overflow condition.

 voverflow	( v -- f )							rational
	f is TRUE if v indicates overflow has occurred previously.
	This word should be used where overflow is possible. (propagation
	of overflow is not guaranteed.)

 vmax		( v1 v2 -- v3 )							rational
	returns the larger of the two ranum arguments. 
	Will always return the overflow condition, if present.

 vmin		( v1 v2--v3)							rational
	returns the smaller of the two ranum arguments. 
	Will always return the overflow condition, if present.

	
-- Conversion

 s>v		( n -- v )					's2v'		rational
	promote single integer to ranum equivalent. n --> n 1

 v>s		( v -- n )					'v2s'		rational
	return the floored, integral component of v as a signed integer.

 vsplit 	( v1 -- v2 v3 )							rational
	floored integral v2 and (non-negative) fractional v3 component of v1. 
	w/ Floored rounding, i.e. v1 = v2 + v3 and assuming +ve v3 is always valid. 
	word is tolerant of the overflow condition.

 vfrac  	( v1 -- v2 )							rational
	return the fractional component of v1 as non-negative ranum v2.
	w/ Floored rounding. word is tolerant of the overflow condition.

-- Rounding

 v>uv?  	( v -- uv f)					'v2uvq'		rational hidden
	uv is the absolute value of the v, f is TRUE if v was negative.

 vround 	( v1 +n -- v2 )			(x)				rational
	returns an approximation to the rational number v1 such that neither 
	the numerator nor the denominator exceeds the positive integer n.
	The intent is that, where high precision is not an issue, vround can 
	be inserted at key points in the code to ensure the quicker "normalise" 
	path is taken in subsequent words that call DV>V

 vsimplify	( v1 +n -- v2 )			(4)				rational
	returns an approximation to the rational number v1 such that neither the
	numerator nor the denominator of the fractional component of v1 exceeds 
	the positive integer n.

	
-- Memory Ref.

 v@		( p -- v ) 							rational
	fetch v from memory at p

 v!		( v p -- ) 							rational
	store v to memory at p

	
-- Stacks Ref.

 v-rot  	( v1 v2 v3 -- v3 v1 v2 )					rational
 vdrop  	( v1 -- v1 v1 )							rational
 vdup   	( v1 -- v1 v1 )							rational
 v2dup  	( v1 v2 -- v1 v2 v1 v2 )					rational
 vover  	( v1 v2 -- v1 v2 v1 )						rational
 vpick  	( ... n -- ... vn )						rational
 vrot   	( v1 v2 v3 -- v2 v3 v1 )					rational
 vroll  	( ... n -- ... vn )						rational
 vswap  	( v1 v2 -- v2 v1 )						rational
	double cells opr. apply to (current) rational numbers impl.

	

 #v		( +v -- 0 0 )					'sharpv'	rational
	append positive ranum +v to the pictured numeric output string according to
	the following rules.
	  If +v is zero append "0".
	  If +v has an integral component but no fractional component, append that
	        number.
	  If +v has a fractional component but no integral component append "a/b"
	        where a is the numerator, and b the denominator.
	  If +v has both a an integral and a fractional component append "a b/c"
	        where a is the integral component, b the numerator and c the
	        denominator of the fractional component. There is a space between
	        the integral and fractional components.
	The conversion is done according to the current value of BASE.

 #vf		( +v -- 0 0 )					'sharpvf'	rational
	append the positive ranum +v to the pictured numeric output string as a
	floating point number. That is to say, the integral component, followed by
	a point, followed by as many digits as specified by places. If places is zero
	no point is included. Returns 0 0 for consistency with other pictured numeric
	output conversion words. The conversion is done according to the current
	value of BASE.

 <#vf#> 	( v -- p n )					'ltvfgt'	rational hidden
	Returns a string representing the ranum v by stg(p,u).
	The string is as described in #vf, but will have a preceding minus sign if v
	was negative. If v is the overflow indicator, returns the string "Overflow".

 <#v#>  	( v -- p u )					'ltvgt'		rational hidden
	Returns the string(p,u) representing the rational number v. The string 
	is as described in #v (above), but will have a preceding minus sign if 
	v was negative. If v is the overflow indicator, returns stg "Overflow".

 f.j		( v n1 n2 -- )					'vdotfj'	rational
	display ranum v according to the rules described in <#vf#>. 
	The display string will be padded with leading spaces until there are n1
	characters before the point and padded with trailing spaces until there are
	n2 characters after the point. This allows numbers to be aligned about the
	point for display in tabular form. If there is no point in the string it will
	be padded with n2+1 trailing spaces for consistency. Trailing zeroes will be
	truncated according to the rules described in -re- {-zeroes}. If n1 is less
	than the number of characters to be displayed before the point no spaces will 
	be displayed, but the string will not be foreshortened. Therefore setting n1
	to zero will switch off right justification. If n2 is less than the number of
	characters to the right of the point no spaces will be displayed, but the
	string will not be truncated. If n2 is zero and places is also zero one
	trailing space will be displayed in lieu of the point. Therefore n2 should be
	-1 to switch off left justification, as this will inhibit all trailing spaces.

 f.		( v -- )					'vdotf'		rational
	display a rational number in floating point format as described in v.fj 
	but without left or right justification, and with one trailing space.

 v.j		( v n1 n2)					'vdotj'		rational
	display rational number v in fractioanl format, as described in <#v#> (above),
	padded with up to n1 leading spaces, and up to n2 trailing spaces, such that
	the number is justified about the space between the integral and fractional
	component, if present. If there is no integral component an additional
	leading space is displayed in lieu of the central space. If there is no
	fractional component an additional trailing space is displayed in lieu of the
	central space. No more than "digits" number of characters will be displayed
	in the numerator or denominator. n1 should be -1 to switch off leading spaces
	entirely, and likewise n2 for trailing spaces.

 v.		( v -- )					'vdot'		rational
	display a rational number in fractional format as described in v.f 
	but without justification and, with one trailing space.

 --
	

 vsqrt  	( v1 -- v2 )							rational
	v2 := sgn(v1) * square root of ranum |v1|.
	accuracy ok w/ less than 5 decimal digits, -re- {dvsqrt} for higher praecision.

 v^n		( v1 +n -- v2 )					'vpovn'		rational
	raise v1 to the power of non-negative sing n. v2 := ovf if n < 0.
	e.g, max e^n w/ n = 21.

 s>vfactorial	( n -- v )					's2vfac'	rational
	v := n!, v := overflow if not fitting into a single ranum (max n = 12).

 e^v		( v1 -- v2 )					'epowv'		rational
	returns approximation to e^x, where x is the rational number v1 | 6 > v1 > -6.
	Computed as 1st {#s!n} terms (dft 13) of power series; +/- 10^(-8) for |v| < 1.
	13 to {#n!v} is maximum for non-overflowing internal factorial calculations.

	
-- mixed, sing and double size

 vm*		( v v -- dv)					'vmmul'		rational
	multiply two ranums, generating double length result.

 qv>v		( qv1 -- v2 )			(4)		'qv2v'		rational
	reduce quad, qv1 to single cells size, v2.

================================================================
 l4sranum.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4string.inc>
--------------------------------------------------------------------------

================================================================
-- text acquisition, strings, search & substitution

	

	F8 type string is either one of
		standard string w. leading countbyte and max 255 chars.
		any length string enclosed by <nul> bytes,
			leading flag & trailing delimiter.
	some words operate only up to a certain maximum of bytes (4K), 
		-re- {place-size} for the limitation on {place}ing words.
	{type} is limited to 64K bytes.

 +blanks	( u1 u2 -- u1 p2 u2 )				'pblanks'	forth
	store count and u2:=min({pad-size}-1,max(0,u1-u2)) blanks to {here}, at 
	p2-1, ready to {type}. {pad-size} redefinable w/ uvari (padsz), dft 256.
	interpreting: { s" hallo" ] 20 +blanks type [ type } right justified.
	-re- {pad-size}, {(padsz)} and, {bl.r} which jumps into {type}.

 -trailing	( p1 u1 -- p1 u2 )		(fg)		'mtrailing'	forth
	cut trailing blanks and 'whitespace' off stg(p1,u1).
	'whitespace' in this context is <tab>, <del>, <bs>.

 zcount  	( p1 -- p1 u )			(e)				forth
	find length u of <nul> terminated strig at p1,
	ret u := 0 if p1 = 0

 count  	( p1 -- p2 u )					'ccount'	forth
	p2 := p1 or p1+charsize, u := string(p1) length; u := 0 if p1 = 0.
	{count} 1st checks whether leading byte is non-zero and returns, 
	else scans memory until trailing <nul> and returns asciz string's 
	character count. 
	NOT A SUBSTITUTE to { 1+ dup 1- c@ } -re- {c@+}; for instance, 
		{ bl word count } will fail on empty input!
	-re- {zcount} and ans-voc {COUNT}.

 COUNT  	( p1 -- p2 u )							ans
	p2 := p1+charsize, u := string(p1) length; u := 0 if p1 = 0.
	NOTE: implementation of 'characters' may change for unicode, etc, thus neither
	variant of {count} should be (ab)used to substitute { 1+ dup 1- c@ } - re c@+

 blw    	( -- p )			(k)		'BLWORD'	novoc
	does{ ans bl word }

 word		( c -- p )			(4)(a:c)(x)	'XWORD'		forth
	scan input source for max 255 chars of text sequence enclosed by chars c.
	returns ptr p to 4th-strg. a blank, not included in length, follows the string.
	programs may replace characters within the string. this is the ANS-style {word}

 blword  	( -- )				(k)(4)(x)
	does{ bl word }

 word		( c -- )			(4)((x))	'xword'		fig
	scan input source for text sequence enclosed by chars c, max len 255.
	fig version, returns counted stg to {here}, where it may be modified.

 parse  	( c -- p u )			((x))				forth
	ret ptr p to before next occurrence of char c in current 
	input buf. after disp of {in@}, adjust {in} by +u.
	if c=<bl> find any delimiter <bl> or ctrl-code 0..31

 enclose	( p c -- p n1 n2 n3 )						fig
	separate by char c enclosed text in max. {#tib} chars at ptr p+
	ret n1 disp to 1st char =/= c, n2 next char = c, n3 next char
	ans stg then { drop over - rot rot + swap }

 enclose	( p u c -- p n1 n2 n3 )				'enclose4'	forth
	separate by char c enclosed text in max. u chars at ptr p+
	ret n1 disp to 1st char =/= c, n2 next char = c, n3 next char
	ans stg then { drop over - rot rot + swap }; w/ char = byte.

 zblcount	( a1 -- a1 u )			(k)(X)
	cnt string length until ctrl code or <bl>
	does{ -1 bl parsec }, for {[number]}

 parsec  	( p1 u1 c -- p1 u2 )		(X)				forth
	push length of char c or <nul> terminated string,
	up to +u chars parsed from address p1, @in not modified
	if c=<bl> find any delimiter <bl> or ctrl-code 0..31

 skip		( p u c -- p' u' )		(83)				forth
	skip leading chars = c of length u string at ptr p,
	ret posn p' of 1st char =/= c and remaining cnt u'.
	scan string length u string at ptr p for 1st occurrence of char =/= c.
	specific handling of <bl> including low ctrl-s if c = 0000<bl><bl>

 scan		( p u c -- p' u' )		(83)				forth
	scan string length u string at ptr p for 1st occurrence of char = c,
	ret posn p' of 1st char = c and remaining cnt u'.
	ret u' = 0 and ptr to after stg if dlm not found.
	skip leading chars =/= c of length u string at ptr p
	specific handling of <bl> including low ctrl-s if c = 0000<bl><bl>
	(e: flags reflect value of u)

 csearch 	( p1 u1 p2 u2 c -- p3 u3 flg )	(4)				forth
	{search} in mem(p1,u1) by char c terminated trailing string(p2,u2).

 search  	( p1 u1 p2 u2 -- p3 u3 flg )	(a:s)				forth
	search u1 bytes beginning at p1 for string(p2,u2).
	ret p3 where string found and u3 remaining chars cnt w. true flag,
	else p3=p1, u3=u1 and false flag.
	-re- {csearch}, additionally checking terminating char.

 s=		( p1 u1 p2 u2 -- n )				'seq'		forth
      compare case dependently, regardless of uc-.. setting.

 compare	( p1 u1 p2 u2 -- n )		(a:s)				forth
	compare strings (p1,u1) and (p2,u2) by subtraction of character code
	in stg2 from char. code in stg1 at the rsp. position. assume stgs 
	terminated by a <nul> byte, while comparing, for deriving the result.
	letter case dependency obeyed as set by lc-depend/ignore.
	return n:
		1: s1>s2, -1: s1<s2, 0: s1=g2
	i.e. difference of 1st different chars determine flag, else length.
	

 rskip  	( p u c -- p' u' )		(83)				forth
	skip trailing chars = c of length u string at ptr p,
	ret posn p' of 1st char =/= c and remaining cnt u'.
	scan string length u string at ptr p for 1st occurrence of char =/= c.
	specific handling of <bl> including low ctrl-s if c = 0000<bl><bl>

 rscan  	( p u c -- p' u' )		(83)				forth
	reverse scan stg(p,u) for last occurrence of char c,
	ret posn p' of 1st found char = c and remaining cnt u'.
	ret u' = 0 and ptr to stg p' = p if dlm not found.
	skip trailing chars =/= c off stg(p,u).
	specific handling of <bl> including low ctrl-s if c = 0000<bl><bl>

 /string	( p u n -- p1 u1 )		(a:s)(e)(4)	'sstring'	forth
	adjust string at p by +n and len u by -u,
	subtracts n from u @tos and adds n to p @nos, unless @tos < 0.
	+ve n truncates string(p,u) from beginning towards end, min. u1=0,
	-ve n extends string ptr p and length u beyond its beginning.
	(e: flags reflect length result)

 1/string	( p u -- p1 u1 )		(e)		's1string'	forth
	cut 1st char (byte) off stg(p,u); short for { 1 /string }.
	(e: flags reflect length result)

 cslice  	( p1 u1 c1 c2 -- p2 u2 p3 u3 )	(4)				forth
	stg slice by delimiting chars, return remaining stg(p2,u2) and slice(p3,u3).
	neither ret-stg includes the delimiters, remainder begins after end-delimiter,
	-ve character code may be passed for the rsp. stg bound, start or end.
	adjust slice w/ { -1 /string 1+ } to including the delimiting chars.

 sslice  	( p1 u1 p2 u2 p3 u3 -- p4 u4 p5 u5 )				forth
	stg slice(p5,u5) enclosed by stg(p2,u2) and stg(p3,u3), remainder(p5,u5).
	sliced stg does not include the delimiters, remainder begins after end-delimiter,
	zero length stg-s may be passed for the rsp. stg bound, start or end.
	adjust slice w/ { u2 negate /string u3 + } to including the delimiting stg-s.

 bslice  	( p1 u1 n1 n2 -- p4 u4 p5 u5 )					forth
	get stg slice(p5,u5) and remainder(p4,u4) by char(byte) positions n1,n2.
	sliced stg includes both, the byte positions n1 and n2.

 substitute	( p1 u1 c1 c2 l1 l2 p2 u2 -- p3 u3 n | abort )(4)(x)		forth
	Recursive, multiply nestable string substitution/text translation.
	in:	(p1,u1)	source stg
		c1, c2	start-/end-dlm
		l1, l2	ptr to reference-/substitution-list
		(p2,u2)	workspace, for result stg
	out:	(p3,u3)	stg result, in buffer(p2,u2)
		n	count of substitutions
		abort	if resolved stg doesn't fit in {place}, {+place} limits.
	Recursively extract stg within innermost delimiters(c1,c2) in stg(p1,u1),
	search list(l1) for extracted unique counted or <nul> terminated string 
	and substitute with <nul>-enclosed stg at corresponding posn in list(l2).
	The empty stg can be simulated w/ "<bl><del>", in substitution list.
	store modified string to buf. (p2,u2),
	ret counted stg(p3,u3) and flag n := count of substitutions done
	or, n=0 and p3:=p1, u3:=u1 if no refs found.
	Abort if {place-size} or storage space u2 exceded.

 replace	( p1 u1 p2 u2 p3 u3 n p4 u4 -- p5 u5 f)				forth
	replace one text in a string by another text.
	letter case dependency as previously set, temporarily being forced to 
	case-dependency if source & replacement text would otherwise be equal.
	
	in:	(p1,u1)	source string;
		(p2,u2)	text to replace by..
		(p3,u3)	  ..replacement text;
		n	operational mode flag (re below);
		(p4,u4)	ptr p4 to buffer of size u4, stg and buffer space may be identical.
	out:	(p5,u5)	stg result - NOTE: not a "counted" stg!
			convert replaced to counted stg e.g. { drop over place };
		f	result flag (re below).
	
	n >  0	replace n-th occurrence of text(p2,u2) in stg(p1,u1) by text(p3,u3).
	n =  0	count text(p2,u2) occurrences, w/o any actual replacement.
	n = -ve replace any occurrence of text(p2,u2).
	f := n	ret flg & counted stg(p5,u5), stored to buf(p4,u4). p5:=p4 and
		 u5:=u4,  f:=-1 if initially unsufficient buffer size;
		 u5:=len, f:=-ve no. of replacements done, if next wouldn't fit;
		 u5:=0,   f:= 0 if stg(p1,u1) is empty (u1=0);
		 u5:=u1,  f:= 0 if stg(p2,u2) not found in stg(p1,u1);
		 u5:=len, f:= n if replacement done.

 c>lower	( c1 -- c2 )					'c2lower'	forth
	convert char c1 to lower case character c2, char = byte, -re- {s>lower}.

 c>upper	( c1 -- c2 )					'c2upper'	forth
	convert char c1 to upper case character c2, char = byte, -re- {s>upper}.

 s>lower	( p1 u1 p2 u2 -- p3 u3 )			's2lower'	forth
	convert stg(p1,u1) to all lower case characters (per byte),
	buf-size expected to provide for chars and terminating <nul>.
	using conversion table { (hi>lo) @ }, no conversion if zero entry.
	ret stg(p3,u3) in buf(p2,u2). u3 = 0 if u2 not > u1.
	if (p1,u1) writable, source and buf may be same area w/ p2:=p1, u2:=u1+1.
	char conversion tables by dft from iso-8559-1 charset data arrangement, i.e.
	upper case ranges [65,90] and [192,222], lower case in [97,122] and [224,254],

 s>upper	( p1 u1 p2 u2 -- p3 u3 )			's2upper'	forth
	convert stg(p1,u1) to all upper case characters (per byte),
	buf-size expected to provide for chars and terminating <nul>.
	using conversion table { (lo>hi) @ }, no conversion if zero entry.
	ret <nul>-terminated, un-counted stg(p3,u3) in buf(p2,u2). 
	u3 = 0 if u2 < u1.
	if (p1,u1) writable, source and buf may be at same address.
	char conversion tables by dft from iso-8559-1 charset data arrangement, i.e.
	upper case ranges [65,90] and [192,222], lower case in [97,122] and [224,254],

 printing?	( p u -- f )					'printingq'	forth
	tf if stg(p,u) contains no other than printing chars, incl. <nl> or <tab>.
	u=0 returns true flg (nothing to print is considerd always 'printable').
	using -re- {ekey>char} per stg bytes.

 e\stg  	( p1 u1 p2 -- p3 u3 )				'estg'		forth
	convert stg(p,u) w/ escaped tokens to stg(p3,u3) at buffer (p2).
	converted stg is never longer than source, thus buffer expected 
	at least u1 chars of size, and not checked. p2 not in stg memory!
	the escape symbol is re-definable in uvari {(escc)}, dft "\", 
	other chars may follow which receive special treatment:
	numeric:
		\nnn	character code, octal numeric sequence as valid for a forth 
			single integer, any other radix w/ the appropriate praefix.
			-re- {[number]}, for instance,
				s" hick\46"	displays	hick!
				s" hick\#33"	does the same, w/ decimal code
	special symbols, letter case dependent:
		\a	<bel>
		\b	<bs>
		\c	w/o trailing <lf> - suppressed, not applicable
		\e	<esc>
		\f	<ff>
		\i	<csi>
		\n	<new line>
		\r	<cr>
		\t	<ht>
		\v	<vt>
		\\	double escape symbol, sending the escape symbol as a char.
	

 ----------------------------------------------------------------
-- {blanks}, {cmove}, {cmove>}, {erase}, {fill}, {move}, {place}, {spaces}
	character is size and cnt is number of 8bit bytes.

 place-size	( -- n )			(c),m,6)	'placesize'	forth
	biggest string size which {place}, {+place} can generate; cpl'd dft 4K.

 place  	( p1 n p2 -- )			(a:?)				forth
	copy stg(p1,n) to byte-counted stg at p2. n limited to -re- {place-size}.
	store <nul>+asciz stg if count > 255, i.e. leading and trailing <nul>.
	buffer at p2 unchanged if n < 1.

 +place 	( p1 n1 p2 -- | abort )		(f6)		'pplace'	forth
	+n1: append stg(p1,n1) to byte-counted stg at p2 or,
	-n1: prepend byte-counted stg at p2 by stg(p1,-n1).
	counted stg if len < 256, else stored w. leading <nul> byte, for asciz.
	forcedly storing a <nul>-enclosed string if state-flag <asciz> is set.
	in either case, dstn stg will be <nul>-terminated.
	abort if accumulated length > -re- {place-size}, old len recovered in +n case. 
	( for safety, stg result length limited to max(PAGE_SIZE,PATH_MAX), which can be
	( changed by re-compiling w/ a modified value of <pthfsize> -re- "constants.inc".

 move		( p1 p2 +n -- )							forth
	non-overwriting copy +n bytes from p1 to p2, noop if n < 0.

 cmove>  	( p1 p2 +n -- )					'cmovegt'	forth
	copy +n bytes from p1 to p2, beginning at high address
	no action if n = zero or -ve; data copying by bytes.

 cmove  	( p1 p2 +n -- )			(fg)		'xcmove'	forth
	copy +n bytes from p1 to p2, beginning at low address.
	faster than {cmove>}, copying by 32bit items if appropriate.

 erase  	( p +u -- )							forth
	store +u <zero> bytes to memory beginning at ptr p

 blanks  	( p +u -- )			(fg)				fig
 blank  	( p +u -- )			(fg)(a:stg)	'blanks'	forth
	store +u <bl> characters (8bit-bytes) to memory beginning at ptr p.

 fill		( p +u c -- )			(fg)				forth
	store +u (8bit-)bytes c to memory beginning at ptr p
	optimizing to 32bit items if count and destn at cell bounds.

 >move< 	( p1 p2 +n -- )					'movex'		forth
	copy n>0 bytes from p1 in reversed order to p2, w/ unrestricted range p1,p2.

	
--------------------------------------------------------------------------------
 

 path+file	( pe ue pf uf pb ub -- pp up | xx 0 )		'pthfile'	linux
	find file w. name (pf,uf) in PATH supplied by string(pe,ue).
	search cwd, only if file-name(pf,uf) begins w/ "./".
	search HOME-dir, only, if file-name(pf,uf) begins w/ "~/".
	put found absolute path and name stg(pp,up) into buffer(pb,ub),
	ret empty stg, up = 0, if no such file found.
	stg result length limited to size of Linux PATH_MAX (4K).
	-re- {f"}, {fname"}, {[fname]} which search {f8dir} and {path}.
	examples:
	  s" /devfs:/dev" s" tty" pad 200 path+file
		path to current kbd console, whether "devfs" active or not.
	  path s" util.f8" pad 400 path+file
		path to 'nearest' f8-utils files (or directory).
	NOTE:
	  path not taken from env-vari, for security reasons but,
	  HOME env-vari read if passed filename begins with '~/'.

	
 -- strings

 stg		ccc( p u n -- )(X: -- p u )	(4)		'stg4'		forth
	define a string value w/ at most n characters of storage space.

 to-stg	ccc( p1 u1 -- )			(i)		'stgs'		forth
	store stg(p1,u1) into string variable ccc.

 +to-stg  	ccc( p1 u1 -- )			(i)		'stgps'		forth
	append stg(p1,u1) to string variable ccc.

 :slist 	ccc( -- )(X: -- p )		(4)		'colslist'	forth
	initiate a reference/substitution list for {enum@}, {enum#}, {substitute}.
	constitute a list of stg-s w/ -re- {slist"}, {slist}, {slist,}, {slist;}.

 slist" 	ccc( -- )			(4)		'slistqte'	forth
	fetch by char {"} enclosed stg ccc and cpl to data-space for ref/subst-list
	overwrites {pad2} if executed in interpreting mode. -re- {:slist}.

 slist  	c ccc( -- )			(4)		'slists'	forth
	fetch by char c enclosed stg ccc and cpl to data-space for ref/subst-list.
	overwrites {pad2} if executed in interpreting mode. -re- {:slist}.

 slist,  	(C: p u -- )			(4)		'slistc'	forth
	cpl <nul>-"counted" stg w/o trailing <nul>, add stg(p,u) to ref/subst 
	list. overwrites {pad2} if executed in interpreting mode. -re- {:slist}.

 slist; 	( -- )				(4)		'slistsemi'	forth
	terminate addressable list of stg-s. -re- {:slist}.

 szlit, 	( p u -- )					'szlitc'	forth
	allot u+2 bytes and store <nul> delimited string(p,u) to here.

 slit,  	( p u -- )					'slitc'		forth
	allot u+2 bytes and store counted string(p,u) to here.
	always <nul> terminated, whether counted or asciz stg.

 sliteral	(C: p u -- )(X: -- a u)		(i)(a:s)			forth
	compile a string passed into a colon definition

 szliteral	(C: p u -- )(X: -- a u)		(i)(a:s)			forth
	compile an asciz unlimited length string into a colon definition

 ."		ccc( -- )			(i)(4)		'dotquote'	forth
	display counted string literal
	compiling:	stores 4th-string to {c-here}
	execution:	displays 4th-string from [IP]+
	interpreting:	copies 4th-string to {pad2}+

 s"		ccc( -- p u )			(i)		'sqte'		forth
	counted string literal, p := {pad2} when interpreting

 string	c ccc( -- p u )			(i)		'stng'		forth
	by char c delimited counted string ccc literal, p:={pad2} when interpreting.
	use{ string <char> <text><char> } e.g. { string ! hallo! type } displays <hallo>.

 z"		ccc( -- p u )			(i)		'zqte'		forth
	unlimited length asciz string literal, p := {pad2} when interpreting
	stg length actually limited by {word} which truncates after 255 bytes,
	use {szliteral} to compiling longer asciz string literals:
	{ [ stg1 count pad place stg2 count pad +place pad count ] szliteral ... }

 name		ccc( -- p u )			(i)				hidden
	fetch a <bl>-enclosed name from input stream to {here}
	cpl only: immediately overwritten while in interpreting mode

 "		ccc( -- p )			(i)		'qte'		forth
	counted string literal, p := {pad2} when interpreting; synonym {c"}

 c"		ccc( -- p )			(i)(a:ce)	'qte'		forth
	counted string literal, p := {pad2} when interpreting

=====================================================================;
 l4string.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/l4struc.inc>
--------------------------------------------------------------------------


================================================================================;
 multi-tasking

	

 struc jargs
	initial data on stack for sys_clone call
 	.ur:uref	; 1st 3 items popped after syscall
 	.kr:kref
 	.nt:entry
 	.ac:argc	; count begins here
 	.np:nameptr
	next two dwords should be zeroed or, stack set up to additional 
	args requirements - <jargs_size> is minimum!

 Wordheaders structures (as of lib4th 0.0.47)

 names headers & linkage, pointers at dword aligned address,
 entries signed 32bit dword items, unless stated,
 basic structure as set up with <struc whead>, below.

 linkage by +ve displacements such that
		linkfield dup @ -
 points to preceding lfa.

 standard 4th word:

 ifa,	index field, 16bit word
		index	unsigned 16bit index into u.o.t.
 ffa, flags field, 16bit word
		flags	4th compileflags, re <constants.inc>
 mfa,	macro field
		ms. word
		cmac	top bit set: word can compile inline code (macro)
			bits 14..0	disp of label to macro code
		ls.word 		count of code length
 lfa,	linkfield
		link	+ve displacement to preceding words link pointer posn
 nfa,	name field
		name	byte counted asciz string,
			with <nul> bytes filled up to before dword aligned posn
 pfa,	parameter field
		doword	code entry in execution segment wrt. <wordbot> reference,
			pre-compiled modules can thus be loaded anywhere and linked 
			by adjusting the pointers with a constant disp supplied 
			by nature of extension, at no cost of additional data.
			code relocation is done by means of inserting relocated
			execution addresses to uot and further adjustment to
			where uot access occurs in the module.
 extendability/compiler not implemented in this version,
 relocation info might follow, with another F8 version...

 vocabulary:

 defined by two consecutive standard forth words:
 	1st the vocabulary word as the above pattern, w. vocf set.
	2nd extension word
		where the execution pointer is replaced by the
		lfa-s displacement value to currently latest word
		in vocabulary to vocabulary's own, 1st word header.
	vifa, index field
		dword +ve disp to primary header's lfa
	vmfa, macro field
		dword vocabulary linkage, +ve disp to previous vmfa,
		last lfa goes to {voc-link}
	vlfa, link field
		zero, base lfa of this voc's wordlist
	vnfa, name field
		unique, dummy name {1,' ',0,0}
	vpfa, parameter field
		toplink, +ve disp to vlfa of top lfa in voc

 voc-link:
	voc-link disp points to latest 2nd-ary voc-lfa
	which is linked to preceding voc, until disp=0.

 kernel-vocs:
	root and forth pre-defined, voc-link points to auxilary link
	at dataspace beginning, re below, "RAM linkage".
	@c0	.-- dataspace --.	initial {here}
		    1st vhead (root)	copy of 2nd-ary wordheader
		    2nd vhead (forth)	..
			other data	\ following voc. linkheaders
		    3rd vhead		/ may be mixed with other data
 module:
	kernel wordlist may serve as an example, re "lib4words.inc".

 	1st standard wordheader as above pattern
		lfa is respective <wordbot> to which all execution 
		pointers supplied with this modules wordlists refer.
	2ndary, vocabulary type extension header w. additional description
	mlst, dword
		+ve disp wrt 1st to last lfa in module, for {last}
	mtop, dword
		+ve disp wrt 1st to last vlfa in module, for {voc-link}
	any number of any type wordheaders may follow.

	words initially linked to {current},
	modules may define sub-vocabularies and wordlists.
	2nd-ary of 1st header may be a dummy, after non-vocabulary word, 
		providing disp to last wrt 1st lfa within module.
	xec-ptrs within module refer to 1st lfa,
	data-ptrs of 2ndary pfa refer to beginning of data memory, @d0.
	nasm deficiencies require modules descriptions positioned last in 
	a module, after the actual code. this is not a lib4th requirement.

 RAM linkage
	Wordlists when extending into alterable data memory will be linked 
	via an intermediate dummy header of 2nd-ary vocabulary headers type,
	vifa
		+ve disp pointing to the primary vocabulary header
	vlfa
		+ve disp to this wordlists previous toplink
	vpfa
		new toplink, updated by new words definitions.

	

 struc whead
	primary word header. (w) is 16bit item.
	when referring to this struct take variable names length into account!
 .i:	C{name}:	ifa (w)	uot index
 .f:			ffa (w)	compileflags, l.s.nibble xtn fields count
 .m:			mfa	macro flags&count
 .l:	L{name}:	lfa	linkfield, wordlink
 .n:			nfa	countbyte, min. length
			3 < namelength < 256, <nul> padded to dwords bounds.
	variable ptr-s follow, dependent on name length:
 .x:			pfa	one cell after nfa is min. posn of execution ptr
			{>body} returns ptr to data-space, past <pfa> - re below.
 .p:			body	.n+aligned(min(max(8,namelength+5),260))
			at 4-aligned 4+(3 < disp = namelength+1 < 257) from nfa.
			contains xec-ptr wrt this address, <zero> in uot for <pfax> words.
 .e			- end of this <struc> -
			additional fields the no. of which is ((@ffa&&xwfl)-1) may follow.
 .b			<pfax>-words disp to vari space
	+4		<inf> init entry
	+8		other data, e.g. {defer}-actions, etc.

 struc vhead
	vocabulary 2ndary header, {wordlist} basic structure.
 .i:			vifa	disp vlfa to word header lfa of vocabulary
 .m:	V{name}:	vmfa	<wid>, voclink
 .l:	B{name}:	vlfa	base lfa of wordlist linkage (0)
 .n:	{name}vnfa:	vnfa	4 bytes dummy name, vocnfa: 1,<bl><nul><nul>
 .p:	{name}top:	vpfa	disp to top lfa of this voc's wordlist

 struc mhead
	module 2ndary header (by 2 dwords extended 2ndary vocabulary header)
 .i:			vifa	disp to word header lfa
 .m:			vmfa	voclink, disp to previous voc-link, init. 0
 .l:			vlfa	initial link (0), modules base ref of execution ptrs
 .n:			vnfa	4 bytes dummy name, vocnfa: 1,<bl><nul><nul>
 .p:			vpfa	disp to top lfa
 .s:			mlst	disp to last lfa in module
 .t:			mtop	disp to last voc-link in module

 struc fgtlink
	forget handler linkage field
 .lfa:  		flfa	link address
 .ixw:  		fwrd	word by ix, which the datafiled is assigned to
 .ixh:  		fhnd	word by ix, which will be executed immediately 
				before <fwrd> being removed by {forget}.
				<fhnd> receives ix of fwrd on @tos, which item 
				may be changed but must remain on stack.
	
 struc casec
	'cnum' list header, for {associative}, {case:}, {range:}

	

================================================================================;
 application data, program setup

	

 struc i4th	re macro i4th_ntry in <lib4th.mac>	-not used-
	lib4th setup, initial data passing structure, from L4 app. by EDI reg.
	defaults used for <zero> items				(dft.)
	.ntry		inital execution entry true address	(quit)
	.bootp		ptr to supplied boot parameters, loadfile/data
	.dstack		size of datastack			( 64K)
	.rstack		size of returnstack			( 64K)
	.tibmem		size of t.i.b.				(  4K)
	.uarea		size of user-vari and uot area, min 64K	( 64K)
	.cplmem		size of compilespace			(128K)
	.datamem	size of dataspace (and word-headers)	(  64K, extendable)
	.jobstk		minimal word executing jobs' stacks	(   2K)
	.jobss		minimal i/o & compiling jobs .ss, plus jobstk
	.jobbss		minimal i/o & compiling jobs .bss section
	.e		-1 marker value for end of structure

================================================================================;
 resources management

	

 -- file access

 struc cdt
	channel definition table
 .chid  0  	file descriptor
 .chpt  4	ptr to extension field (yet empty)
 .iofl  8	io flags
 .acfl 0c 	access flags from open
 .perm 10 	file permissions
 .rnum 14 	latest op error code
 .fpos 18 	current file pointer, 64bit (2.4 kernel)
 .ibuf 1c	single char input buffer
 .bbuf 20	ptr to blockfiles buffer (n.i., requires memory management)

 struc buffers - n.i.
	pointers, flags, linkage for blockfile buffers, per file linkage base
 .l		circular link, to next buffer or self if single buf
 .u		(ptr to buffer space -?-)
 .n		latest used buffer
 .c		file channel the rsp buffer chain is assigned to

 struc blkbuf
	screenfile block buffer ptrs
	[ link ][ (reserve) ][ owner-file fd ][ no. of blocks ] [[ updt|blk# ][ disp to blk ] ... ]
 .l		circular link, disp to next blockptr, -re- {block-lk}
 .u		- (yet unused) -
 .c		file channel this buffer is assigned to
 .b		no. of blocks in this buffer (4)
 .f		2 cells per block: block number & update flag, disp to rsp. block (8)

 struc blkhead
	block header per buffer in block of screenfile buffers
 .u		file-block number, bit#31:update-flag, bit#30(n.i.):interpreter input
 .d		pc-rel disp to buffer

 -- memory

 struc hphead		( => 'under construction...')
	heap memory allocation block header
	[ len ][ drivr ][ owner ][ rflag ]
	<zero> entries indicate a noop, struc. may be extended by other handlers
 useage for
	reserved system heap:
	.len		size, header inclusive
	.drivr  	used heap blocks chain: ptr to handler link address
	.owner  	pid of allocating job, 0 if block unused
	.rflag  	ptr to follow-up block wrt .rflag address, 0 at end of chain
	available system blocks:
	.len		size, header inclusive
	.next		ptr to next free heap address, 0 at end of chain
	.owner  	0
	.rflag  	0
	user heap:
	.len		size, header inclusive
	.drivr  	ptr to handler link address
	.owner  	pid of owner job
	.rflag  	ptr to flagbit to set when block removed, or 0
	available user heap:
	.len		size, header inclusive
	.next		ptr to next free heap address, 0 at end of chain
	.owner  	0
	.rflag  	0

 struc handler
	full size handler defn. block
	link and ptr-s to resources management routines and simple devices
 .lio		linkage
 .aio		address of i/o routine
 .aopen  	address of allocation routine
 .aclos  	address of cancelling routine

--------------------------------------------------------------------------------;
 heap header extensions

	

 struc console4	(n.i.)
	i/o window definition block
 struc screen4 = console w/o <console.queue> item
	non-input window definition block
	

================================================================;
 l4struc.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4sys.inc>
--------------------------------------------------------------------------

 allocf	(bytes oldtop -- newtop|ernum )	(k)
	page align and allocate memory in .bss/RAM

 allocjob	( -- newtop|ernum )		(k)
	page align and allocate memory in .bss/RAM
	setup for a 'standard' job, after <stacksini> - new layout w. 0.0.61:
 .ss		returnstack	top down,		64K
		datastack	bot.up,			64K
		tib		terminal input buf.	 4K
		user-vari	top down, variable size	64K
 .bss		dataspace	bot.up, variable size
		codespace	bot. up			64K

 <allocbss>					(s)
	page align size and bounds, allocate memory in .bss/RAM
	syscalls brk & mprotect -re- man 2 brk, mprotect
 <heaphead>						(k)
	clear memory block, store initial 'heap' structure
	len should be multiple of PAGE_SIZE,
	l.s. 2 bits: bit #1 is no-clear-flag if set
	[ len ][ handler ][ owner ][ flagptr ] at eax
	[ ecx ][ mmrechp ][  pid  ][    0    ] initial values

 <ustkini>
	initiate .ss range: stacks, tib, user-vari
 <ustkini.n>
	i: eax := accumulated size
	o: eax := .ss bottom
	   ecx := page aligned size

================================================================
 -- hi-level accessible words

================================================================
 -- kernel support, non-standard and f8 or system specific routines
 -- register addressed primitives

	any lo-level routines must save or set appropriately, rsp:
		ebx	kernel reference pointer
		edi	parameter stack
		esi	local dataspace base ptr
		ebp	user vari reference pointer
		esp	returnstack
	

 -- partially or uninitiated support routines,
	may be used but are not intended for hi-level access!

 stty-s  	( c -- er ) 					'sttys'		linux
	set console channel c to known state - Linux "stty sane"

 rstty  	( -- )								linux
	reset {work}-channel console to initial state,
	called once, with {bye} or when job/thread(?) killed
	<uref> expected valid.

 otty		( -- )								linux
	open & init r/w channel to current console
	on succes store fs to stdin cdt, close previous stdin
	all regs preserved, ernum from open attempt in (ierr)
	NOTE:	open when input was file after program termination 
		leaves console in nowait and no-echo state -> why?

 setty  	( -- )								linux
	prepare stdin to single key input,
	called once on init after intro,
	de-activated by byte @uv.aux =/= 0, set to -ve afterwd.
	can be executed to restoring tty state e.g, after a -re- {sh}ell command
	<uref> expected valid, but NO <kref>'d code
	all regs preserved

 fcntl  	( p op ch -- ernum )		(e)		'cfcntl'	linux
	fcntl system call
	p:=ptr to data structure, op:=fcntl operational flag, ch:=i/o channel
	(e: S on error)

 ioctl  	( p op ch -- ernum )		(e)		'cioctl'	linux
	ioctl system call
	p ptr to data structure, op ioctl operational flag, ch i/o channel.
	NOTE:	console ioctls are not that useful, though they could, in a more 
		reasonable implementation. many of those nice features are simply 
		useless because the settings affect #all# consoles, globally...
	(e: S on error)

 cstg		( n1 n2 -- p u )						linux
	index list# -- ptr count, u := 0 if n1,n2 out of range
	index 0..3 for terminal control:
		0:ctrls, 1:F-console, 2:F-xterm, 3:colours by [ ctrl stg <nul> ]
	{ 0 4 cstg } returns ptr & sum of length's of syscalls names
		by items of [ 16bit number | chars name <nul> ]
	{ 0 5 cstg } returns ptr & sum of length's of colour-strings
		asciz names in sequence of the rsp. numbers, for "sys".
	
	0 ctrl termcaps
		ho,le,nd,up,do,cl,cd,ce,bl,dc,dl,sf,sr,so,se,us,ue,md,
		mr,mb,me,blink off, reverse video off,xy,ris,sc,rc
	1 console termcaps
		k1,k2,k3,k4,k5,k6,k7,k8,k9,k0,kl,kr,ku,kd,kh,kH,kN,kP,kb,kD,kI
		F11..F20 is <\e[23~> ... <\e[34~> - \e[22~ apparently unused(?)
	2 xterm termcaps
		k1,k2,k3,k4,k5,k6,k7,k8,k9,k0,kl,kr,ku,kd,kh,kH,kN,kP,kb,kD,kI
	3 colours
		fg: black,red,green,brown,blue,magenta,cyan,white,underscore-on,-off
		bg: black,red,green,brown,blue,magenta,cyan,white,default,default

 (sys)  	( p u -- n | er )				'psysp'		linux
	fetch syscall-no. n by name(p,u)
	all linux 2.2 and 2.4. syscall names implemented.

 sys		ccc( p -- er )			(i)				linux
	xec/cpl literal syscall by name ccc -re- {syscall}, {(sys)}, {[sys]}
	rejects <sys mprotect> - re {mprotect}.
	example:{ pad 0x200 2dup erase over 4th>abs sp@ sys uname 3drop dump }
	NOTE:	{ 0 1 sp@ 4th>abs 0 swap sp@ sys nanosleep } kernel 2.2.19 requires 
		different ptrs for nanosleep, which might apply to more syscalls.

 [sys]  	( p a -- p er )			(i)		'bsysb'		linux
	execute syscall by name at <a> with register values at addr. <p>
	rejects <sys mprotect> - re {mprotect}.
	example: { 0 1 sp@ 4th>abs dup sp@ s" nanosleep" [sys] }

 syscall	( p n -- p er )			(mc)		'scall'		linux
	executes OS specific system call n, returns value/error code in er,
	syscall parameters from table at p, p pointing to top item in list:
		lo:[ ebp, edi, esi, edx, ecx, ebx ]:hi addr
	<ebx> corresponds to 1st arg in the rsp man(2)-pages description.
	sequence of pushed to return-stack arguments is in same order as "C" 
	functions parameter lists  but, wrt a structure in memory or, the L4 
	data-stack which grows towards higher addresses, the arguments should
	 be passed in reversed order, i,e. "right to left". -re- {sys}.
	
	NOTE:	addresses expected by true values, as after {4th>abs}.
		{syscall} rejects call to <SYS_mprotect> - re {mprotect}.
	
	example f8-forth access, all arguments but eax and sp@ are optional, 
	dependent on the rsp. system call:
		( edi esi edx ecx ebx sp@ eax -- edi esi edx ecx ebx eax2 )
	where eax2 is result, replacing the passed syscall number from eax on entry.
	for instance, reading a directory entry (file open, channel in work-id):
		{ 0x100 pad 4th>abs work-id sp@ #141 syscall }
	Further reading:
		Linux system calls libc access documentation in <man> section 2,
		numbers vs names, asmutils <os_linux.inc>, <linux/include/unistd.h>.
		http://home.snafu.de/phpr/lhpsycal.html (syscalls doc, en)

 argstg 	( u1 -- p u2 )							linux
	get program's passed asciz argument strings p,u2 by number u1.
	cnt begins at 1, 0 for program name. ovf & -ve returns <zero>

 envstg  	( u1 -- p u2 )							linux
	get ptr to program's asciz environment strings by number u
	cnt begins at 1, 0 and overflow return empty stg.
	program name is asciz string at { (argp) @ @ abs>4th }.
	display all env strings:
	{ -1 1 rshift 1  do i envstg dup if type cr else 2drop leave endif loop }

 path		( -- p u )					'epath'		forth
	ret ptr to string of PATH environmental variable.
	alternatively, fetch <nul>-terminated stg from @(path) if non-zero.

 --env-ini	( -- )								system
 f8ini   	( -- )								system
	evaluate F8INI environment variable. active word in {system} wordlist!

 term		( -- p u )					'eterm'		linux
	ret terminal type from TERM env-vari

 getenv  	( p1 u1 -- p2 u2 | p1 0 )	(4)		'gtenv'		linux
	get ptr p2 and cnt u2 to program's environment strings by name at p1,u1
	p2,u2 ptr to empty stg & u2 := 0 if env-vari name not found.
	searching case-in/dependently, as set w. {lc-depend} or {lc-ignore}.

 .cpu		( -- )						'dotcpu'	forth
	display actual host system cpu type

================================================================
 -- execution

 bye		( -- )				(s)(w)				root
	exit program, exitcode 0
	syscalls exit, getgid, kill, write -re- man 2 ...

 bye-r  	( n -- ) 			(s)		'byer'		linux
	display pid & message if n<0
	terminate and pass exitcode |n| to caller.
	syscalls -re- {bye}

 <byes>  	(R: x r -- )			
	exit by signal hnd invocation, ret signum

 <intro>					(k)(u)
	display startup message to STDERR
	do nothing if not stdin and stdout at console or, if any args pssed
 o:	eax	:= 0x80000000
	eflags	Z: stdin is console, S stderr not writable

 sigmsg  	( x -- x )			(s)(u)				linux
	display signal message to STDERR if -ve x in range
	syscall write -re- man 2 ...

 kerror  	( x -- )			(s)(k)(u)
	print message to STDERR if -ve x in range, else do nothing
 o:	eflags	set accordingly

 <terror>					(s)(u)
	exec <error> without referring to PS, uninitiated call

 kmessage	( x -- +x )			(s)(u)				hidden
	print to STDERR, message no. @tos, if -ve x in range
	flags & all regs but W, <ecx>, preserved, KR restored/set
	syscall write -re- man 2 ...

----------------------------------------------------------------
	

 push4th	( -- )(R: -- LP UR SP KR )					system
	save (true) cpu regs used by kernel: KR (ebx), LP(esi), SP(edi), UR(ebp).
	supposed to preserving L4 state e.g, for usage w/ external libraries.

 pop4th 	( -- )(R: LP UR SP KR -- )					system
	restore cpu regs which were saved to returnstack -re- {push4th}

 cpuid  	( n -- na nb nc nd )				'cpuidf'	system
	clear/sync cpu state.
	fetch level(n) register values eax..edx of <cpuid> instruction.

 emms		( -- )				(m,2)		'emmsf'		forth
	clear mmx cpu registers

 femms  	( -- )				(m,2)		'femmsf'	non-mmx
	clear floating point cpu registers

=====================================================================;
 l4sys.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4text.inc>
--------------------------------------------------------------------------

================================================================
 l4text.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4time.inc>
--------------------------------------------------------------------------

================================================================
 -- system time

	date & time

 time		( -- ts tm| er -1 )		(s)		'time4'		forth
	ret ts := time in seconds, tm := remaining microsec (on tos)
	or ernum and -1. syscall gettimeofday, re man(2), linux/time.h

 date		( -- n )			(s)		'date4'		forth
	ret n := time in seconds sice 1.1.1970 or, error
	syscall time, re man(2), linux/time.h

 day		( -- n )					'day4'		forth
	no. of day per week, 0 for Sunday.

 time&date	( -- n1...n6 )			(4)(a:yx)	'timedate'	forth
	ret time & date n1..n6, second, minute, hour, day, month, year.
	NOTE:
	POSIX.1 defines seconds since the Epoch as a value to be interpreted 
	as the number of seconds between a specified time and the Epoch, 
	according to a formula for conversion from UTC equivalent, leap 
	seconds ignoring and considering all years divisible by 4 being leap years. 

 >time&date	( n1 -- n2..n7 )		(4)		'totida'	forth
	convert n1 seconds since "the Epoch" to time&date format
	n7:year n6:month n5:day n4:hour n3:minute n2:second

 <ndatey>	( s m h d3 -- s m h d m y	(k)				novoc
	resolve date from seconds/min, min/hour, hours/day, days
	to further returning month & year, incl. leap years wrt 1970

 "day		( [cc] -- p u )			(4)		'sday4'		forth
	ret stg(p,u) w/ name-stg of system time day
	use <en> or <de> decoding if [cc] present and = "en" or "de"

 "time  	( -- p u )			(4)		'stime4'	forth
	return system time stg(p,u)
	stg in {hld}-buffer below {pad2}, using {here} for intermediate storage.

 "date  	( [cc] -- p u )			(4)		'sdate4'	forth
	return system date stg(p,u)
	stg in {hld}-buffer below {pad2}, using {here} for intermediate storage.
	use <en> or <de> decoding if [cc] present and = "en" or "de",
	dft & "en": year-month-day, "de": day-month-year.

 "time&date	( [cc] -- p u )			(4)		'stimedate'	forth
	full size system date & time stg, in stg buffer at {pad2}.

 .time&date	( [cc] -- )			(4)		'dotimedate'	forth
	display full size system date & time stg
	using {hld} buffer below {pad2} and {here} for intermediate storage.

=====================================================================;
 l4time.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4tools.inc>
--------------------------------------------------------------------------

--  tools
	

 [rs]		( -- )				(i)(4)		'dotrsi'	tools
	immediate variant of -re- {.rs}, {cr} appended.
	(asm debugging: eflags, all reg. and stack contents preserved)

 .rs		( -- )				(4)		'dotrs'		tools
	display returnstack content, topmost item to the left, w. leading 
	"R[#depth:#base]"; signed if @base = decimal, else unsigned.
	(asm debugging: eflags, all reg. and stack contents preserved)
	stack display variants use local data-space for numeric conversion.
	NOTE: system exceptions can lead to local- and data-space corruption,
		which may partly be recovered by exchanging dp and s0 values.

 [s]		( -- )				(i)(4)		'dotsi'		tools
	immediate variant of -re- {.s}, for debugging, reg/eflags preserved.
	displaying state@, rp@, lp@, sp@, before stack content; <cr> terminated.
	(asm debugging: eflags, all reg. and stack contents preserved)

 .s		( -- )				(4)		'dots'		forth
	display datastack content, topmost item to the left, w/ leading 
	">D[#depth:#base]"; signed if @base = decimal, else unsigned.
	1st char, ">" if interpreting, "=" while compiling, by system prompt.
	(asm debugging: eflags, all reg. and stack contents preserved)
	stack display variants use local data-space for numeric conversion.
	NOTE:	system exceptions can lead to local- and data-space corruption,
		which may partly be recovered by exchanging dp and s0 values.

 adump  	( a u -- )							tools
	dump from true address

 bdump   	( -- )								tools
	continue dump towards lower addr.

 ndump   	( -- )								tools
	continue dump

 rdump  	( -- )				(f6)				tools
	repeat previous {dump} or {adump} action

 dumpa  	( p n -- )			(4)(f6)				tools
	dump no. n bytes of contents at ptr p
	display w. true addresses
	executes {dump} if cnt is -ve

 dump		( p n -- )			(4)(f6)				forth
	dump no. n bytes of contents at ptr p
	<space> to halt, <esc> key to abort display,
	<any other key> after <space> continues.
	stores p & n for {rdump}, executes {dumpa} if cnt is -ve
	all {dump} variants use local data-space for numeric conversion.
	NOTE: system exceptions can lead to local- and data-space corruption,
	      which may partly be recovered, examining dp, lp and s0 values, 
	      w/ { dp lp !! } and { last @ lfa>idx >body 4+ dp ! }.

 tdump  	( p n -- )			(4)				tools
	memory dump w.o. args storage - re {dump}

 #dcm		( p1 -- p2 )			(4)(e)	'hdcm'			tools
	decompile from ref by ptr p1 to codespace, leave ptr p2 to next opr.
	(e: ret NZ at end of code section, after <ret> or <jmp ...>

 s						(4)	'nsee'			tools
	8 times repeat #see

 #see		( -- )				(4)	'hsee'			tools
	continue where {see} terminated, from @fld, inc @fld at least by 1.

 see		ccc( -- )			(a:f)				forth
	(at most) decompile a hi-level word/soubroutine call by name.
	interrupt w. <esc>, halt display w. <space>, any other key to carry on.
	stores final ptr to {fld}, for continuation w. {#see}.
	NOTE: decompiles aliased words to names earliest in wordheaders list.

 id.		( n -- ) 			(4)		'iddot'		forth
	display name of word by n uot index ("execution token") or lfa.
	imed words displayed at reversed video.

 voc.		( p -- )					'vocdot'	tools
	display name of wordlist which word pointed to by lfa p is in.

 v		ccc( -- )			(4)		'vau'		root
	independently of search order, display which wordlist ccc belongs to, 
	display "-?-" if word doesn't exist.

 wvoc-r  	( p1 -- p2 )					'wvocr'		tools
	find 2ndary lfa p2 of wordlist which the word pointed to by lfa p1 is in.

 wvoc		( p1 -- p2 )					'wvoc'		tools
	find bottom lfa p2 of wordlist which the word pointed to by lfa p1 is in.
	get/verify RAM linkage w. { ( p1 ) wvoc lfa>idx idx>wid wid>lfa }.

 all-words  	( -- )								tools
	{vlist} all vocabularies.
	use keys <space> to halt, <esc> to terminate display.

 selected	ccc( .xx. -- .xx. )		(d)(i)				forth
	pass {words} selective output selection word. - preliminary -
	An example, selecting {words} output by a text segment:
		defer (t)			\ a string, used in (r)
		defer (w)			\ ( lfa -- flg ) selection
		s" *" dup stg s 
		' s is (t)
		: (r) lfa>nfa count (t) search -rot 2drop ;
		' (r) is (w)
		: sel begin dup 0= -exit dup (w) -exit dup @ - dup @ 0= until ;
		selected sel forth words	\ show words with "*" in their names
		forth words			\ next will be listing all words...

 (selected)	( n1 lfa1 -- n2 lfa2 | .. 0 )	(d)(k)		'pselectedp'	util
	{words} selection, executed while collecting the nfa array to display.
	should return either the lfa, unchanged, or another lfa or, zero in which 
	case the array generation will be terminated, and adjust the array items 
	count value, accordingly.

 [selected]	( lfa0 -- lfa0..lfa(n-1) n )	((d))(k)	'bselectedb'	util
	{words}' lfa collecting, w/ selection by deferred {(selected)}.

 words  	( -- )				(f6)				forth
	alphabetically sorted list all names of {context} vocabulary,
	use keys <space> to halt, <esc> to terminate display.
	for once only(!) selective display -re- {selected}, 
	{words} returns w/ (selected) reset to it's default action.

 vlist  	( -- )				(fg)				forth
	consecutively list all names of {context} vocabulary,
	use keys <space> to halt, <esc> to terminate display.

 all-find	ccc( -- lfa flg )				'allfind'	tools
	as {find}, searching all {voc-link}ed wordlists

 hv		( -- )						'hvstack'	root
	restrict {help} to searching wordlists from stacked search order, only.

 help		ccc( -- )			(i)				root
	Display help-text from glossary for word ccc or, @context if none given:
	1st occurrence of ccc in sequence of all {voc-link}ed wordlists will be 
	displayed; use { hv help } to searching the stacked search order, only. 
	{ vocs } displays the default search order specific to {help}.
	Searching can further be narrowed w/ {lc-depend} to letter case dependency.
	An error message will be returned, if word ccc or glossary file not found.
	
	The glossary file the name of which is stored in -re- {f8glo} is expected 
	in the documentation directory -re- {f8doc}, redirectable by ptrs to the 
	rsp strings in kernel-values {(f8doc)}, {(f8gls)}.
	
	{help} finds a word enclosed by leading <nl><bl> and trailing char <= <bl>
	in a glossary header line, w/ "( .. )" stack balance and ref to vocabulary
	and, reads/displays the rsp and any following lines until empty line found.
	By default, applicable to kernel words, only, and if the simple glossaries 
	were generated w/ e.g. <make doc>. Additional, conformant text may then be 
	appended to the file <glossary> in the installed documentation directory
	which becomes available to any lib4th programs, immediately after.
	plain ascii, un-escaped text displayed by -re- {[type]}.
	
	error messages:
		?vocabulary	 24	unknown or, voc-ref error in <glossary> file;
					try {v name} to verifying whether a word exists.
		invalid arg.	-22	<glossary> access or, text format error.
		no data avail.	-61	<glossary> reading error.
	

	
 ----------------------------------------------------------------
-- {sorted}, {sort}, {quick}, using {d!}, {d@}, {d!!}
	a tag-sort procedure, in {util} wordlist.

	

 sorted 	ccc( p n -- )			(i)(4)				util
	according to the relation ccc order array(p,n), n cells at ptr p.
	use{ SORTED <relation> } - 'relation' being stored to {precedes}.

 srd		( p -- )			(k)		'psortedp'	novoc

 sort		( ptr n1 -- )			(4)				util
	Modified "quicksort", sort an array by ptr p to array of n1 items.
	(from: R.Zech, Forth 83, Muenchen Franzis' 1987) -re- {quick}, {sorted}.
	An example application (on assembly level) is -re- {words}.

 quick  	( ptr1 ptr2 -- )		(4)				util
	sort arrays by ptrs, using deferred words to enabling virtual 
	memory addressing and task specific evaluation words:
	{precedes}	( p1 p2 -- flg ) comparison at p1,p2, tf if "lower"
	{d@}		( p -- n )	fetch sing n from ptr p
	{d!}		( n p1 -- )	store sing n to ptr p
	{d!!}		( p1 p2 -- )	exchange sings at p1,p2

 precedes	( p1 p2 -- f )			(d)				util
	comparison function in {sort}, should return tf for "lower".

 d@		( p -- n )			(d)		'dfetch'	util
	deferred 'fetch' a sing, for virtual addressing in {sort}, etc.

 d!		( n p -- )			(d)		'dstore'	util
	deferred 'store' a sing, for virtual addressing in {sort}, etc.

 d!!		( p1 p2 -- )			(d)		'dxsto'		util
	deferred 'exchange' contents of equally sized storage places.

=====================================================================;
 l4tools.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4tty.inc>
--------------------------------------------------------------------------


 ctrlchars, bytewise dft code translation
	in range [0...31], <del> substitutes <nul>

 ctrlbits, default pattern
	bit pattern of executeable ctrl actions, 256 bits

================================================================
 l4tty.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4uvari.inc>
--------------------------------------------------------------------------


================================================================
-- user vari/cons

 up+		( -n -- p )			(m,7)		'upplus'	forth
	get ptr to user vari by disp
	(consecutive disp's wrt uv.link := 0, .aux:=124, .vocs:=-128)

 uv@		( -n -- p )			(m,7)		'uvfetch'	forth
	get content of user vari by -ve(!) disp, -n < 0
	(consecutive disp's wrt uv.link := 0, .aux:=124, .vocs:=-128)

 bl		( -- c )			(m,6)		'bbl'		forth
	dft. character code of blank space

 dpl@		( -- n ) 			(f6)(m,4)	'dplfetch'	forth
	does{ dpl @ }, fetch decimal point location after numeric input.

 edpl@	( -- n ) 			(m,5)		'edplfetch'	forth
	signed, (optional) base-exponent from numeric input.

 in@		( -- n ) 			(f6)(m,4)	'infetch'	forth
	does{ in @ }

 blk@		( -- n ) 			(f6)(m,4)	'blkfetch'	forth
	does{ blk @ }

 span@  	( -- n )			(m,4)		'spanf'		forth
	number of chars fetched with latest expect, -re- {#tib}

 #tib		( -- u )			(83)(m,7)	'ntib'		forth
	received no. of bytes in tib storage - f83 eq. to {span}

 tib		( -- p ) 			(m,4)				forth
	push ptr to terminal input buf.
	ANS-4th standard: tib is tib and is tIB wich is an Input Buffer, 
	thus any question whether it might be written to is just stupid!

 tib-max	( -- u )			(f6)(m,7)	'tibmax'	hidden
	max bytes of tib storage

 tib-dft	( -- p )			(m,8)		'tibdft'	hidden
	default terminal input buffer for stdin input. below user area.

 tib>dft	( -- )				(m,10)		'tib2dft'	root
	set terminal input buffer to default location -re- {tib-dft}.

 pad-size	( -- n )			(m,4)		'pad-size'	forth
	size of {pad}, {pad2}, implied size of numeric stg conversion buf. at {hld}.
	should not be set to less than 136 bytes, i.e. for quads' number conversion.
	system default 256 bytes, 4096 (Page Size) recommended for long strings, etc.

 pad		( -- p )			(a:c)				forth
	double cell aligned auxilary memory {pad-size} bytes on top of current 
	dictionary ptr, "above"  {pad2}, stored data may extend until below {sp@}.

 pad2		( -- ptr )							forth
	2ndary double-cell aligned auxilary memory {pad-size} bytes on top of current 
	dictionary ptr used by literal string storage opr's while interpreting, {s"} etc.

 cc4cc@  	( c -- p )			(83)		'cc4thf'	forth
	user vector, zero ctrl action for char c in jumptable

 cc4cc!  	( c p -- )					'cc4ths'	forth
	store execution ptr p for char c to (cc4th) table.
	2drop if @(cc4th) = 0; p = 0 or kref(p) = 0 de-acivates entry

 here		( -- p )			(m,4)				forth
	ptr to bot of unused dataspace
	current dataspace dictionary ptr, between @{d0} and @{d-top}.

 unused  	( -- n )			(a:cx)				forth
	available data-space cells,
	{ d-top @ here - 4/ }, may be extended w. {allocate}

 c-here  	( -- p ) 			(m,4)		'chere'		forth
	current executeable code dictionary ptr, between @{c0} and @{c-top}.

 state@  	( -- n ) 			(f6)(m,4)	'statef'	forth
	fetch compile/interpret state flag(s)
	zero if actively interpreting, any non-zero otherwise

 (r)@		( -- p ) 			(f6)(m,7)	'prpf'		forth
	ptr to fill-up char for formatted string output

 source-id	( -- n ) 			(a:cx)(m,7)	'sourceid'	forth
	current input source
		-2: initial arguments present
		-1: input by {evaluate}d string
		 0: user input device = <stdin>, file if -ve blk@
		>0: channel number of file input, 0 and -ve @blk@ for stdin
		    file pointer in channels chp data

 4th-id  	( -- n ) 			(f6)(m,7)	'fthid'		forth
	basic task's process id, set on startup.
	re {pid@} for currently running job's id

 ti-cal  	( -- dn )			(f6)(m,7)	'tical'		forth
	fetch cpu clocks per second, from (tick).
	non-macro variant checks and inititates calibration, if required

 cmc-off	( -- )				(i)		'cmcoff'	root 
	disable "optimization", i.e. end-of-word <call> to <jmp> conversion 
	until next new entry into compile state. 
	use { ... [ cmc off ] ... } to disabling for next word, only, and 
	to re-enabling common optimization features after disabling. 

 cmc?		( -- )				(i)		'cmcq'		compiler
	immediately(!) sedecimal display {cmc} value.

 !fence 	( -- | abort )					'stofence'	forth
	store current top values to {fence},{c-fence},{i-fence} variables
	backing up code-, compile- and auxilary compile-ptrs to c-here,
	thus restricted to be used while (non-intermediately!) executing.
	NOTE: {i-fence} stores 1st un-used index, following last unsed one.

 fence! 	( n1 n2 n3 -- )					'fences'	forth
	store values from tos, n1:=c-fence, n2:=fence, n3=i-fence to {..fence} ptrs
	NOTE: n3, @i-fence, is 1st un-fenced index, following fenced one.

 fence@ 	( -- n1 n2 n3 )					'fencef'	forth
	fetch latest {fence!}-ed values to tos, n1:=c-fence, n2:=fence, n3=i-fence
	NOTE: n3, @i-fence, is 1st un-fenced index, following fenced one.

 argp   	( -- p )			(m,7)		'argpp'		linux
	get ptr to array of ptr-s to program's asciz environment strings.

 envp   	( -- p )			(m,21)		'envpp'		linux
	get ptr to array of ptr-s to program's asciz environment strings.

---------------------------------------------------------------
-- user vari ptrs (re glossary)
	NOTE: those w. no stack notation not (yet) available by name.

	

 <top>  	( -- p )					'utop'		hidden
	p *is* ptr to top of user-vari area - neither read nor store!

 (eax)  	( -- p )					'ueax'		hidden
	@tos, initial/task switching register value

 (ecx)  	( -- p )					'uecx'		hidden
	W-reg., initial/task switching register value

 (edx)  	( -- p )					'uedx'		hidden
	T-reg., initial/task switching register value

 (ebx)  	( -- p )					'uebx'		hidden
	'KR', ref into kernel memory (ROM)
	initial/task switching register value

 (esp)  	( -- p )					'uesp'		hidden
	'RP', esp of initiating program

 (ebp)  	( -- p )					'uebp'		hidden
	'UR', ref into user vari
	initial/task switching register value

 (esi)  	( -- p )					'uesi'		hidden
	'LS', locals ptr
	initial/task switching register value

 (edi)  	( -- p )					'uedi'		hidden
	'PS', datastack running ptr
	initial/task switching register value

 (aux)  	( -- p )					'pauxp'		hidden
	i/o system flags

 (sstop)  	( -- p )					'sstop'		hidden
	true address of top of .ss section (lowest address)
	section can be extended by pushing any item to requested new address, e.g:
	{ ]] (sstop) @ 10000 - abs>4th r0 @ swap r0 ! rp! 0 >r rdrop r0 ! rp! [[ }

 (bot)  	( -- p )					'mbot'		hidden
	true address of bottom of user task memory

 (top)  	( -- p )					'mtop'		hidden
	true address of global RAM/.bss top, end of user area

 d-top  	( -- p ) 					'dtop'		forth
	top of data-space (kref'd ptr!), -re- {d0}, {here}, {unused}

 c-top  	( -- p ) 					'ctop'		forth
	top of code-space (kref'd ptr!), -re- {c0}, {c-here}

 s0		( -- p )							forth
	datastack, bottom up; -re- {sp@}, {depth}, {-depth}

 lp		( -- p )							local
	ptr into local data-space,
	content temporarily exchanged w/ {dp} while compiling a local word header.

 r0		( -- p )							forth
	initial returnstackptr, -re- {rp@}

 up		( -- p )							forth
	memtop uservari ptr, top down, after last used item

 d0		( -- p )							forth
	bottom of dataspace, in .bss section

 dp		( -- p )							forth
	ptr into dataspace, -re- {here}, {unused}, {d0}
	content temporarily exchanged w/ {lp} while compiling a local word header.

 c0		( -- p )							forth
	base address of codespace

 cp		( -- p )							forth
	ptr into codespace, in .bss section; -re- {c-here}, {c-top}

 state  	( -- p ) 			(fg)(a)				forth
	ptr to compile/interpret state flag(s).
	state@ zero if actively interpreting, any non-zero otherwise.
	lib4th {state} complies to standard, though non-zero values 
	have specific control functions different to common useage!

 (head)  	( -- p ) 					'pheadp'	hidden
	xec entry ptr while compiling

 (tail)  	( -- p ) 					'ptailp'	hidden
	backup ptr while compiling

 (scanwl)	( -- p )					'uscanwl'	hidden
	wordlists searching 2nd-ary error handler

 csp    	( -- p ) 							forth
	saved compile-stack ptr

 (source-id)	( -- p ) 					'psourceidp'	hidden
	root of input source redirection linklist

 (tib)  	( -- p ) 					'ptibp'		hidden
	ptr to ptr to terminal input buf.

 span	  	( -- p )			(79)				forth
	ptr to number of chars fetched with latest expect

 blk 	  	( -- p ) 			(a:b)				forth
	ptr to block number storeage
	double will fetch {blk} to l.s. cell, and {in}

 in		( -- p ) 			(fg)		'xin'		fig
 >in		( -- p ) 			(a:c)		'xin'		forth
	disp from start to parse area in input buf.

 (sighnd) 	( -- p )					'sigh'		linux
	base address of linux signal handlers, -re- {sighnd-size}

 scr		( -- p )							forth
	fig-4th screenfile line editor, screen number.

 (argn)  	( -- p ) 	arguments count(er)		'argn'		hidden

 (bits)  	( -- p ) 					'bbitsb'	hidden
	internally used different purpose auxilary flagbits

 out		( -- p ) 			(fg)		'nout'		forth
	editor, output chars cnt

 rows		( -- p ) 							forth
	editor, output lines cnt

 r#		( -- p ) 			(fg)		'unr'		editor
	editor, cursor posn in screenfile

 (pchr)  	( -- p )					'pchr'		hidden
	dft: [32,126] & [128,255] ranges of printing chars

 (escc)  	( -- p )					'uescc'		hidden
	escape symbol for -re- {etype}

 (vtim)  	( -- p ) 					'uiovtim'	hidden
	lo.b: VTIME, hi.b VMAX byte values for stdin ioctl

 (iolink)	( -- p ) 					'iolink'	hidden
	i/o redirection link pointer, re "lib4th.mac", <pushiosrc> & <popiosrc>.

 (ierr)  	( -- p )	input error code		'ierr'		hidden

 a-heap 	( -- p ) 					'aheap'		hidden
	allocated, used memory heap linklist

 f-heap 	( -- p )					'fheap'		hidden
	linked list to free allocated heap blocks

 (ulink)	( -- p )					'plinkp'	hidden
 	circular linklist to user vari & task reference.
	this is where <uref> points, jobs' UP = ebp.

 (lkindex)	( -- p )					'plkindexp'	hidden
	running ptr to word execution address indices (preserved in tasks!)

 (m/mod)  	( -- p ) 	xec vec				'upmbymp'	hidden

 (eof)  	( -- p ) 	eof character			'peofp'		hidden

 (ioacc)	( -- p ) 					'uioacc'	hidden
	up to 4 accumulated input chars (for vt emu)

 fld		( -- p )	uvari, free for user aplication	'ufld'		forth

 dpl		( -- p )			(fg)				forth
	decimal 'point' location, i.e. posn of last numeric fractions marker from 
	(dpl). type flag settings from numeric stg conversion -re- {[number]}:

 base		( -- p )							forth
	ptr to number conversion radix

 hld		( -- p )							forth
	ptr to current posn in number to string conversion buf.

 hld0		( -- p )							hidden
	initial {hld} after start of number conversion

 (tick)  	( -- p )					'ptickp'	hidden
	cpu timing cons, cps.

 (locb) 	( -- p )					'locb'		hidden
	used local bytes counter

 (locn) 	( -- p )					'locn'		hidden
	local cells count in currently being defined word

 (padsz) 	( -- p )					'padsz'		hidden
	disp from here to pad2, pad2 to pad, max+4 stg size for {word}
	{word} fetching long stg-s, <nul>-enclosed, if @(padsz) set to > 256.

 fence  	( -- p )							forth
	upper bound of non-alterable dictionary, 1st writable position.

 c-fence	( -- p )					'cfence'	forth
	upper bound of non-alterable compile-space, 1st writable position.

 i-fence	( -- p )					'ifence'	forth
	upper bound of non-alterable uot-index, no. of 1st writable ix.

 (argc)  	( -- p ) 							hidden
	program arguments cnt

 (argp)  	( -- p )							hidden
	ptr to current argument

 (bootp)  	( -- p )					'ubootp'	hidden
	ptr to executeable's data area, supplied sourcefile/data, etc

 (path)	( -- p )					'upath'		hidden
	ptr to {path} string

 (cmc)  	( -- p )					'ucmc'		hidden
	compiled words counter, for optimization support

 (oerr)  	( -- p )	output error on write		'oerr'		hidden

 (chans)	( -- p ) 	i/o channels redirection table	'pchansp'	hidden

 (inchp)		( -- p ) 				'pinchpp'	hidden
	stores latest used channels chp, of _any_ i/o call

 (outchp)		( -- p ) 				'poutchpp'	hidden
	stores latest used channels chp, of _any_ i/o call

 (cc4th)	( -- p ) 			(83)		'icc4th'	hidden
	user vector, kref(ptr) to base of ctrl actions jump-table, else zero

 voc-link	( -- p )					'voclink'	forth
	vocabulary link pointer, linkage by disp to respective ptrs,
	chained { voc-link begin dup @ -dup while - dup voc>lfa id. repeat drop }

 last		( -- p )			(79)		'lastu'		forth
	last accessible word in system. -re- {latest} wrt {current} voc.

 current	( -- p )							forth
	ptr to double voc descriptor of defining vocabulary, i.e. vocabulary 
	the wordlist of which currently will be extended by new definitions.

 ocurrent	( -- p )							hidden
	previous current voc, after {definitions}. 
	{prevdef} restores {current} from {ocurrent}.

 context	( -- p )							forth
	ptr to double voc descriptor of 1st voc in search order

 ocontext	( -- p )							hidden
	old context, 2nd volatile item on stack, ALSO moves into voc-stack

 (tattr)	( -- a )					'utattr'	hidden
	program's terminal settings, true address of data structure

 (tattr-s)	( -- a )					'ustattr'	hidden
	initial terminal settings, true address of data structure

 (vpal) 	( -- p )					'uvpalette'	hidden
	program's video terminal mode, ptr to data structure

 width  	( -- p )							forth
	max. length of a 4th name moved into header data (currently un-used).

 (dpl)  	( -- p )					'pdplp'		forth
	decimal point location ptr

 (#tab) 	( -- p)						'pntabp'	hidden
	<tab> spacing. (1 if set to zero)

 (tib-max)	( -- u )					'ptibmaxp'	hidden
	max bytes of tib storage

 (r)		( -- p )			(f6)		'uprp'		hidden
	ptr to max 4 fill-up chars for formatted string output, for .r, u.r etc

 (eol)  	( -- p ) 					'ueol'		hidden
 	up to 4 bytes for eol sequence, CR/LF, <nl> char(s)

 (lo>hi)	( -- p )					'ulo2hi'	hidden
	i/o chars, bytewise, lo mapped into hi, 0:no translation

 (hi>lo)	( -- p ) 					'uhi2lo'	hidden
	i/o chars, bytewise, hi mapped into lo, 0:no translation

 (fperm)	( -- p )					'ufperm'	hidden
	file permission bits for {open-file} etc, dft 600o

 (can)  	( -- p ) 					'ucan'		hidden
	lo-w:d_can exit code, hi-w:no. of sequential chars=d_can

 (quit) 	( -- p )					'uquit'		hidden
	execution entry

 (ekey?)	( -- p )					'uekeyq'	hidden
	basic character input

 (emit) 	( -- p )					'uemit'		hidden
	{emit} xec vec.

 (type) 	( -- p )					'utype'		hidden
	the basic operation for text output to stdout.

 (accept)	( -- p )					'uaccept'	hidden
	ptr to true address of {accept}.

 (stimo)  	( -- p ) 					'ustimo'	hidden
	timout when waiting for input. nanoseconds setting at (p-4).

 (echo)					(n.i.)
	single chars output (stdout)

 (ok)		( -- p )					'upokb'		hidden
	ptr to true execution ptr to kbd input prompt
	to re-define, for instance, enter { ' .s idx>xec 4th>abs (ok) ! }

 (error)	( -- p )					'uerror'	hidden
	ptr to true address of error handler

 (?error)	( -- p )					'uqerror'	hidden
	ptr to true address of conditional error handler

 (eval)  	( -- p )					'ueval'		hidden
	ptr to true address of {evaluate}

 (compile)	( -- p )	xec vec				'ucompile'	hidden

 (interpret)	( -- p )	xec vec				'uinterpret'	hidden

 (]interpret)   ( -- p )	dft unset			'ubinterpret'	hidden

 (interpret[)	( -- p )	dft unset			'uinterpretb'	hidden

 ([debug])	( -- p )	dft (compile)			'updebugp'	hidden

 (sp!)  	( -- p )	xec vec				'ustosp'	hidden

 (>number)	( -- p )					'utonum'	hidden
	convert, default xec vec

 (number)	( -- p )	xec vec				'unumber'	hidden
	dft {f-number}/{a-number} according to preferred mode, re Makefile

 (um/mod)	( -- p )					'usmbym'	hidden
	default UM/MOD variant (floored/near zero), init {sm/rem}

 (?terminal)	( -- p )	xec vec				'uqterminal'	hidden

 (pause)	( -- p )	xec vec				'upause'	hidden
	0 or xec after timout to {wait4..} words elapsed, by true address.

 (buffer)	( -- P )	xec vec				'ubuffer'	hidden

 (block)	( -- p )	xec vec				'ublock'	hidden

 (source)	( -- p )	xec vec				'usource'	hidden

 (vbot) 	( -- p )							hidden
	end of pre-defined user area, up := disp to uv.link in uv.up,
	{ (vbot) tib tib-max + - 4/ } cells free for application defined user vari

 (#tib)  	( -- p )					'pntibp'	hidden
	no. of chars in tib

 (uot)  	( -- p )					'ultab'		hidden
	bottom of executeables pointers, all true addresses

================================================================
-- kernel vari/"value"s
	

 wdw-lk	( -- p )			n.i.		'wdwlk'		hidden
	console windows linkage, top down ptr, bottom up is next cell

 (alarm)	( -- )						'palarmp'	linux
	kernel {defer}red, executed by redirected SIGALRM handler
	if @p =/= 0 xec kernel-vari (alarm), else dft { [s] }
	

=====================================================================;
 l4uvari.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4vt.inc>
--------------------------------------------------------------------------


----------------------------------------------------------------
 -- vt... and ctrl sequences
	different terminal emulations emulate "standards" differently and
	not always correct. following was tested in console, xterm, rxvt.
	all handle CSI sequences differently, false or, simply don't...

	vt words is a minimal set of word for console control until final
	implementation, which is planned to utilize terminfo settings.
	words' names might change, according to terminfo.

 -- console.c:
  r	0x00,0xaa,0x00,0xaa,0x00,0xaa,0x00,0xaa,0x55,0xff,0x55,0xff,0x55,0xff,0x55,0xff
  g	0x00,0x00,0xaa,0x55,0x00,0x00,0xaa,0xaa,0x55,0x55,0xff,0xff,0x55,0x55,0xff,0xff
  b	0x00,0x00,0x00,0x00,0xaa,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x55,0xff,0xff,0xff,0xff
 -- attribute bits:
  0,1	intensity (0..2)
  2	underline
  3	reverse
  7	blink
	

----------------------------------------------------------------
 -- ascii ctrl constants, in {vt} voc.

 
 <bel>  	( -- n )					'lbelg'		vt
	cons, BEL (0x07, ^G) beeps;

 <bs>		( -- n )					'lbsg'		vt
	cons, BS  (0x08, ^H) cursor back  one  column, not clearly
	def'd: backing up or additionally erasing char before curpos.
	(but not past the beginning of the line)

 <ht>		( -- n )					'lhtg'		vt
	cons, HT  (0x09, ^I) goes to the next tab stop or to 
	the end of the line if there is no earlier tab stop

 <lf>		( -- n )					'llfg'		vt
	cons, LF  (0x0A, ^J), linefeed; Linux: also console & files <eol> code.

 <vt>		( -- n )					'lvtg'		vt
	cons, VT (0x0B, ^K) vertical tabulator, linefeed to console channels

 <ff>		( -- n )					'lffg'		vt
	cons, FF (0x0C, ^L), linefeed to console channels

 <cr>		( -- n )					'lcrg'		vt
	cons, CR  (0x0D, ^M) gives a carriage return

 <so>		( -- n )					'lsog'		vt
	cons, SO  (0x0E, ^N) activates G1 character set (graphic chars), 
	and if LF/NL (new line mode) is set also a carriage return

 <si>		( -- n )					'lsig'		vt
	cons, SI  (0x0F, ^O) activates the G0 character set

 <can>   	( -- n )					'lcang'		vt
	cons, CAN (0x18, ^X) interrupt escape sequence

 <sub>  	( -- n )					'lsubg'		vt
	cons, SUB  (0x1A, ^Z)  interrupt escape sequence

 <esc>  	( -- n )					'lescg'		vt
	cons, ESC (0x1B, ^[) starts an escape sequence

 <del>  	( -- n )					'ldelg'		vt
	cons, DEL (0x7F) is ignored (?, linux console)

 <csi>  	( -- n )					'lcsig'		vt
	cons, CSI (0x9B) is equivalent to ESC [.

	
----------------------------------------------------------------

 !vtp		( n c -- )					'vtsp'		vt
	send a vt.. numeric parameter w/ trailing char c, unless c<0.
	NOTE: numeric stg output buffer @hld will be overwritten.

 @vtp		( -- n )					'vtfp'		vt
	fetch a vt.. decimal parameter, regardless of @base setting.

 vt?esc 	( -- flg )					'wesc'		vt
	initial response to vt request:
	wait for <esc>, timeout after kbd?key failed for 1s, 
	ret ff if non-<esc> char received w/ <ecx>-reg = char-code.
	(sec of reading timeout modifiable in asm source, at <wesc> label)

 vt?csi 	( -- flg )					'wcsi'		vt
	initial response to vt request:
	wait for <esc>[ or <csi>, timeout after kbd?key failed for 1s,
	ret ff if non-<esc> char received w/ <ecx>-reg = char-code.
	(sec of reading timeout modifiable in asm source, at <wesc> label)

----------------------------------------------------------------
 -- ctrl and vt.. sequences/actions
	orderly output might require an initial {max-xy} if stdout connected to a pipe

	

 set-palette	( r g b n -- )					'setpalette'	vt
	set a selected colour by number -1 < n < 16 to the composition 
	of three 8bit colour values for (r)ed, (g)reen, (b)lue.
	n: 0 black, 1 red, 2 green, 3 yellow, 4 blue, 5 magenta, 6 cyan, 7 white
	n: -1 to resetting to default values, colour items discarded.
	NOTE1: restricted to the Linux console, won't work in an xterm, etc.
	NOTE2: use Linux <reset> to recover from an unexpectedly aborted program.

 reset-palette	( -- )						'rstpalette'	vt
	restore terminal colours from inital (default) values. 
	this will restore to defaults from the Linux KERNEL! neither of ioctl or 
	vt sequences, offer any means to reading the #actual# console settings! 
	NOTE: use Linux <reset> to restore from an unexpectedly aborted program. 

 [i]		( -- co )			(kv)		'bibv'		vt
	latest {ink} colour

 ink		(co -- )					'vtink'		vt
	set foreground colour/vt-mode, update {[i]} if co is a colour value.

 [p]		( -- co )			(kv)		'bpbv'		vt
	latest {paper} colour

 paper  	( co -- )					'vtpaper'	vt
	set background colour/vt-mode, update {[p]} if co is a colour value.

 colour 	( co bf -- )					'vtcolour'	vt
	set console colour from colour- and back- or foreground values,
	re colour and bg/fg names in {vt}-wordlist - {black}.., {bg}..
	NOTE:
	these settings can also control the xterm, rxvt, etc. display but, use 
	"<esc>[" for <csi> because some terminals won't interpret the latter.
	{colour} applicable to all 'ECMA-48 Graphic Rendition' cmd-s, "<esc>[<num>m"
	other parameter values -re- man 4 console_codes:
	{me}	( -1 0 -- )	reset all attributes to their defaults
	{md}	( -1 1 -- )	bold
	{so}	( -1 2 -- )	half-bright
	{us}	( -1 4 -- )	underscore
	{mb}	( -1 5 -- )	blink (light colour background)
	{mr}	( -1 7 -- )	reverse video
		( 0  1 -- )	reset toggle-meta flg, selected mapping, display ctrl flg.
		( 1  1 -- )	reset toggle-meta flg, select null mapping, set display ctrl flg.
		( 2  1 -- )	set toggle-meta flg, select null mapping, set display ctrl flg.
		( 1  2 -- )	normal intensity (not ECMA-48)
	{se}	( 2  2 -- )	normal intensity
	{ue}	( 4  2 -- )	underline off
		( 5  2 -- )	blink off
		( 7  2 -- )	reverse video off
		( 8 fg -- )	underscore on, set default foreground colour
		( 9 fg -- )	underscore off, set default foreground colour
		( 9 bg -- )	default background colour

 ?vt		( -- flg )					'qvt'		forth
	true flag if stdout connected to a terminal of "vt102" type.
	test for '[?6' vt102, then '[?1;Pc', P=dec.digit, vt100+ of xterm/rxvt.
	determines whether i/o is file, returns false if in or out not a console.
	reading response to stdin w. zero timeout,
	1s timeout for leading <esc>, modify source at <qvt> if not sufficent.

 xy		( -- u1 u2 )							forth
	fetch current cursor posn, col u1, row u2, = -1 if posn not available.
	NOTE:	false values if sending a char to the last column, i.e. posn 
		fetched before and after return identical co-ordinates!
		(console should solve 'pending newline problems', internally!)

 max-x  	 ( -- n )			(vt)				vt
	max. cursor position to the right of terminal window

 max-y   	 ( -- n )			(vt)				vt
 	max. cursor position toward bottom of terminal window

 row		( -- n )			(vt)				vt
	current cursor posn in row n

 to-row  	( n -- )			(vt)				vt
 	set cursor posn to row n at current column

 col		( -- n )			(vt)				vt
	current cursor posn in column n

 tab-to	( n -- )					'tabto'		forth
	advance cursor to column max(current+1,n) at current line

 to-col  	( n -- )			(vt)				vt
 	set cursor posn to column n at current line

 home		( -- )								vt
	^^ (ascii 30), cursor to top left of screen, non-terminal receives <ff>.
	emulated via { 0 0 at-xy } because only linux console does the standard 
	vt command emulation correctly - may be different with other linux setup...

 at-xy  	( u1 u2 - )			(vt)(a:f)	'atxy'		forth
	place cursor at posn u1 chars from the left and u2 rows below 
	top, store u1 to user vari {out}, u2 to {rows}.
	linux console esc[6n and esc[p1;p2H are in-consistent (Lx 2.2.14):
	reading refers to home posn = 1;1 while storing begins at 0;0.
	Lx 2.2.19 was ok. thus kvalue provided, for 'calibration' by {?vt}  
	such, that {xy} adjusts parameters to keeping same posn w/ { xy at-xy }.
	re DPANS 10.4.1.2: no-op if i/o is not a terminal.

 csr		( n1 n2 -- )							vt
	set scrolling region to n1=top, n2=bottom row.
	termcap 'cs' supported by linux console, rxvt, xterm.

 vt!state	( -- )						'vts'		vt
	save console state:
      cursor, intensity, underline, blink, reverse, charset, color, G0, G1
      (note: xterm-4 doesn't save the colours)

 vt@state	( -- )						'vtf'		vt
	restore most recently saved console state. -re- {vt!state}

 tab		( -- )								forth
	blanks till next horizontal tabulator wrt @out,
	using the tab spacing value from uvari (#tab).

 rev-off	( -- )				(vt)		'revoff'	vt
	reverse video off

 rev-on 	( -- )				(vt)		'revon'		vt
	reverse video on

 rev		( flg -- )			(vt)				vt
	reverse video on (tf) or off (ff)

 cure		( -- )				(vt)				vt
	enable cursor display.
	
	console (only) cursor appearance can be modified with, e.g.
		normal blinking underline : '\e[?2c'
		blinking block            : '\e[?6c'
		red non-blinking block    : '\e[?17;0;64c'
	1st arg:	0:dft, 1:invis, 2:underline, 4:(?), 8:block
			+16: soft curs, +32:change bg, +64: bg=/=fg
	2nd:		char attr to change, 'toggle mask' (XOR):
			bits 0..2: fg colour, 3:fg highlight/blink
			bits 4..6: bg colour, 7:fg highlight/blink
	3rd:		char attr to set, before applying 2nd arg,
			i.e. clearing a bit by passing as 2nd and 3rd.
	un-specified args default to zero.
 curd		( -- )				(vt)				vt
	disable cursor display.

 abscur	( -- )								vt
	cursor addressing wrt top left of terminal screen (console dft).
	NOTE: immediately changes cursor posn if prev. state was relative.

 relcur	( -- )								vt
	cursor addressing wrt top left of scrolling region.
	NOTE: immediately changes curpos and, is inconsistent wrt {xy} and {at-xy}.

 cup		( -- )						'cup'		vt
	cursor one line up
	(vt sequence, ok w. console, xterm, rxvt)

 cdn		( -- )						'cdn'		vt
	cursor one posn to the left
	(vt sequence, ok w. console, xterm, rxvt)

 cur-		( -- )						'clft'		vt
	cursor one posn to the left
	(vt sequence, ok w. console, xterm, rxvt)

 cur+		( -- )						'crgt'		vt
	cursor one posn to the right, cc4th action for '^_', ascii 31
	(vt sequence, ok w. console, xterm, rxvt)

 bs		( -- )								forth
	send <bs> to @{stdout}
	NOTE: {bs} is back-_SPACE_, which is not back-_BLANK_ - re {del}!

 del		( -- )								vt
	move cursor one column back and delete char at cursor posn

 cur!		( -- )						'curs'		vt
	save console cursor posn

 max-xy 	( -- x y )					'maxxy'		vt
	max. cursor position x to the right and y bottom of terminal window.
	NOTE: changed sizes orderly received in rxvt or xterm but, 
	      segfault in console e.g, after TIOCSWINSZ ioctl ($5414).

 cur@		( -- )						'curf'		vt
	rst console saved cursor posn

 max-lw 	( -- n )					'maxlw'		editor
	max stdout display line width, whether terminal window or file.
	line-width for non-terminal channels from (kernel-)value {#col}.

 cls		( -- )								forth
	clear screen & {home} if stdin or stdout is console.

 clsc		( -- )								forth
	cc4th action for <ff>, clear screen & <cr> if stdin or stdout is console.
	does not affect the cursor position - use vt {home} for cursor to top left.

 rs		( -- )								root
	reset terminal, colours palette, char founts, G0/0 character set.

 g0		( n -- )							vt
	activate G0, n-th charcter set; { 0 g0 } for the default charset.
	n may be passed by character when ORed with -0, { char -0 or }
	the rsp, linux kernel defined <esc>-sequences:
	 1 : LAT1_MAP	Latin-1 (ISO 8859-1)		ESC ( B
	 2 : GRAF_MAP	DEC VT100 pseudographics	ESC ( 0
	 3 : IBMPC_MAP	IBM code page 437		ESC ( U
	 4 : USER_MAP	User defined			ESC ( K

 g1		( n -- )							vt
	activate G1, n-th charcter set, 0 for default, -re- {g0}

 ff		( -- )								vt
 page		( -- )								forth
	form feed & <cr>, <nl> if out-fd is console, clr {out} and {rows}
	"clear screen" is -re- {clsc}, in forth vocabulary.

 bel		( -- )								forth
	pc-speaker's noise from kbd/console

----------------------------------------------------------------
 -- termcap -re- man term(5), terminfo(5), curs_terminfo(3), curs_termcap(3)
	fixed capabilities' order -re- <inc/term.h.inc>, from /usr/include/term.h
	compiled data structure ('int' is 2 bytes):
		1)	00	'magic number' &432 = $11a
			02	bytes size of names' section (4th)
			04	no. of bytes in boolean section (3rd)
			06	no. of 'int's in numbers' section (5th)
			08	no. of offsets by 'int's in stgs' section (6th)
			0a	bytes size of string table
		2) terminal names, <nul>-terminated
		3) boolean flags bytes, even aligned at end of table
		4) numbers per 'int's, -1 for an undefined capability, no other -ve
		5) strings section, capabilites by 'int's,
				w/ special chars in interpreted form, e.g. "^X", "\c"
				padding information by "$<nn>"
				parameter information in un-interpretted form, e.g "%x"
		6) string table, stgs <nul> terminated, refs may also point into stgs.
		new capabilites may follow
	

=====================================================================;
 l4vt.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4vtseq.inc>
--------------------------------------------------------------------------

 vt kernel ioctls, structure defn's, </usr/src/linux/include/linux/vt.h>
	
	

=====================================================================;
 l4vtseq.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4whead.inc>
--------------------------------------------------------------------------

-- interpreter, word headers structure
	conversion words all but {idx>lfa} & {>body} in {hidden}.
	"(c)" marks system defined constants, where reverse operation
	can be derived, e.g. for hypothetical mfa>lfa: { 0 lfa>mfa - }
	"(p)" depend on parameter*cons1+cons2.

	NOTE:
	ANS terminology "execution token" is index ix into uot.
	Basic words reference is by uot index.
	All linkage by displacement wrt lfa, towards lower addresses.
	re word header structure <whead> and data/flags in "lib4th.mac".
	valid range of ix in the actual system setup is 0 to @(lkindex)-1,
	absolute max is { (#tib) (ltab) - 4/ }, and less than 65535/4.
	a(ny) job can implement up to 16196 words.

	

 header pointers, reference conversion

 lfa>nfa	( n1 -- n2 )			(c)(m,3)	'lfa2nfa'	hidden
	convert wordheader linkfield ptr to namefield ptr

 nfa>lfa	( n1 -- n2 )			(c)(m,3)	'nfa2lfa'	hidden
	convert wordheader namefield ptr to linkfield ptr

 lfa>ifa	( n1 -- n2 )			(c)(m,3)	'lfa2ifa'	hidden
	convert wordheader linkfield ptr to indexfield ptr

 lfa>head	( n1 -- n2 )			(c)(m,3)	'lfa2head'	forth
	convert wordheader linkfield ptr to indexfield ptr

 ifa>lfa	( n1 -- n2 )			(c)(m,3)	'ifa2lfa'	hidden
      convert wordheader linkfield ptr to indexfield ptr

 idx>wid	( ix -- wid | 0 )				'idx2wid'	hidden
	convert vocabulary name's index to wordlist identifier
 
 wid>idx	( wid -- ix | -1 )				'wid2idx'	hidden
	convert wordlist identifier to vocabulary name's index
	check { ix (lkindex) @ u< } whether ix is valid.

 lfa>idx	( n1 -- n2 )			(m,3)		'lfa2idx'	forth
	convert wordheader linkfield ptr to uot index

 xec>lfa	( x -- p | 0 )					'xec2lfa'	hidden
	search uot for x, return lfa ptr p, corresponding to uot index.
	scan all vocabularies, independently of actual search order.

 idx>lfa	( ix -- lfa | 0 )		(cm,37)		'idx2lfa'	forth
	convert word index to linkfield ptr
	scan all {voc-link}ed wordlists, independently of actual search order.

 lfa>ffa	( n1 -- n2 )			(c)(m,3)	'lfa2ffa'	hidden
	convert wordheader linkfield ptr to compile-flags field ptr

 lfa>mfa	( n1 -- n2 )			(c)(m,3)	'lfa2mfa'	hidden
	convert wordheader linkfield ptr to macrofield ptr

 lfa>wid	( p1 -- p2 | 0 )				'lfa2wid'	hidden
	convert p1 lfa to ptr p2 to voclink posn

 wid>lfa	( p1 -- p2 )			(m,6)		'wid2lfa'	hidden
	find primary lfa of vocabulary wordlist

 idx>pfa	( ix -- p | 0 )					'idx2pfa'	hidden
	convert uot index ix (execution token) to pfa p

 lfa>pfa	( n1 -- n2 )			(m,14)		'lfa2pfa'	forth
	convert wordheader linkfield ptr to parameterfield ptr

 pfa>lfa	( p1 -- p2 | 0 )		(cm,47)		'pfa2lfa'	hidden
	convert wordheader parameterfield ptr to linkfield ptr
	ret 0 if no corresponding lfa found.

 >data  	( ix -- p )			(l4)		'todata'	root
	ref into re-located data-field in RAM of kernel-supplied variables,
	etc; aequivalent to -re- {>body}, applicable to kernel words, only.
	NOTE: kernel words store disp into data-space wrt @{d0} while new, 
	{create}d words store the disp to "body" directly as a kref'd ptr.

 lfa>body	( lfa -- p )					'lfa2body'	hidden
	convert lfa ptr to ptr to words' data space

 >body  	( ix -- p )			(a:c)		'tobody'	root
	ANS defines this to fetch the reference where "," etc. would store wrt a 
	-re- {create}d word which, with lib4th is data-memory and does not apply
	to kernel defined words' relocated alterable memory address -re- {>data}.

 latest  	( -- p )			(m,10)				forth
	return lfa of latest word in {current} vocabulary, which
	is the wordlist currently extended by new definitions.

 wid>top	( p1 -- p2 )			(m,6)		'wid2top'	hidden
	fetch top lfa p2 of vocabulary wordlist from @voclink p1

 uot>idx	( p -- ix )			(p)(m,13)	'uot2idx'	hidden
	get word index ix by uot execution ptr p.
	actually valid range of ix is 0 to @(lkindex)-1,
	absolute max is { (#tib) (ltab) - 4/ }, always less than 65535.

 idx>uds	( ix -- p )			(p)(m,7)	'idx2uds'	hidden
	return disp to base of uot for indirect call [uref uv.ultab+disp].

 uds>idx	( n -- ix )			(p)(m,9)	'uds2idx'	hidden
	return ix index into uot from compiled disp n wrt uot base ptr.

 xec>uot  	( x -- p )					'xec2uot'	hidden
	return uot ptr p to execution ptr x, ret 0 if x not in uot

 idx>uot	( ix -- p | 0 )			(p)(m,18)	'idx2uot'	hidden
	return ptr p to execution ptr by index ix, ret 0 if ix not in uot

 lfa>xec	( p -- x | 0 )					'lfa2xec'	hidden
	return execution ptr x from uot pointed to by wordheader via lfa p

 idx>xec	( ix -- x | 0 )					'idx2xec'	hidden
	return executionptr from uot by word index ix.
	(debugging: x is equal to code-ptr in assembly listing)

 idx>do	( ix -- x | 0 )					'idx2do'	hidden
	DOES>-entry of word by ix or, zero if not applicable.

 dsp>xec	( p1 -- p2 )			(p)(m,9)	'dsp2xec'	hidden
	return xec ptr p2 from dword disp at ptr p1.

 xec>idx	( x -- ix | -1 )		(cm,36)		'xec2idx'	hidden
	return uot index of execution ptr x, else -1
	(exec ptr is to library code, not to got of user program!

=====================================================================;
 l4whead.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/src/l4words.inc>
--------------------------------------------------------------------------


--------------------------------------------------------------------------------;

 NOTE:
 Due to nasm specific issues (deficiencies?) DO NOT CHANGE the general structures
 SETUP AND LOCATIONS! Current arrangement was found feasible after many (weeks of)
 trials and errors and apparently is on a very narrow path of possible solutions!

 List Items
	may be ordered to suit. in Forth, last entries will be found first.

 Additional Words:
	add standard wordheader w. <crea> macro
		[mark]<tab>crea flags,findname,asmname,parentvoc ;<bl>[comment]
		strictly stick to the above pattern, for orderly doc's generation,
		assign words type kathegory (re %define-s, l4words) for the docs.
	add word's
		executeable code at <asmname> to the rsp file in src directory.
		if not already present %include filename into <lib4th.asm>.
	add comment
		4th word, stack flow, etc, else {help} won't help... - re below

 Synonyous Words:
	use <acrea> instead of <crea> and insert the new defn to the list after the 
		one it refers to - nasm can't forward refer to <equ>, %define, etc.

 Kernel Variables & Values:
	use the pattern of
	<[mark]<tab>crea pfax|varf|2,{'..name..'},runtime,parentvoc,default ;<bl>[comment]>
	where '2' in the flag item can be any higher value, corresponding to the
	number of additional, following cells, and passed one less to <nxvari ..>
	<label> points to the default data structure
		label: nxvari 1		; ptr w/ disp to dataspace after sys.init
			dd ..data..	; default datafield
	<label> can be referred from kernel code as <label>v, re the rsp runtimes.
	lo-level access by, e.g.
		mov reg,[kref <label>v-Y]
		add reg,databot		; ptr to 1st data cell by %defined <databot>
 Kernel Deferred:
	deferred words require a provisional, additional field for the forget-linkage:
		<[mark]<tab>crea pfax|varf|4,{'..name..'},pdodefer,parentvoc,xeclabel
		label: dd I<dftword>,I<dftword>
	3rd datafield generated by kernel at system initiation time.
	<xeclabel> should point to deferred execution entry, e.g.
		mov ecx,<label>v-Y
		jmp pdodefer
	<dftword> required to be referrable by uot-index, thus requires a regular 
	word header or, in {novoc}. headerless words may be used at run-time, only.

	NOTE1:	counting entries, "nxvari", required because 
		"nasm" neither can backpatch nor 'look' forward...
	NOTE2:	<pfax> words cannot be 'immediate'

 Additional vocabularies:
	add vocabulary type wordheader w. <cvoc> macro
		cvoc flags,findname,vocname,parentvoc
	add ref at/to end of wordlist after header list
		(name)link: equ (name)top-last(name)
		or w. macro, <endvoc vocname>.
	add vocabulary
		executeable, preferrably to "l4sorder.inc".
	add comment
		some general description of the rsp voc, for {help} w/o name.

	flags	  re "lib4th.mac"
	findname  is text by which word can be found w. {find}
	asmname   label of executable in assembly source
		  which should be declared "global", for external prog refs.
	vocname	  ditto, defining a vocabulary
	parentvoc name of vocabulary in the wordlist of which the word
		  defined by this header will be found.
-
 root
	must remain the very 1st defn in wordlist.
	do not modify the <root> header.

 documentation
	<make html> uses a bash shell-script which is a bit funny with 'special' 
	characters, and other text evaluation. Thus pse, add new words by header 
	lines as below, exactly matching the explained pattern. 
	particularly, words the header-lines of which do not show a trailing 
	comment (at least the "; " part) might not appear in the html glossaries.

 { help forthword }
	takes its text from the rsp. glossary entries, which are extracted from 
	the assembly source, with <make doc>. {help} relies on a certain, very 
	simple text structure which is explained in it's glossary entry.

--------------------------------------------------------------------------------;

 prevlink, re <uv.voclink>
	initial vocabulary link in library .text segment,
	running asm-vari re previous linkaddress.

 lastroot
	required initial link, base ref of voc-link
	running asm-vari re previous linkaddress
 lkindex, re <uv.lindex>
	per word 16bit unsigned index into user offset table
,'-
?-;dfdtlk: dd 0; linkage will be initiated w/ 1st {is} or {deferred?}
,'-
,'-
,'-
,'-
,'-
,'-
,'-

================================================================
 l4words.inc <eof> ;[list]

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/ascictrl.inc>
--------------------------------------------------------------------------

=========================================================================;
 ascictrl.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/asm+resource.h.inc>
--------------------------------------------------------------------------


================================================================;
 asm+resource.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/colours.inc>
--------------------------------------------------------------------------

================================================================;
 colours.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/console_h.inc>
--------------------------------------------------------------------------

 console_h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/console_struct_h.inc>
--------------------------------------------------------------------------

 console_struct_h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/constants.inc>
--------------------------------------------------------------------------

 "sysdep.inc"
	includes system dependent constants which cannot be
	derived at runtime, neither from the proc fs nor, by trial. 

  conditional assembly

  __lockthread, dft: NOT defined
	if def'd block move operations executed w. interrupts disabled
	NOTE: <setuid> programs only!

	

================================================================;
  signals -re- man 7 

  default setup

  nsi(signum)
	signal mask for messages handler
  sgm(signum)
	signal mask for program exit handler
	re include/asm/signal.h
  srt(signum)
	signal mask for retry mode (re asm, segfault recovery)
  nms(signum)
	quiet, neither one of nsi, sgm

================================================================;
  ctrl-s

  ctrl actions, signals and/or linux console, re struct "termios"
	3	C		SIGINT
	4	D	EOF	logout(!)
	7	G		<bel>
	8	H		<bs><bl><bs>
	9	I		<tab>
	19	S		lock screen ("roll" off)
	26	Z	SUSP	SIGTSTP	-> job to bg
	28	\		SIGQUIT
	127			<del>
	

  AC_NUL,...
	ascii contol-character constants by AC_(ascii name)
	AC_DEL
		<del>ete at cursor posn, code 127
	AC_NBSP
		"non breaking space", code 160 in iso????-1 ("latin")
	AC_VT102, reg_vt102
		dft terminal query response string "vt102"
	AC_VT100x, reg_vt100x
		terminal query response ("enhanced", whatever...) "vt100" of xterm

================================================================;
  forth system constants:

	
	b_b		bits per byte (8)
	b_c		bytes per character (1), may be set to max. 4
	b_cell		bytes per cell (4), may *not* be changed!

	galign		subroutines entry alignment (4)
 alignment figures > 4 seem useless: no timing difference... (or even worse)

  vm registers

  KR	ebx		kernel ref reg, base of lib4th .text section
  PS	edi		parameterstack, datastack (push bottom up!)
			memory ref for <scas>,source for <movs>
  SP	edi		data-stack, synonym
  LP	esi		locals base-ptr
  lref	LP + (disp)	ref to local value/ptr
  RS	esp		return-stack
  UR	ebp		user vari reference base register (uref...)
  W	ecx		4th-vm W register (word address, wa, pfa)
  T	edx		4th-vm T register (temporary storage)
  uref	uvari		ref into user-vari via [UR-uv.link+disp]
  vref	vari		ref into data memory [vref ptr] = [VR+disp]
  kref	address-$$	ref into kernel by [kref address-Y] = [KR+disp]
			for kernel words & constant data (r/x memory)

  datatop		@dtop	kref-d @mtop
	 ..
  dataptr		@dp	64K+, extendable into .bss, bottom up
	 ..
  databot		@d0	dataspace
  codetop		@ctop	end of code-space
	 ..
  codeptr		@cp	bottom up, 64K
	 ..
  codebot		@c0	dictionary
  loclptr		@lp	@s0 bottom up
	

================================================================;
  user vari defaults:

	d_base	number conversion radix, dft decimal.
 	d_ccr	max 4 bytes newline ctrl code, dft (msb..<lf>lsb) sequence.
	d_bl	blank space, any code below equally valid for <bl> parsing, ascii 32.
	d_can	keyboard input char code for program termination, dft AC_EM, ^Y.
 	d_cmul	no. of consecutive chars to recognize <d_del>, default is 4
 	d_del	"delete", up to 4 chars used to deleting char under cursor, dft AC_DEL
 	d_bs	"backspace", up to 4 chars to retracting cursor by one posn, dft AC_BS
	d_substc
		text substitution delimiters, dft ascii 96 = "'", start in l.s.w, end in m.s.w
	d_tab	tabulator spacing, dft 8
	d_nvocs	max no. of stacked vocs., dft 16
	d_pchr	(lsb[32,126],[160,255]msb) ranges of printing chars
	d_escc	"\" {etype} escape char
	d_prp	up to 4 chars for (r), used for formatted text output, dft 4 chars of AC_BS
	d_frac	max 4 +ve chars to mark input numeric fractions (dec. comma, etc; dft ",."
	d_hdp	stg output char to mark output numeric fractions, dft ","
	d_nfm	max 4 +ve chars to mark bignum fractions (dec. comma, etc; dft ",."
	d_width	max leading part of a name copied to wordheader, dft 254 (system dep'd max)
		provisional (tested -> useless -> in-active):
	d_pydel pty output delay count, hard dft 10200, actual appropriate value will be
		determined at startup if stdin is pty; may be saved for later use instead 
		of dft. (pty-delay) set to dft by {out-pty?} query, if pty and vari unset.
	d_pydiv	timing divisor for automatic pty-delay detection, dft 34000

 
 
  blockfile constants
		note: implied size of a char is a(n 8-bit-)byte.
	b_buf		bytes per screenfile buffer (cons 1024, as of ANS-4th)
	b_scr		block per screen (1)
	c_l		c/l characters per line (64)
	bbuffers	no. of initial blockfile buffers (1 buf w/ 4 blocks)
			for bbufmem := (b_buf*bbuffers+PAGE_SIZE-1)&PAGE_MASK

  bupdt, mupdt 31		screenfile blocks' update flag, in <bufhead.u>
  bfile, mfile 30		(un-used: 4th input from file, in {sourcre-id})

  user variables flag(bit)s

  flag	vari	posn	if flag set:

 	uv.aux	byte#
  skey	l.s.b.	0	single keystroke console mode
  klok	m.s.b.	3	kernel to input-job lock

	uv.bits	bit-value, bit#
  caps, mcaps	16
			case dependent word search
  bbign,mbign
		16	next numeric input is bignum (counted integer)
  branu,mranu
		17	next numeric input is 'ranum'
			(ordered cells pair, 'real', rational, reelle zahl...)
  bqranu,mqranu
		18	next numeric input is quad 'ranum'
			(ordered quad cells pair)
  bfloat,mfloat, mfloatm
		19	set persistent numeric input mode to 'double ranum'
			'mfloatm' defines the set of bit-values (mfloat|mranu|mquad)
  bquadm,mquad 20
			next numeric input is quad
  bcall,mcall	21
			cpl direct calls by disp to words, instead of uot-indirect;
			controlled {call-by-disp}, {call-by-uot} of {compiler}-voc.
  bfmac,mfmac	22
			set if <bcmac> set and a macro compiling word was found
  bcmac,mcmac	23
			compile words as inlined code - where possible
  bedpl 24(l.s.b.), medpl 24..31(bits), edpl 3(byte)
			auxilary dpl for -ve exponent w/ rational numbers input

 quad ranum if mfloat,mranu,mquad all set and, medpl mask = $080

	

  i/o channels & flags

  cdt_num
	no. of channel definition tables, dft 32 (any power of 2)

  cdt_bsize
	binary exponent of cdt_size in :cells:, dft 4 (cdt_size:=16 cells)

  cdt.chid
  +ve file descriptor, dword at <cdt.chid>, 4th per {ch-id}.

  chinval
	cons (-1) pseudo file descriptor at invalid channel id
  stdin, stdout, stderr, work, prt, scr1, scr2, kbd
	pre-defined channel numbers

  O_ANYF	pseudo open-flag for {create-file} wrt serial devices.
	
  cdt.iofl
  file descriptor flag bits, dword at <cdt.iofl>, 4th per {ch-flags}.

  binval, minval 31, sign-bit of flags dword
	not normally used but, if set denoting that associated
	channel id does not correspond to a valid file descriptor
  bcons,mcons	30
	set if fd is echoing console
  bicon,micon	29
	set if 2ndary console opened
  bcflg,mcflg	28
	character received flag, set if any char present (buffered)
  bcrgt,mcrgt	27
	charcter reget flag, set if non-ascii char received (buffered)
  bedif,medif	26
	edit mode, 1st cursor backup done
  bptyf,mptyf	25
	set if channel is a pty device
  bqryf,mqryf	24
	{query}-compliant {accept} mode, terminating if buffer full
  bchrf,mchrf	23
	nonblocking i/o if flag set, else "ndelay"
  biowf,miowf	22
	inserting editting mode, overwriting if bit unset

  cdt.perm
  file descriptor flag bits, dword at <cdt.perm>.

  d_fperm
	new files' permissions, dft 600. on file open taken from user vari (fperm),
	required because ANS <fam> defined to the unsufficient size of a single cell.

	

  termios ioctl values

  qtermtimo 1
	VTIME timeout value, dft 1, should always be >0 (re below)
  qtermnum 1
	VMIN min. no. of chars to returning error free (if VTIME > 0),
	dft 1, after timeout read returns zero if VTIME := 0!

	VTIME	VMIN	(glibc 2.1.3 description)
	>0	>0	wait until VMIN char or timeout VTIM wrt each char
	 0	 0	ret immediately, 0 if no char available
	>0	 0	ret after timeout, 0 if no char available
	 0	>0	wait until at least VMIN chars received

 sys_select

 d_ustimo 0x7fffffff
	{wait4in} timeout default, used on entry to {accept}
	

================================================================;
  compiler, interpreter

	

 assembler cons, for {see} etc. eax is @tos
	call/jmp 4th-word, fetch/sto kref'd/user mem, dup, drop, nop, ret

 x_dcall  b	<call PC+4+disp>, call a word by disp
 x_ucall  w	<call [UR+disp]>, call a word by uot index
 x_djmp   b	<jmp PC+4+disp>, jump into a word by disp
 x_ujmp   w	<jmp [UR+disp]>, jump into a word by uot index

 x_nop    b	<nop>, alignment
 x_ret    b	<ret>, unnest, {;S}
 x_spush  b	<stosd>, op-code for push @tos to nos, {DUP}
 x_push  b	op-code for push reg
 x_pop   b	op-code for pop reg

 x_ipush  w	<stosd\;mov eax,imed>, push imed, i.e. {LIT}eral or cons, vari, etc.

 x_drmov  w	<mov eax,[dword kref+disp]> fetch from dataspace - {integer}, {VALUE}
 x_ubread w	<mov eax,[byte UR+disp]>, fetch uvari at byte-sized disp
 x_udread w	<mov eax,[UR+disp]>, fetch uvari at dword-sized disp

 x_drmov  w	<mov [dword kref+disp],eax> sto to dataspace - {TO}
 x_ummov  w	<mov [byte UR+disp],eax>, store uvari at byte-sized disp
 x_ummov  w	<mov [UR+disp],eax>, store uvari at dword-sized disp

 x_rread 3b	<mov eax,[kref eax]>, fetch from kref'd memory - for {@}
 x_dread 3b	<mov eax,[kref eax+disp]>, fetch from kref'd memory w. dword disp
 x_dread 3b	<mov eax,[kref eax+disp]>, fetch from kref'd memory w. dword disp
 x_dalea w	<lea eax,[kref disp]>

 x_lread w	<mov eax,[lref disp]>, fetch from local memory
 x_lstor w	<mov eax,[lref disp]>, store to local memory w. dword disp
 x_lpsto w	<add eax,[lref disp]>, add to local memory w. dword disp
 ptr to local

 x_eaxc w	<mov eax,ecx>, prior to <spush> in {to}, {+to}
 x_lptr1 w	<mov eax,LP>
 x_lptr2 3b	<sub eax,KR; sub eax,disp>, disp follows

 "lib4th" doesn't implement traditional distinction between interpreting
 and compiling state. It always compiles something executeable, terminated
 by an <rts> code and then decides whether to immediately executing this
 piece of code and removing it from compilespace, which is "interpreting",
 or leave it in place until the surrounding structure(s) fully resolved,
 which is "compiling". the latter state applies to any structured code, i.e.
 "IF" .. "ENDIF" as well as ":" .. ";" sequences, equally.
 A "structure" to this respect is any source sequence which requires more
 than a single executeable to be compiled before it can safely be executed.
 "compiling" simply is delaying execution of compiled code until structures
 nesting levels fully resolved.
 A hi-level 4th word being just one of those structures, execution of which
 is "delayed" until invoked explicitely and which can be repeated.

 variable {state} used for two different purposes:
	l.s. half cell is structures nesting levels counter.
	m.s. half cell carries several special states flags.

 {state} bit-flags and masks:

 bimed, mimed #31, 80000000
		immediate words not executing while in a structure
		set by {[COMPILE]} and, {POSTPONE} or equivalent {[_]}.
 bbrac, mbrac #30, 40000000
		temporarily interpreting, after {[} within a structure;
		interpreting, emergency only, after errors, etc.
 basciz, masciz #28, 10000000
		currently compiling literal string is asciz, for (z"), etc.
		flag instantly reset, may be set but not read by a program.
 bword,mword  #27, 08000000
		persistent code after wordheader compilation
 bnnam,mnnam  #26, 04000000
		headerless word compilation
 blocl,mlocl  #25, 02000000
		word has local memory def'd
 blocr,mlocr  #24, 01000000
		word refers to previously initiated locals

 search order storage bit-flags and masks
	flags stored in cell at lower address near the rsp. wid in vocabulary stack.

 bsvoc,msvoc	#31
	'vocabulary searched' flag, to avoiding multiply searching of wordlists.
 bfpcpl,mfpcpl #30
	floating point numbers ('ranum') compiling/reading vocabulary (n.i.)

	
 
 whead.f
 <ffa> word-sized header-field of bit-flags

	bit#	mask	useage
	0	noxf	inhibit execution flag if no other bits set or, 
	0..3	xwfl	parameter-fields count mask (0..15)
	 4	vocf	word is a vocabulary, fieldcount=no. of wordheaders -?-
	 5	smud	word name finding disabled - re {smudge}, {unsmudge}
	 6	pfax	xec from pfa, pass ptr to body to ecx = W of 4th vm.
	 7	imed	immediately executing word - re {immediate}
	 8	wcas	find always letter-case dependently - re <ncas>, {lc-depend}
	 9	locf	double purpose: 1) local value; used while compiling, only
					2) 'normal' word w/ compiled in {forget:} action
	10	ixec	immediately execute when not in compiling state, e.g. {bye}
	11	inif	initalization from header-fields, @pfa is kref'd ptr to xec
	12	varf	type {variable} word, 2nd-ary pfa is disp to vari-space
	13	ncas	find always letter-case independently - re <wcas>, {lc-ignore}
	14	nopt	suppress backward code optimizing
	15	cmac	word can be compiled as inline code ("macro")

 noxf		0
	bit#0 set if find and execution disabled, for {novoc} words.
 xwfl		0..3
	additional parameter-fields count mask (0..15),
	no. of dwords (cells) after concerning word header's pfa.
	this field is valid only if at least one other flag set, otherwise 
	a word w. bits 0..3 set will be seen as "smudged", i.e. not found.
 vocf		4
	word is vocabulary, fieldcount is no. of wordheaders
 smud		5
	word finding disabled, un-set by {unsmudge}, toggled by {smudge}
 pfax		6
	execute from pfa in header, pass ptr to body in ecx
 imed		7
	immediately executing, set by {immediate}
 wcas		8
	word will always be found letter-case dependently
 locf		9
	word is local value
 ixec		10
	do not compiled execute when in interpreting state;
	provision for the emergency case - e.g. {bye}, {cold}.
 inif		11
	word which requires initialization from header data
	@pfa is ptr to init. code wrt beginning of module
 varf		12
	2nd-ary pfa holds disp to beginning of variables dataspace
 ncas		13
	word will always be found letter-case independently
 nopt		14
	suppress backward code optimizing
 cmac		15
	compile-macro, bitmask to compiling inline code

	
 accumulated:
	combined flags, internally used.

 ihead	= imed|nopt
 locvf	= nopt|locf|pfax|imed|varf|2
	local value combined header-flags
 kvalf	= pfax|varf|2
	kernel value header-flags - (notwendige, nicht hinreichende bed.)

	
 
 4th words, initial pointers & defns
	to setting up linkable dynamically loadable wordlists.

 vocnfa, rgvnfa	cons: (1,blank space,0,0)
	unique(!), dummy vocabulary name, data/register values
 vocrfa, rgvrfa	cons: (2,0,0,0)
	dummy vocabulary RAM linkage name, data/register values
 modnfa, rgmnfa	cons: (0,0,0,0)
	module base header dummy name

 v0.0.50: lastroot, prevlink, lkindex def'd in "lib4words.inc"

 lastroot
	required initial link, base ref of voc-link
	running asm-vari re previous linkaddress
 prevlink, re <uv.voclink>
	initial vocabulary link <Vz> in library .text segment,
	running asm-vari re previous linkaddress.
 lkindex, re <uv.lindex>
	per word 16bit unsigned index into user offset table
 ixalias
	synonymous words count, initial value := 0
 variptr
	index into vari space (alterable memory), dft = 0.
	final value at <tophead> for initial @dp.
	

================================================================;
  Forth system memory

  :preliminary: per task memory
  ranges adjusted to page-size!

  adr: [ hi ...                                          ... lo address range ]
  .ss  [ r0 ret-stack 64K <-|-> data-stack 64K s0 ][ tib 4K ][ uvari 64K+ ... ]
       [-  -                     -  (libraries) -                        -   -]
       [-    system heap - extends .bss by sy_brk, managed by lib4th code    -]
  .bss [- ...  64k+ data-space  ... d0 -] [- ...  64(128?)K codespace ... c0 -]
  .text[- calling application programm -]

  workspace
	d_npad			4-aligned(!) disp from {here} to {pad}, 4K, min. 256 bytes
	d_mintib		min. local t.i.b. for nested {included}s, 256 bytes
	pthfsize		{place}, {+place}, {path+file} string storage limit
				dft %xdefine-d to max(PATH_MAX,PAGE_SIZE)

  allocation blocks
  cdtmem
	cdt_num*cdt_size + cdt_size(for kbd channel), extends data-space
  bbufmem
	memory space for blockfile buffers (b_bufbuffers), extends dat-space
	d_dictionary		128K compilespace, w. {pad},{hld},{here}
	d_dcmin			max(1K,PAGE_SIZE) compilespace minimum
	d_dstack, dsmin		64K data stack, min 64K
	d_rstack,d_rsmin	64K returnstack & locals, min max(4K,PAGE_SIZE)
	d_uarea,d_uamin		64K user variables/data, min max(4K,PAGE_SIZE)
	d_varispace,d_vsmin	64K per task dataspace, min max(4K,PAGE_SIZE)
	d_ntib			max(4K,PAGE_SIZE) terminal input buffer
	d_safecode		safety margin towards top of code-space max(1K,PAGE_SIZE)

  .bss section:
	d_bssmem		std. per task .bss memory size
				dataspace(64)+codespace(128) = 192K

 .ss section:
	d_ssmem			std. per task .ss memory size
				rstack(64)+dstack(64)+ntib(4)+uarea(64) = 196K

 sigle words executing job
	d_jobstk		minimal single words executing .ss setup, just stacks = 2K
				plus <d_jobbss> for number conversion, etc = 2K, sa. 4K
	d_jobss, d_jobbss	minimal compiling jobs memory setup
				dcmin(1)+dsmin(64)+uamin(1)+ntib(4)+vsmin(1)+rsmin(1) = 68K

	
	
================================================================;
 asm cons:

 s_sqr2n2, s_sqr2n3, s_sqr2n10, s_sqr12n2, s_pi, s_e, s_e3by16k, s_c      
 scaling constants (val := arg * 1st_cons / 2nd_cons)
 (re r.zech, forth 83, pg 43)

 preset <uvp>:=0,<uvi>:=-4,<uvs>:=-1 for macro <uv>

 uv, macro 1
	setting up the user vari names and cell size disp's
	%define uv_%{1} as shortest [<ea>] ptr

 :preliminary: user vari setup

 uv.utop
	beginning of pre-defined user area = top of user task memory, growing down
 names the 2nd part of which does NOT begin wit "u" are byte addressable, i.e.
	those of pattern {uv.u...} are not byte addressable (single exception: uv.u0)!
	stored memory references are all relative to kernel ref reg <kref> with a few
	exceptions w. pointers which are used internally, only.
	the "uot" stores true ptrs to the rsp. words' execution entry.
	re "lib4th.asm" and "constants.inc" about usage and default settings.

 do not use utop...uedi for an application! reserved for inner task scheduler ;
 vocabulary stack builds top down: ------------------------------------------ ; (v- - -v)
 vocabulary stack growing 'down', extending into non-byte-addressable space
 each item is double cell, voc-link ptr and searchflags cell, used in {find}
	
---------------------------------------------------------------

 (*) mode-7: 'safety fast'
================================================================
 constants.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/errno.inc>
--------------------------------------------------------------------------


 errors

 _nr_
	assigned, msg.no. labels counter

 dbn 3 (for <dbs>, only)

 dbs, macro 1-3
	label & msg string assembly, errnum defn
	compiles list of word counted message strings,
	%define-s S(errorname) message strings as "S"-prepended standard error names,
	%assign-s (errorname)  -ve(!) error numbers as standard error names.
	<mn> %define-d to top msg.no. (used in "debug.inc")
	<_nr_> incremented by one, after label/stg defn.

 error messages strings
 two macros to be used in conjunction:

 ertstg, macro 0-1
	compiles labels & errormessages, if no argument given,
	defines -ve error codes and names
	for instance:
		%define SEPERM 'Operation not permitted'
		%assign EPERM -1
 	<rt> label, base of msg strings
	<m.ro>,<a.ro>,<e.ro> internal labels, and
	<e1>..<e124> refer to message texts, rsp., and will be
	stet up by <ertdsp> for access by -ve number with <ermstg>.
 ertdsp, macro 0
	compiles reference table of disps re <rn> to errormessages
 	<rn> label, base of disp's to msg(no.*2) strings
	<rm> double, top message no.

 label: ermstg 0
	subroutine, pic, find error message
	no regs changed if not applicable
 i:	eax	(assumed) ernum
 o:	eax	eax
	ecx	ecx or message text after leading <nl>
	edx	edx or text count, trailing <nl> inclusive

================================================================;
 signals
 

 sbn 3 (for <sbs>, only)

 sbs, macro 1-3
	label & msg string assembly, errnum defn
	compiles list of word counted message strings,
	%define-s S(signal names) as message strings,
	%assign-s M(signal names) as -ve error numbers,
	%assign-s B(signal names) as bit-values.
	<mn> %define-d to top msg.no. (used in "debug.inc")
	<_nr_> incremented by one, after label/stg defn.

 signal messages strings
 two macros to be used in conjunction:

 sigstg, macro 0-1
	signals, re macro <sbs>.
 	<rs> label, base of msg strings
	<m.rs>,<a.rs>,<e.rs> internal labels, and
	<s1>..<s31> refer to message texts, rsp.
 linux signal number defn's
 signals
	default actions are as follows:
	:1:
		Abnormal termination of the process. The process is terminated
		with all the consequences of _exit() except that the status
		made available to wait() and waitpid() indicates abnormal
		termination by the specified signal.
	:2:
		Abnormal termination of the process. Additionally,
		implementation-dependent abnormal termination actions, such as
		creation of a core file, may occur.
	:3:
		Ignore the signal.
	:4:
		Stop the process.
	:5:
		Continue the process, if it is stopped; otherwise ignore the
		signal.

 sigdsp, macro 0
	compiles reference table of disps re <sr> to signal messages
	macro <ermstg> can be used to reference signal names strings
 	<sr> label, base of disp's to msg(no.*2) strings
	<sm> double, top message no.

================================================================;
 errno.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/fcntl.inc>
--------------------------------------------------------------------------

 	open/fcntl

 F_...
	(f_)flags, fcntl cmd

 F_...
	sockets

 FD_CLOEXEC
 	F_[GET|SET]FL

 F_..LCK - at <flock.l_type>
	posix fcntl() and lockf()
	old bsd flock ()
	ops for bsd flock(), also kernel - at <flock.l_whence>

 flock
	structure for bsd flock()

================================================================;
 fcntl.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/ioctl_h.inc>
--------------------------------------------------------------------------

 ioctl command encoding: 32 bits total, command in lower 16 bits, size 
 of the parameter structure in the lower 14 bits of the upper 16 bits.
 Encoding the size of the parameter structure in the ioctl request is
 useful for catching programs compiled with old versions and to avoid
 overwriting user space outside the user buffer area. The highest 2 bits
 are reserved for indicating the ``access mode''.
 NOTE: This limits the max parameter size to 16kB -1 !

 The following is for compatibility across the various Linux platforms.
 The i386 ioctl numbering scheme doesn't really enforce a type field.
 De facto, however, the top 8 bits of the lower 16 bits are indeed used
 as a type field, so we might just as well make this explicit here.
 Please be sure to use the decoding macros below from now on.

 Direction bits.

 createing numbers;

 decode ioctl numbers..;

 for the drivers/sound files...;

================================================================;
 ioctl_h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/ioctls_h.inc>
--------------------------------------------------------------------------

 ioctls.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/kd.h.inc>
--------------------------------------------------------------------------

=========================================================================;
 kd_h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/lib4th.mac>
--------------------------------------------------------------------------

 %include "sysmac.mac"	datatypes, substitute mnemonics
 %include "reloc.inc"		global/external labels generating macroes
 %include "constants.inc"	assembly & system constants

 %include "l4struc.inc"	lib4th specific data structures
	

 CELLS(x)	%define-d address space items multiplier

 %define-d returnstack reference by
	TOR(#cells)

 %define-d datastack reference by
	TOSPULL(#cells), TOSPUSH(#cells), TOS(#celldisp)

 spop 0-1, inl, 5 bytes
	pop eax from datastack, eflags unchanged(!)
	optionally %1 items

 spush 0-1, inl, (code: 1 byte per pushed cell)
	no. %{1} times push eax to datastack, preserve eflags, dft %1=1.
	

 kernel locals

 kloci 1	initiate no. %{1} of local values,
		modifies next occurrence of <ret> mnemonic -re- <locret>!
	NOTE: local memory should be prepared, for instance w/
		push dword[byte uref uv.s0]
		kloci 6		; init local vari
		mov ecx,[esp]
		add ecx,KR
		mov [esp],LP	; save allocation ptr
		mov LP,ecx	; rst working LP
	and, LP restored from allocation value, before <ret>urn - re "klocret" macro
 klocwrite(disp,reg)	store reg to local by disp
 klocread(disp,reg)	read local by disp into reg
 kloc@(reg,disp)	fetch local value to reg by disp
 label: klocs %1, advance to %1-st cell for (next) local(s)
 label: klocv	define a local value, optionally assign disp to @s0 =: <label>
 label: klocz	define a zero-initiating local value, optionally assign disp to @s0 =: <label>
 klocr	de-allocate local values, count as previously initated w/ <kloc>
	NOTE: before entry into "klocr", by redirected <ret> token, rst LP from alloaction ptr, 
	-re- "kloci" macro (above)
 locret	insert <klocr> and <ret>, undef. local <ret> macro
 klocread 1-2	read local %{1} into reg %{2}
		dft %{2} = <eax>
 kloc@ 2	fetch local value by disp %{2} to reg %{1}
 klocpop 1	push @tos copy local value by disp %{1} to @tos
 klocwrite 2	store reg %{2} to local %{1}
		dft %{2} = <eax>
 kloc_s 1-2	store reg %{2}, dft = eax, to local value by disp %{1}
 kloc_to 1-2	store and drop @tos, <eax> to local value by disp %{1}
		any optional %2 to suppressing <spop> generation, for no drop from tos
 kloc_add 1	add and drop @tos, <eax> to local value by disp %{1}
		any optional %2 to suppressing <spop> generation, for no drop from tos
 kloc_xg 2-4	exchange local values by disp %{1} and disp %{2} from reg %{1},
		optionally use temp regs %{3}, %{4}
		using mm0, and mm1 w/ 2-/3-args variant
 klocptr 2	fetch ptr to local value by disp %{2} to reg %{1}

 jmpu 1-2
	enter lib4th user vector w/ false data protection, i.e.
	0 < @arg=index < top-index or 65535 < @arg=true-address
	arg %{1} is asm-name of user vari w/o. "uv." praefix
	%{2} entrypoint dft <perform.i> which may be substituted.

 label:C
	initiate system-macro
	generate intermediate MD and MM with name of entry label
 C name
	end of system-macro
	generate MM(name) %define-d as disp of $ to entrypoint

 label:M
	initiate compile-macro
	generate intermediate MD and MM with name of entry label
 M,name
	displaced entrypoint, bytes count begins at posn M,name
	with <N%{2}: equ $> at entrypoint
 M name
	end of compilemacro
	generate MM(name), MD(name) %define-d size & disp to entrypoint

 endvoc 1
	cpl vocabulary %{1}'s final data, after wordlist

 [label] nxvari, macro 0-1
	cpl dword variptr, increment ptr by %{1) rsp. by 4
	compiles "<label>v" at pc, %assign-s value of dataptr to "<label>vv"
	

 crea 3-5 root,noop
	args: flag,wordname,asmname,voc,label; -re- file <l4struc.inc>
		1: 32 bit headerflags
		2: name string
		3: label of code entry
		4: wordlist
		5: 2ndary label, linkname & indexname-extn for <pfax> & <varf> words
 if __LIB4TH defined:
	create ordinary word header entry
	1:flags 2:code-entry (subroutine!) 3:name
	%{3}:function and un-typed I%{3}, L%{3} defined "global"
 if __LIB4TH not defined:
	just setting up external references to
	%{3}, C%{3}, I%{3}, L%{3}

 acrea 3-4
	create synonym, dft in {forth} wordlist
	entry in uot expected previously defined

 cvoc 2-3
	create macro for vocabularies.
	builds double header, 1st regularly w. <crea> macro and
	2nd as vocabularies dummy header w. words base-linkage.
	arg 1 of crea implied and set to <imed|(1&xwfl)|vocf>,
	%1 = name, %2 = exec. label and search order name prefix.
	defines global/extern: V%{2}, %{2}top, %{2}link
	other labels as from <crea>, and %{2}vnfa.

 kernel list-constructs

 ccas	5-*
	args name,wordlist,datalabel,type(0,ff), item(s)

 cassoc 5-*
	args flags,name, wordlist,datalabel,type(0,ff), item(s)

 crange 5-*
	args flags,name, wordlist,datalabel,type(0,ff), item(s)
	

 TICK 1-2	any 2nd arg can be used for code alignment
	1 arg,  cpl 6 bytes: push cpl'd ix I%{1} to @tos
	2 args, cpl 8 bytes: push ix from wordheader L%{1} in library

 icons 1
	inline compile constant (11 bytes)
	takes optional global label as a "function"

 dcons 1
	subroutine constant (9 bytes)
	takes optional global label as a "function"

 scons 1
	inline constant from W-register by dummy subroutine call
	takes optional global label as a "function"

 label:uvuv 0-1
	the respective user vari access defn in "lib4th.asm", by name
	<label> is user-vari name after 'uv.', which might trigger an error 
	if name already def'd. then use label=4thname and %1="uv.(variname)"
	compiles macro flags, uvutop<index<uvubot long:9, else short:6 bytes.

 label:uiui 0-1
	the respective user vari access defn in "lib4th.asm", by uot-index
	<label> is user-vari name after 'uv.', which might trigger an error 
	if name already def'd. then use label=4thname and %1="uv.(variname)"
	compiles macro flags, uvutop<index<uvubot long:9, else short:6 bytes.

================================================================;
 tests

 call4 1-2, inl
	macro, test forth word by u.o.t. index
	%{1}: name, %{2},optionally: temp reg, else ecx
	refers to previously defined L(%1), defines it "extern"
	cpl 7 bytes, vari ;0fb78b(disp kref to ifa)
	 +  7 bytes, cons ;ff948d(disp uref to uot)

 jmp4 1-2, as call4

 calli [reg]		macro 0-1
	call subroutine by uot index in reg, dft eax: 4th {execute}

 jmpi [reg]		macro 0-1
	jump into subroutine by uot index in reg, dft eax

================================================================;
 forth

 label: i4th_nty 0-8
	startup structure in non-bss section, re <i4th> in file "l4struc.inc"
 .ntry:	inital execution entry true address	(quit)
 .bootp	ptr to supplied loadfile/data, etc
 .dstack	size of datastack			( 64K)
 .rstack	size of returnstack			( 64K)
 .tibmem	size of t.i.b.				(  4K)
 .uarea	size of user-vari and uot area, min 64K	( 64K)
 .cplmem	size of compilespace			(128K)
 .datamem	size of dataspace (and word-headers)	(  64K, extendable)
	
 i4th_ref 1	<extern>al references

 Setting up the Basic 4th Job

 [label:]START4TH 0-4
	initial macro to setting up a "lib4th" based forth system,
	entry label is <_start>, macro ends with <(label)_s4th>.
	assembly can then continue w. hi-level 4th calls
	until end with END4TH macro.
	initial {context} and {current} set to {forth} vocabulary
	<[label]_gotc> additional subroutine compiled by macro to fetching
		ecx := got-reference
	located in codespace before <_start> entry.
	disable ref to got code generation, prior to macro invocation w.
		%define __startgot_omit
 args:
	%3:ptr to true address of application <quit> entry
	  if >0: true address, initialize and jmp into user supplied interpreter
	      0: init and jmp into lib4th outer interpreter, {quit}, no return to application
 	     <0: init and ret to application, store address from <vquit> to (quit) user-vari
	%4:startup name, <progname> for name from arg(0), dft <noname>
 example with default args:
 	START4TH kend,help,vquit,noname
		callx ...
		callx ...	; program code
		callx ...
	END4TH kend
 minial code compiling
	%define __startgot_omit
	START4TH kend,0,,''
 START4THL
	listing version of START4TH

 END4TH 0-1
	%1 last label of the entire program, defaults to <kend>
	last address in .text, end of memory for <save-system>
	aligned to 256 bytes to persuading "nasm" to beginning
	the .bss section in an orderly aligned manner...
	must remain last label and after any data in .text section!
 NOTE (v0.0.57+):
	This reference substituted by sys_brk 0, which returns latest
	top of .bss section and thus dispenses with the last one hard
	coded reference, which was formerly required.

 Setting up a 4th Clone - re "glossary".
 Capabilities of Linux clones not fully explored, yet, thus :preliminary:!

 [label:]CREA4TH 1-4 taskmem,0,local
	macro to setting up a "lib4th" based forth clone,
	entry at optional <label>, macro ends with <(label)_c4th>.
	calls <terror> message display if call to <crea4th> failed.
	assembly can then commence w. hi-level 4th calls
	until end with END4TH macro.
	initial {context} and {current} set to {root} vocabulary
 args:
	%1:clone's entry address
	%2:size of alterable memory, defaults to <takmemory>, re "constants.inc"
	%3:optional ptr to asciz name of cloned job, re %4
	%4:dft <local>, any other identifier for external name ref wrt ..got

 example with default args:
		..(program)..
 	CREA4TH jobentry,taskmem,0,local
	ACTV4TH clonflags
		..(program)..	; caller continues
 at <jobentry>:
	CLON4TH vquit-Q		; job entry
		callx ...
		callx ...	; program code
		callx ...
		jmpx bye	; terminate clone

 [label:]ACTV4TH 0-1 clonflags
	activate previously set up 4th clone, re CREA4TH
	macro entry expects eflags and would do nothing if S flag set.
	%1: flags to sys_clone, dft <clonflags>, re "constants.inc"

 [label:]CLON4TH 0-1 vquit-Q
	start a 4th clone, must be inserted at entry level, un-nested
	esp is job's stack, readily set up w. arguments, regs, etc.
	%1 for initial <vquit>

================================================================;
 lib4th.mac <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/limits.h.inc>
--------------------------------------------------------------------------

================================================================;
 limits.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/nasmmac.inc>
--------------------------------------------------------------------------

	pre-definable macroes global listing on/off via asm-vari

 import 1-2 name
	%include %1 if not already done; binary mode if %2=bin

 %macro num_stg 1 .nolist
	db secimal 8 digits number to 8 bytes text stg
	nasm: w/ %assign no (not even relative disp's) forward refs useable!
	      <db..> would do, but cannot add for ascii/hex...

 %macro list 0-*.nolist on;[nolist]
	useless substitute to upgraded nasm, just to preventing "errors"

 %imacro _message 0-*.nolist
	silly 'helper' to list macroes arguments by _content_

 jr
	<jmp short>

 disp
	<jcc/jmp disp [label|abs.expr]>
	cpl shortest branch code, backwards only.

 a32
	noop if __OPTIMIZE__ =/= __O_SPEED__, else
	align 32 if 8 bytes or less below a 32-byte bound, else align 4
	_ascall_	;seg-prefixed call, disp 4-aligned (eForth, muell!)

 label: aligned 2
	assign by %{2} (dft=4) aligned number %{1} to <label>

 oalign 0-3+
	alignment of 2^(%{1}), optionally displaced by %{2} bytes
	%3 unset (or non-numeric):
	align by neutral opcode insertion or, <jmp short (disp-2)> if disp > 15
	%3 numeric:
	align by insertion of the required no. of {db %3}.

 AMODE 0-1
	<%assign (var) 0/1> to addressing mode of operand %1
	var = one of AER(unknown), REG, TXT(string), EA(other)

 label: min 2, %macro - but, "nasm": neither variant works!
	%xdefine %00 to the lesser of two args
 label: max 2, %macro
	%xdefine %00 to the greater of two args

================================================================;
 nasmmac.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/posix_types.h.inc>
--------------------------------------------------------------------------

================================================================;
 posix_types.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/ptrace.h.inc>
--------------------------------------------------------------------------

================================================================;
 ptrace.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/pushpop.mac>
--------------------------------------------------------------------------

	push dword by unsigned immediate byte - not covered by modified <push>

 push_sbyte(imed)
	push dword by sign ext'd immediate byte - not covered by modified <push>

 push 1-*
	multiple push dwords <push a,b,c,...>, eflags preserved,
	storage order left to right as with consecutive <push>es,
	%xdefine-s register list <regl> which can be used to 
	restoring with pop: <pop regl>
	!! debugging: <regl> saved within DUMP, PFBIN, PFSYM, PRBIN, PRNUM,
	!! PRSTG, PRTXT, WKY but, overwritten by "debug.inc" subroutines.
	! requires %xdefine, from updated to at least 98e version nasm !

 pushsys 0
 popsys 0
	push/pop regs which may be clobbered by syscalls: ebp,edx,ecx

 pop 1-*
	multiple pop in reversed order <pop a,b,c,...>, right to left
	!! use of %xdefine-d "regl" seems unsafe, verify !!

 mpush, mpop
	%assign-ed for multi-push/pop
	max no. of items up to which using true mnemonic
	default %assign-ed to 8/2

 s_<reg>, s_tor
	internally for readad/writead (re below)
	disp into storage on tos from <pushad>

 readad 2
	read reg %1 from <pushad> reg %2 storage
 writead 2
	store reg %2 to <pushad> reg %1 storage
 xgtosd 2
	xchange reg %1 and <pushad>-d reg %2 storage

	
 multi push/pop to return-stack. in-active, enable defns in source-file
	reg-vari set up for eforth, modify to actual requirements!
 %macro rpop 0-*,@TOS
	rpop		pop @RS to @TOS
	rpop reg[,reg,...]
	rpop regl	pop from RS to 'regl' - re <rpush>
	rpop {num}	pop num times @RS to @TOS
	rpop <ea>	pop @RS to non-reg <ea>

 %macro rpush 0-*,@TOS
 pre-decrement & store to RS, %define <regl> to list of args
	rpush		copy @TOS to RS
	rpush reg[,reg,...]	copy reglist to RS, last arg to TOR(0)
	rpush {num}	copy num times @TOS to RS
	rpush <ea>	copy non-reg ea

================================================================;
 pushpop.mac <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/reloc.inc>
--------------------------------------------------------------------------


	inl		compiles inline code
	sub		compiles a subroutine, takes a label
	imac		macro name case in-sensitve
	0-*	etc.,	macro w. arguments specification

================================================================;

 GETGOT 0-1	%1=<reg> or ebx
	fetch relocatible elf code vari ref, by
	<ea wgot> independent of g.o.t got or not
	macro in-active and <wgot> empty if __NO_PIC defined.
 =>	UN-SAFE - VERIFY!	<=
 i:	%1 reg	dft <ebx>
 o:	%1	ref addr
 c:	%1

;------------- das spielt ------------- ;
   mov dword [tbuf+80],VER<<16|EXT
;------------- das spielt ------------- ;
   get_GOT
   PRNUM ebp
; auf tbuf nur _ein_ d-posten angegeben
   PRNUM [ebp+tbuf wrt ..gotoff]
   mov dword [ebx+tbuf+24 wrt ..gotoff],0x99|EXT<<16
   PRNUM [ebp+tbuf+24 wrt ..gotoff]
;------------- reloc.inc -------------- ;

 "lib4th" support

 kernref 0-1	%1 := reg, inl
	dft ebx or, %1-reg to segment base reference <$$>. - (slow!)

 XN 2-*
	define (a list of) "extern"al labels, %1 determines which ones,
	or-ed together to accumulate for several labels types:
	%1 = 1	 %{2}:function    code entry
	   = 2  C%{2}:data	\ lib4th
	   = 4  I%{2}		 )wordheader
	   = 8  L%{2}:data	/ references
	   =16	define 'global', instead of 'extern'
	%undef __LIB4TH and %include "lib4words.inc" for all "lib4th" hi-level words

 label:GL
	define global label:function

 label:A	0-*
	label:A
	initiate 4-aligned local to source .text <label>
	%1 may be another macro, for instance
		label:A M	(f8 macro and label)
		label:A N	(un-typed label)
		label:A <num>	4-aligned + <num> nops before <label:>

 label:GA	0-*
	label:GA		(label re global function)
	initiate 16-aligned globally accessible .text <label>
	%1 may be another macro, for instance:
		label:GA M	(f8 macro and label re global function)
		label:GA N	(un-typed global label)

 <label>:N 0-3, global label
	label:N
		generates	global {label}:data,N{label}:data
	label:N,length
		un-aligned	global N{label}:data
		4-aligned	global {label}:data
	label:N,length,<data>
		un-aligned	global N{label}:data
		4-aligned	global {label}:data (%2)
		%xdefine-s	_N_{label}

 label KV 0-*
	name of a kernel defined "value", noop macro for the docs

 callx symbol		macro 1
	call external subroutine
	declare external symbol, if not already done and __LIB4TH undefined(!)
	%xdefine-s a testable (nasm!) name "_X_%{1}"

 jmpx symbol		macro 1
	jump into external subroutine
	declare external symbol, if not already done and __LIB4TH undefined(!)
	%xdefine-s a testable (nasm!) name "_X_%{1}"

================================================================;
 reloc.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/resource.h.inc>
--------------------------------------------------------------------------

 Resource control/accounting header file for linux
 Definition of struct rusage taken from BSD 4.3 Reno
 We don't support all of these yet, but we might as well have them....
 Otherwise, each time we add new items, programs which depend on this
 structure will lose.  This reduces the chances of that happening.
 Due to binary compatibility, the actual resource numbers
 may be different for different linux versions..
 Resource limits

================================================================;
 resource.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/rwfloat.inc>
--------------------------------------------------------------------------

 true(-1), false(0)

 isascii 0-1
	ret {true} if arg is 7bit uk/us ascii
 i:	%{1}	char	(dft: eax)
 o:	eax	flag
 rwfloat <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/sched.h.inc>
--------------------------------------------------------------------------

 cloning flags:
	CSIGNAL		signal mask to be sent at exit
	CLONE_VM	VM shared between processes
	CLONE_FS	fs info shared between processes
	CLONE_FILES	open files shared between processes
	CLONE_SIGHAND	signal handlers shared
	CLONE_PID	pid shared
	CLONE_PTRACE	we want to let tracing continue on the child too
	CLONE_VFORK	the parent wants the child to wake it up on mm_release

 These are the constant used to fake the fixed-point load-average
 counting. Some notes:
  - 11 bit fractions expand to 22 bits by the multiplies: this gives
    a load-average precision of 10 bits integer + 11 bits fractional
  - if you want to count load-averages more often, you need more
    precision, or rounding will get you. With 2-second counting freq,
    the EXP_n values would be 1981, 2034 and 2043 if still using only
    11 bit fractions.

 #define CALC_LOAD(load,exp,n) \
	load *= exp; \
	load += n*(FIXED_1-exp); \
	load >>= FSHIFT;
 Open file table structure
 pointers to (original) parent process, youngest child, younger sibling,
 older sibling, respectively. (p->father can be replaced with p->p_pptr->pid)

=========================================================================;
 sched.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/siginfo_h.inc>
--------------------------------------------------------------------------



+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/signal_h.inc>
--------------------------------------------------------------------------

 syscalls acces is kernel mode

 Most things should be clean enough to redefine this at will, 
 if care is taken to make libc match.
	_NSIG	_NSIG_BPW	_NSIG_WORDS
 These should not be considered constants from userland:
	SIGRTMIN	SIGRTMAX

 linux signal number defn's

 SA_FLAGS values (re "Single Unix" doc's by Open Group; man 2, "sigaction"):
	SA_ONSTACK
		indicates that a registered stack_t will be used.
	SA_INTERRUPT
		is a no-op, but left due to historical reasons. Use the
	SA_RESTART
		flag to get restarting signals (which were the default long ago)
	SA_NOCLDSTOP
		flag to turn off SIGCHLD when children stop.
	SA_RESETHAND
		clears the handler when the signal is delivered.
	SA_NOCLDWAIT
		flag on SIGCHLD to inhibit zombies.
	SA_NODEFER
		prevents the current signal from being masked in the handler.

 SA_ONESHOT and SA_NOMASK are the historical Linux names for
 the Single Unix names RESETHAND and NODEFER respectively.
 	In contrary to man 2 page documentation, the sys_sigaction call does 
 	NOT default to ANY setting, i.e. SA_ONESHOT isn't "default behaviour", 
	i.e. SA_FLAGS bits is under full control of the programmer!

 These values of sa_flags are used only by the kernel as part of the
 irq handling routines.

 SA_INTERRUPT is also used by the irq handling routines.
 SA_SHIRQ is for shared interrupt support on PCI and EISA.

=========================================================================;
 signal_h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/stat.h.inc>
--------------------------------------------------------------------------

=========================================================================;
 stat.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/sysdep.inc>
--------------------------------------------------------------------------

================================================================;
 kernel

 PAGE_SHIFT, PAGE_SIZE, PAGE_MASK
	check for currently valid data: /usr/include/asm/page.h
 pg(x)	for page size adjustment, takes (x)K bytes

================================================================;
 jobs

 flags to sys_clone, re linux/inlude/linux/sched.h
	CSIGNAL		signal mask to be sent at exit
	CLONE_VM	set if VM shared between processes
	CLONE_FS	set if fs info shared between processes
	CLONE_FILES	set if open files shared between processes
	CLONE_SIGHAND	set if signal handlers shared
	CLONE_PID	set if pid shared, - CLONE_PID not permitted for root (and others?)
	CLONE_PTRACE	set if we want to let tracing continue on the child, too
	CLONE_VFORK	set if the parent wants the child to wake it up on mm_release

 clonflags
	flags to macro CLON4TH: CLONE_VM|CLONE_FS|CLONE_FILES|CLONE_PTRACE
	other possible flags re above, flags to sys_clone..

 (*) mode-7: 'safety fast'
================================================================
 sysdep.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/sysexits.h.inc>
--------------------------------------------------------------------------

=========================================================================;
 sysexits.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/sysmac.mac>
--------------------------------------------------------------------------

	dft align 4, shorthand

 page_align 0
	align to linux memory page size, %define-d

 PAGE_ALIGN 0
	page_align if __STATIC compile-switch not defined

 enum 1-2
	compiles %{1}: equ <p_enum>
	updates p_enum:=p_enum+c_enum
	initial defaults are p_enum := 0 and c_enum := 1
	optionally set c_enum := %{2} and initiate p_enum := 0 

 label:string 1
	db a 4th string %{1} by countbyte and chars,
	no padding, no alignment, <label> optional.

 label:wstring 1
	cpl global <label> & dw-counted string %{1}

 ccf
	complement carry flag (synonym ccf)

 dbplus 2-3
	insert db-s (or size %3) data items counting from %1 till (%2-1)

 dbcons 2-3
	insert %1 times db-s (or size %3) data items of value %2

================================================================;
 sysmac.mac <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/termbits.inc>
--------------------------------------------------------------------------

	tty related ioctl descriptors

 NCCS
	no. of ctrl-s in termios, kernel 2.2.14
	re kernel source for version dep'd value!

 struc termios, termio
	terminal control structures
	from linux/include/asm/termbits.h:
 	from linux/include/asm/termios.h:

 c_cc character posn's - commments from the mips defn
	VINTR	VQUIT	VERASE	VKILL	VEOF	VTIME	VMIN	VSWTC	VSTART	
	VSTOP	VSUSP	VEOL	VREPRINT VDISCARD VWERASE	VLNEXT	VEOL2	
 defaults, from linux/include/asm-i386/termios.h:
	intr=^C		quit=^\		erase=del	kill=^U
	eof=^D		vtime=\0	vmin=\1		sxtc=\0
	start=^Q	stop=^S		susp=^Z		eol=\0
	reprint=^R	discard=^U	werase=^W	lnext=^V
	eol2=\0
 c_iflag bits
	IGNBRK	BRKINT	IGNPAR	PARMRK	INPCK	ISTRIP	
	INLCR	IGNCR	ICRNL	IUCLC	IXON	IXANY	IXOFF	IMAXBEL	
 c_oflag bits, and attributes
	OPOST	OLCUC	ONLCR	OCRNL	ONOCR	ONLRET	
	OFILL	OFDEL	NLDLY	CRDLY	TABDLY	BSDLY	VTDLY	FFDLY	
 c_cflag bit meaning, and attributes
	CBAUD	EXTA	EXTB	CSIZE	CSTOPB	CREAD	PARENB
	PARODD	HUPCL	CLOCAL	CBAUDEX	CIBAUD	CRTSCTS	CMSPAR
 c_lflag bits
	ISIG	ICANON	XCASE	ECHO	ECHOE	ECHOK	ECHONL	NOFLSH	
	TOSTOP	ECHOCTL	ECHOPRT	ECHOKE	FLUSHO	PENDIN	IEXTEN	

 tcflow() and TCXONC modes
	TCOOFF	TCOON	TCIOFF	TCION	
 tcflush() and TCFLSH modes
	TCIFLUSH	TCOFLUSH	TCIOFLUSH	
 tcsetattr modes
	TCSANOW		TCSADRAIN	TCSAFLUSH	

 termbits.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/term.h.inc>
--------------------------------------------------------------------------

================================================================;


+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/time.h.inc>
--------------------------------------------------------------------------

=========================================================================;
 time.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/unistd.h.inc>
--------------------------------------------------------------------------

=========================================================================;
 unistd.h.inc <eof>

+ -- +

 <hda6-x/usr/src/forth/lib4th/inc/vt.inc>
--------------------------------------------------------------------------

 ioctl-s
	0x56 is 'V', to avoid collision with termios and kd
 VT_OPENQRY	VT_GETMODE	VT_SETMODE	VT_AUTO		
 VT_PROCESS	VT_ACKACQ	VT_GETSTATE	VT_SENDSIG	
 VT_RELDISP	VT_ACTIVATE	VT_WAITACTIVE	VT_DISALLOCATE	
 VT_RESIZE	VT_RESIZEX      VT_LOCKSWITCH   VT_UNLOCKSWITCH 

 struct-s:
	vt_mode, vt_stat, vt_sizes, vt_consize
 vt.inc <eof>

+ -- +
<eof> -1-0-6+16 .hpr'2002
