[OpenSPARC-T2-SAM] / obp / obp / fm / kernel / double.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: double.fth
\ 
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ 
\  - Do no alter or remove copyright notices
\ 
\  - Redistribution and use of this software in source and binary forms, with 
\    or without modification, are permitted provided that the following 
\    conditions are met: 
\ 
\  - Redistribution of source code must retain the above copyright notice, 
\    this list of conditions and the following disclaimer.
\ 
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution. 
\ 
\    Neither the name of Sun Microsystems, Inc. or the names of contributors 
\ may be used to endorse or promote products derived from this software 
\ without specific prior written permission. 
\ 
\     This software is provided "AS IS," without a warranty of any kind. 
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ 
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)double.fth 1.9 06/10/13 13:19:27
purpose: 
copyright: Copyright 2006 Sun Microsystems, Inc.  All rights reserved.
copyright: Copyright 1994 FirmWorks
copyright: Use is subject to license terms.

headers
: 2literal   ( d -- )  swap  [compile] literal  [compile] literal  ; immediate
: 2variable  ( -- )  \ name  \  Run-time:  ( -- addr )
   2 /n* ualloc user
; 
\  In-dictionary variables are a leftover from the earliest FORTH
\  implementations.  They have no place in a ROMable target-system
\  and we are deprecating support for them; but Just In Case you
\  ever want to restore support for them, define the command-line
\  symbol:   in-dictionary-variables
[ifdef] in-dictionary-variables
   [ifnexist] 2variable
   : 2variable  ( "name" d -- )  create  0 , 0 ,  ;
   [then]
[then]

headerless
\ Double-word comparison support routines:

\ Conditional-double-"drop-or-nip":  If the supplied flag is true,
\ nip off the pair under the top pair, otherwise drop off the top pair
: ?2off ( d1.lo d2.lo d1.hi d2.hi flag -- d1.hi d2.hi | d1.lo d2.lo )
   if  2swap  then  2drop
;

\ Prepare for a double-word comparison.
\ Leave the relevant elements from the pair, i.e.,
\ if the "Hi"s are equal, leave the "Lo"s
: d(pre-compare) ( d1.lo,hi d2.lo,hi -- d1.hi d2.hi | d1.lo d2.lo )
  rot  swap				( d1.lo d2.lo d1.hi d2.hi )
  2dup <>  ?2off
;

headers

: d0=   ( d1 d2 -- flag )  or  0=  ;
: d=    ( d1 d2 -- flag )  d- d0=  ;
: d<>   ( d1 d2 -- flag )  d=  0=  ;
: d0<   ( d -- flag )   nip 0<  ;
: du<   ( ud1 ud2 -- flag )  d(pre-compare) u<  ;
: d<    ( d1 d2 -- flag )
   rot swap				( d1.lo d2.lo d1.hi d2.hi )
   2dup =  if				( d1.lo d2.lo d1.hi d2.hi )
      \ Both high values are equal.
      \ If negative we need to negate the low cells.
      drop 0<  if			( d1.lo d2.lo )
	 negate swap negate swap	( d1.lo d2.lo )
      then				( d1.lo d2.lo )
      u< exit
   then					( d1.lo d2.lo d1.hi d2.hi )
   < nip nip
;

[ifnexist] dnegate
\ defined in fm/kernel/sparc/double.fth
: dnegate  ( d -- -d )  0 0  2swap  d-  ;
[then]
[ifnexist] dabs
\ defined in fm/kernel/sparc/double.fth
: dabs     ( d -- +d )  2dup  d0<  if  dnegate  then  ;
[then]

[ifnexist] s>d 
\ defined in fm/kernel/sparc/kerncode.fth
: s>d   ( n -- d )  dup 0<  ;
[then]

: u>d   ( u -- d )  0  ;
: d>s   ( d -- n )  drop  ;

: (d.)  (  d -- adr len )  tuck dabs <# #s rot sign #>  ;
: (ud.) ( ud -- adr len )  <# #s #>  ;

: d.    (  d -- )     (d.) type space  ;
: ud.   ( ud -- )    (ud.) type space  ;
: ud.r  ( ud n -- )  >r (ud.) r> over - spaces type  ;

: d2*   ( xd -- xd*2 )  2*  over 0<  negate +  swap  2*  swap  ;
: d2/   ( xd -- xd/2 )
   dup 1 and				( d.lo d.hi d.hi-uf-bit )
   [ /n 8 * 1- ] literal lshift		( d.lo d.hi d.hi-uf )
   rot u2/ or				( d.hi d.lo' ) 
   swap 2/				( d.lo' d.hi' )
;

: dmax  ( xd1 xd2 -- )  2over 2over d<      ?2off  ;
: dmin  ( xd1 xd2 -- )  2over 2over d<  0=  ?2off  ;

: m+    ( d1|ud1 n -- )  s>d  d+  ;
: 2rot  ( d1 d2 d3 -- d2 d3 d1 )  2>r 2swap 2r> 2swap  ;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: double.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	id: @(#)double.fth 1.9 06/10/13 13:19:27
	43	purpose:
	44	copyright: Copyright 2006 Sun Microsystems, Inc. All rights reserved.
	45	copyright: Copyright 1994 FirmWorks
	46	copyright: Use is subject to license terms.
	47
	48	headers
	49	: 2literal ( d -- ) swap [compile] literal [compile] literal ; immediate
	50	: 2variable ( -- ) \ name \ Run-time: ( -- addr )
	51	2 /n* ualloc user
	52	;
	53	\ In-dictionary variables are a leftover from the earliest FORTH
	54	\ implementations. They have no place in a ROMable target-system
	55	\ and we are deprecating support for them; but Just In Case you
	56	\ ever want to restore support for them, define the command-line
	57	\ symbol: in-dictionary-variables
	58	[ifdef] in-dictionary-variables
	59	[ifnexist] 2variable
	60	: 2variable ( "name" d -- ) create 0 , 0 , ;
	61	[then]
	62	[then]
	63
	64	headerless
65	\ Double-word comparison support routines:
66
67	\ Conditional-double-"drop-or-nip": If the supplied flag is true,
68	\ nip off the pair under the top pair, otherwise drop off the top pair
69	: ?2off ( d1.lo d2.lo d1.hi d2.hi flag -- d1.hi d2.hi \| d1.lo d2.lo )
70	if 2swap then 2drop
71	;
72
73	\ Prepare for a double-word comparison.
74	\ Leave the relevant elements from the pair, i.e.,
75	\ if the "Hi"s are equal, leave the "Lo"s
76	: d(pre-compare) ( d1.lo,hi d2.lo,hi -- d1.hi d2.hi \| d1.lo d2.lo )
77	rot swap ( d1.lo d2.lo d1.hi d2.hi )
78	2dup <> ?2off
79	;
80
81	headers
82
83	: d0= ( d1 d2 -- flag ) or 0= ;
84	: d= ( d1 d2 -- flag ) d- d0= ;
85	: d<> ( d1 d2 -- flag ) d= 0= ;
86	: d0< ( d -- flag ) nip 0< ;
87	: du< ( ud1 ud2 -- flag ) d(pre-compare) u< ;
88	: d< ( d1 d2 -- flag )
89	rot swap ( d1.lo d2.lo d1.hi d2.hi )
90	2dup = if ( d1.lo d2.lo d1.hi d2.hi )
91	\ Both high values are equal.
92	\ If negative we need to negate the low cells.
93	drop 0< if ( d1.lo d2.lo )
94	negate swap negate swap ( d1.lo d2.lo )
95	then ( d1.lo d2.lo )
96	u< exit
97	then ( d1.lo d2.lo d1.hi d2.hi )
98	< nip nip
99	;
100
101	[ifnexist] dnegate
102	\ defined in fm/kernel/sparc/double.fth
103	: dnegate ( d -- -d ) 0 0 2swap d- ;
104	[then]
105	[ifnexist] dabs
106	\ defined in fm/kernel/sparc/double.fth
107	: dabs ( d -- +d ) 2dup d0< if dnegate then ;
108	[then]
109
110	[ifnexist] s>d
111	\ defined in fm/kernel/sparc/kerncode.fth
112	: s>d ( n -- d ) dup 0< ;
113	[then]
114
115	: u>d ( u -- d ) 0 ;
116	: d>s ( d -- n ) drop ;
117
118	: (d.) ( d -- adr len ) tuck dabs <# #s rot sign #> ;
119	: (ud.) ( ud -- adr len ) <# #s #> ;
120
121	: d. ( d -- ) (d.) type space ;
122	: ud. ( ud -- ) (ud.) type space ;
123	: ud.r ( ud n -- ) >r (ud.) r> over - spaces type ;
124
125	: d2* ( xd -- xd2 ) 2 over 0< negate + swap 2* swap ;
126	: d2/ ( xd -- xd/2 )
127	dup 1 and ( d.lo d.hi d.hi-uf-bit )
128	[ /n 8 * 1- ] literal lshift ( d.lo d.hi d.hi-uf )
129	rot u2/ or ( d.hi d.lo' )
130	swap 2/ ( d.lo' d.hi' )
131	;
132
133	: dmax ( xd1 xd2 -- ) 2over 2over d< ?2off ;
134	: dmin ( xd1 xd2 -- ) 2over 2over d< 0= ?2off ;
135
136	: m+ ( d1\|ud1 n -- ) s>d d+ ;
137	: 2rot ( d1 d2 d3 -- d2 d3 d1 ) 2>r 2swap 2r> 2swap ;