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

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: kernel2.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: @(#)kernel2.fth 2.11 03/12/08 13:22:09
purpose: 
copyright: Copyright 1990-2003 Sun Microsystems, Inc.  All Rights Reserved
copyright: Copyright 1985-1990 Bradley Forthware
copyright: Use is subject to license terms.

\ Kernel colon definitions
decimal
 0 constant 0     1 constant 1      2 constant 2      3 constant 3
 4 constant 4     5 constant 5      6 constant 6      7 constant 7
 8 constant 8
-1 constant true  0 constant false
32 constant bl
\ 64 constant c/l

[ifnexist] bounds
   : bounds  ( adr len -- adr+len adr )  over + swap  ;
[then]

: roll    ( nk nk-1 ... n1 n0 k -- nk-1 ... n1 n0 nk )
   >r  r@ pick   sp@ dup  na1+
   r> 1+ /n*
   cmove> drop
;


[ifnexist] ?dup
   : ?dup    ( n -- [n] n )        dup if   dup   then   ;
[then]
[ifnexist] between
   : between ( n min max -- f )    >r over <= swap r> <= and  ;
[then]
[ifnexist] within
   : within  ( n min max+1 -- f )  over -  >r - r> u<  ;
[then]

: erase      ( adr len -- )   0 fill   ;
: blank      ( adr len -- )   bl fill   ;
: pad        ( -- adr )       here 300 +   ;
: depth      ( -- n )         sp@ sp0 @ swap - /n /   ;
: clear      ( ?? -- Empty )  sp0 @ sp!  ;

: hex        ( -- )   16 base !  ;
: decimal    ( -- )   10 base !  ;
: octal      ( -- )    8 base !  ;
: binary     ( -- )    2 base !  ;

: ?enough   ( n -- )  depth 1- >   ( -4 ) abort" Not enough Parameters"  ;

hex
ps-size-t constant ps-size
rs-size-t constant rs-size

: cdump  ( adr len -- )
   base @ >r  hex
   bounds  ?do
      i 8 u.r  ." : "  i  h# 10  bounds  do
         i /l bounds  do  i c@ <# u# u# u#> type space  loop  space
      /l +loop
      i  h# 10  bounds  do
         i c@  dup  bl h# 80 within  if  emit  else  drop ." ."  then
      loop
      cr
   h# 10 +loop
   r> base !
;
: ldump  ( adr len -- )
   base @ >r  hex
   bounds  ?do
      i 8 u.r  ." : "  i  h# 10  bounds  do
         i l@ 8 u.r space space
      /l +loop
      i  h# 10  bounds  do
         i c@  dup  bl h# 80 within  if  emit  else  drop ." ."  then
      loop
      cr
   h# 10 +loop
   r> base !
;
headerless
: (compile-time-error)  ( -- ) d# 58 d# 45 fsyscall ;
: (compile-time-warning) ( -- ) d# 59 d# 45 fsyscall ;
headers

: abort  ( ?? -- )  mark-error  -1 throw  ;

\ Run-time words used by the compiler; also used by metacompiled programs
\ even if the interactive compiler is not present

nuser abort"-adr
nuser abort"-len
: set-abort-message  ( adr len -- )  abort"-len !  abort"-adr !  ;
: abort-message  ( -- adr len )  abort"-adr @  abort"-len @  ;
: (.")  ( -- )           skipstr type  ;
: (abort")   ( f -- )
   if
      (compile-time-error) mark-error  ip@ count  set-abort-message  -2 throw
   else
      skipstr 2drop
   then
;
: ?throw  ( flag throw-code -- )  swap  if  throw  else  drop  then  ;
: ("s)  ( -- str-addr )  skipstr  ( addr len )  drop 1-  ;

nuser 'lastacf         \ acf of latest definition
: lastacf  ( -- acf )  'lastacf token@  ;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: kernel2.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: @(#)kernel2.fth 2.11 03/12/08 13:22:09
	43	purpose:
	44	copyright: Copyright 1990-2003 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Copyright 1985-1990 Bradley Forthware
	46	copyright: Use is subject to license terms.
	47
	48	\ Kernel colon definitions
	49	decimal
	50	0 constant 0 1 constant 1 2 constant 2 3 constant 3
	51	4 constant 4 5 constant 5 6 constant 6 7 constant 7
	52	8 constant 8
	53	-1 constant true 0 constant false
	54	32 constant bl
	55	\ 64 constant c/l
	56
	57	[ifnexist] bounds
	58	: bounds ( adr len -- adr+len adr ) over + swap ;
	59	[then]
	60
	61	: roll ( nk nk-1 ... n1 n0 k -- nk-1 ... n1 n0 nk )
	62	>r r@ pick sp@ dup na1+
	63	r> 1+ /n*
	64	cmove> drop
65	;
66
67
68
69	[ifnexist] ?dup
70	: ?dup ( n -- [n] n ) dup if dup then ;
71	[then]
72	[ifnexist] between
73	: between ( n min max -- f ) >r over <= swap r> <= and ;
74	[then]
75	[ifnexist] within
76	: within ( n min max+1 -- f ) over - >r - r> u< ;
77	[then]
78
79	: erase ( adr len -- ) 0 fill ;
80	: blank ( adr len -- ) bl fill ;
81	: pad ( -- adr ) here 300 + ;
82	: depth ( -- n ) sp@ sp0 @ swap - /n / ;
83	: clear ( ?? -- Empty ) sp0 @ sp! ;
84
85	: hex ( -- ) 16 base ! ;
86	: decimal ( -- ) 10 base ! ;
87	: octal ( -- ) 8 base ! ;
88	: binary ( -- ) 2 base ! ;
89
90	: ?enough ( n -- ) depth 1- > ( -4 ) abort" Not enough Parameters" ;
91
92	hex
93	ps-size-t constant ps-size
94	rs-size-t constant rs-size
95
96	: cdump ( adr len -- )
97	base @ >r hex
98	bounds ?do
99	i 8 u.r ." : " i h# 10 bounds do
100	i /l bounds do i c@ <# u# u# u#> type space loop space
101	/l +loop
102	i h# 10 bounds do
103	i c@ dup bl h# 80 within if emit else drop ." ." then
104	loop
105	cr
106	h# 10 +loop
107	r> base !
108	;
109	: ldump ( adr len -- )
110	base @ >r hex
111	bounds ?do
112	i 8 u.r ." : " i h# 10 bounds do
113	i l@ 8 u.r space space
114	/l +loop
115	i h# 10 bounds do
116	i c@ dup bl h# 80 within if emit else drop ." ." then
117	loop
118	cr
119	h# 10 +loop
120	r> base !
121	;
122	headerless
123	: (compile-time-error) ( -- ) d# 58 d# 45 fsyscall ;
124	: (compile-time-warning) ( -- ) d# 59 d# 45 fsyscall ;
125	headers
126
127	: abort ( ?? -- ) mark-error -1 throw ;
128
129	\ Run-time words used by the compiler; also used by metacompiled programs
130	\ even if the interactive compiler is not present
131
132	nuser abort"-adr
133	nuser abort"-len
134	: set-abort-message ( adr len -- ) abort"-len ! abort"-adr ! ;
135	: abort-message ( -- adr len ) abort"-adr @ abort"-len @ ;
136	: (.") ( -- ) skipstr type ;
137	: (abort") ( f -- )
138	if
139	(compile-time-error) mark-error ip@ count set-abort-message -2 throw
140	else
141	skipstr 2drop
142	then
143	;
144	: ?throw ( flag throw-code -- ) swap if throw else drop then ;
145	: ("s) ( -- str-addr ) skipstr ( addr len ) drop 1- ;
146
147	nuser 'lastacf \ acf of latest definition
148	: lastacf ( -- acf ) 'lastacf token@ ;
149