[OpenSPARC-T2-SAM] / obp / obp / fm / lib / linklist.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: linklist.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 ============================================
\ linklist.fth 2.5 02/05/02
\ Copyright 1985-1990 Bradley Forthware
\ Copyright 1990-2002 Sun Microsystems, Inc.  All Rights Reserved
\ Copyright Use is subject to license terms.

\ Linked list words.  Assumes a singly-linked list, where the
\ first element in each list node is the link.  Links point to links,
\ and the last link contains 0.
\
\ list:  \ name  ( -- )   Child: ( -- list )
\	Defines a named list.
\
\ listnode   ( -- offset )
\	Used like "struct" to begin the creation of a list node structure
\	The link field is automatically included in the structure.
\
\ nodetype:  \ name  ( size -- )   Child: ( -- nodetype )
\	Defines a new named node type.  Example:
\
\		listnode
\			/n field >node-data
\		nodetype: integer-node
\
\ node-length  ( nodetype -- len )
\	Returns the length of a node of the indicated type.
\
\ allocate-node  ( nodetype -- node )
\	Allocates a node of the indicated type.
\
\ more-nodes  ( #nodes nodetype -- )
\	Adds "#nodes" more nodes to the free list for the indicated node type.
\	Automatically executed by "allocate-node" if necessary.
\
\ free-node  ( node nodetype -- )
\	Returns the indicated node to the free list for the indicated node
\	type.
\
\ insert-after  ( new-node-adr prev-node-adr -- )
\	Inserts "new-node" into a linked list after "prev-node" (and before
\	the node which was the successor of "prev-node").
\
\ delete-after  ( prev-node -- deleted-node )
\	Removes the node AFTER the argument node.  The deleted node is
\	returned so its memory can be freed or whatever.
\
\ find-node  ( ??? list acf -- ??? prev-node this-node|0 )
\	Searches the linked list "list", executing the procedure "acf"
\	for each node in the list.  Returns the node for which "acf"
\	returned "true", and also the preceding node.  See the comments
\	in the code for more information.

alias list: variable

alias listnode /n

: nodetype:  \ name  ( size -- )
   aligned  create 2 /n* user#,  0 over ! na1+ !     \ Free list, size
   does> >user
;
: node-length  ( nodetype -- len )  na1+ @  ;

alias >next-node @     ( node-adr -- next-node-adr )

\ Inserts "new-node" into a linked list after "prev-node" (and before
\ the node which was the successor of "prev-node").

: insert-after  ( new-node-adr prev-node-adr -- )
   2dup >next-node    ( new-node prev-node  new-node succ-node )
   swap !             ( new-node prev-node  )
   !                  ( )
;

\ Delete-after removes the node AFTER the argument node
\ The deleted node is returned so its memory can be freed or whatever.

: delete-after  ( prev-node -- deleted-node )  dup @ tuck @ swap !  ;


\ find-node  traverses the list, executing "acf" between each pair of nodes.
\ When "acf" returns true, find-node returns the addresses of the pair of
\ nodes.  If the list is exhausted before "acf" returns true, the last node
\ and 0 is returned.

\ "acf" is called as:
\     ( ??? node-data-adr -- ??? flag )
\
\ ??? is whatever was on the stack underneath "list" and "acf" when "find-node"
\ was called.  It would typically be a test value used by the "acf" function.
\ "acf" is only called with valid node addresses, assuming that the list is
\ well-formed.  In other words, "acf" will not be called with either the
\ list head node or with the null node past the end of the list.

\ The data and return stack manipulations in find-node are pretty grim.
\ Reasons:
\ (a) We want the stack diagram for the action routine to be clean in order
\     to make find-node easy to use.  Thus we do not wish to expose the
\     loop information on the data stack when the action routine is called.
\ (b) The arguments to the action routine are arbitrary in number, thus
\     we cannot store loop information underneath them.
\ (c) This routine needs to be reentrant, since it is used by the alarm
\     interrupt handler.  Thus we cannot use variables.

: find-node  ( ??? list acf -- ??? prev-node this-node|0 )
   \ Guard against null lists
   over 0=  if  drop 0 exit  then
   \ get next node before the execute
   >r >r r@ >next-node >r 0 >r   ( )                  ( r: acf list this 0 )
   begin                         ( )                  ( r: acf prev this ?? )
      r> drop  r>                ( this )             ( r: acf prev )
      dup 0= if                  ( this )             ( r: acf prev )
         r> r> drop swap exit    ( prev 0 )           ( r: )
      then                       ( this )             ( r: acf prev )
      dup 2r@ rot r> drop >r     ( this acf prev)     ( r: acf this )   
      \ get next node before you execute
      r@ >next-node >r >r        ( this acf )         ( r: acf this next prev )
      execute                    ( flag )             ( r: acf this next prev )
   until                         ( )                  ( r: acf this next prev )
   r> r> r> r>                   ( prev next this acf )  ( r: )
   drop nip                      ( prev this )           ( r: )
;


\ Here's how "find-node" could be used to locate the insertion point
\ for a list sorted in ascending order of the second field.

\ : larger?  ( key node-data-adr -- key flag )  na1+ @ over u>  ;
\ : insertion-point  ( key list -- node )   ['] larger?  find-node  drop  ;


\ Locates the last node in the list.  The routine used with "find-node"
\ is "0=", which always returns "false" because find-node is guaranteed
\ not to call its test routine with a 0 node.

: last-node  ( list -- node-adr )  ['] 0=  find-node  drop  ;

\ Add new nodes to the free list of "nodetype", from the block of memory
\ "adr len", whose length must be a multiple of that nodetype's node length.
: add-nodes  ( adr len nodetype -- )
   dup node-length                     ( adr len nodetype /node )

   \ Find the end of the free list
   swap last-node                      ( adr len /node last-node )

   \ Link new nodes onto free list
   2swap bounds  ?do                   ( /node prev-node )
      i swap !  i                      ( /node prev-node' )
   over +loop                          ( /node prev-node' )
   0 swap !   drop                     ( )
;

\ Adds "#nodes" more nodes to the free list for the indicated node type.
\ Automatically executed by "allocate-node" if necessary.

: more-nodes  ( #nodes nodetype -- )
   tuck node-length *                  ( nodetype total-size )
   dup alloc-mem                       ( nodetype total-size adr )
   swap rot  add-nodes
;

\ Allocates a node of the indicated type by removing a node from the
\ free list.  If the free list start out empty, allocate-node first
\ calls more-nodes to populate the free list.

: allocate-node  ( nodetype -- node )
   dup @  0=  if                       ( nodetype )
      d# 10 over more-nodes            ( nodetype )
   then

   dup >next-node dup >next-node       ( nodetype first-node second-node )
   rot !                               ( first-node )
;

\ Adds the node to the free list for the indicated node type.

: free-node  ( node nodetype -- )  insert-after  ;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: linklist.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	\ linklist.fth 2.5 02/05/02
	43	\ Copyright 1985-1990 Bradley Forthware
	44	\ Copyright 1990-2002 Sun Microsystems, Inc. All Rights Reserved
	45	\ Copyright Use is subject to license terms.
	46
	47	\ Linked list words. Assumes a singly-linked list, where the
	48	\ first element in each list node is the link. Links point to links,
	49	\ and the last link contains 0.
	50	\
	51	\ list: \ name ( -- ) Child: ( -- list )
	52	\ Defines a named list.
	53	\
	54	\ listnode ( -- offset )
	55	\ Used like "struct" to begin the creation of a list node structure
	56	\ The link field is automatically included in the structure.
	57	\
	58	\ nodetype: \ name ( size -- ) Child: ( -- nodetype )
	59	\ Defines a new named node type. Example:
	60	\
	61	\ listnode
	62	\ /n field >node-data
	63	\ nodetype: integer-node
	64	\
65	\ node-length ( nodetype -- len )
66	\ Returns the length of a node of the indicated type.
67	\
68	\ allocate-node ( nodetype -- node )
69	\ Allocates a node of the indicated type.
70	\
71	\ more-nodes ( #nodes nodetype -- )
72	\ Adds "#nodes" more nodes to the free list for the indicated node type.
73	\ Automatically executed by "allocate-node" if necessary.
74	\
75	\ free-node ( node nodetype -- )
76	\ Returns the indicated node to the free list for the indicated node
77	\ type.
78	\
79	\ insert-after ( new-node-adr prev-node-adr -- )
80	\ Inserts "new-node" into a linked list after "prev-node" (and before
81	\ the node which was the successor of "prev-node").
82	\
83	\ delete-after ( prev-node -- deleted-node )
84	\ Removes the node AFTER the argument node. The deleted node is
85	\ returned so its memory can be freed or whatever.
86	\
87	\ find-node ( ??? list acf -- ??? prev-node this-node\|0 )
88	\ Searches the linked list "list", executing the procedure "acf"
89	\ for each node in the list. Returns the node for which "acf"
90	\ returned "true", and also the preceding node. See the comments
91	\ in the code for more information.
92
93	alias list: variable
94
95	alias listnode /n
96
97	: nodetype: \ name ( size -- )
98	aligned create 2 /n* user#, 0 over ! na1+ ! \ Free list, size
99	does> >user
100	;
101	: node-length ( nodetype -- len ) na1+ @ ;
102
103	alias >next-node @ ( node-adr -- next-node-adr )
104
105	\ Inserts "new-node" into a linked list after "prev-node" (and before
106	\ the node which was the successor of "prev-node").
107
108	: insert-after ( new-node-adr prev-node-adr -- )
109	2dup >next-node ( new-node prev-node new-node succ-node )
110	swap ! ( new-node prev-node )
111	! ( )
112	;
113
114	\ Delete-after removes the node AFTER the argument node
115	\ The deleted node is returned so its memory can be freed or whatever.
116
117	: delete-after ( prev-node -- deleted-node ) dup @ tuck @ swap ! ;
118
119
120	\ find-node traverses the list, executing "acf" between each pair of nodes.
121	\ When "acf" returns true, find-node returns the addresses of the pair of
122	\ nodes. If the list is exhausted before "acf" returns true, the last node
123	\ and 0 is returned.
124
125	\ "acf" is called as:
126	\ ( ??? node-data-adr -- ??? flag )
127	\
128	\ ??? is whatever was on the stack underneath "list" and "acf" when "find-node"
129	\ was called. It would typically be a test value used by the "acf" function.
130	\ "acf" is only called with valid node addresses, assuming that the list is
131	\ well-formed. In other words, "acf" will not be called with either the
132	\ list head node or with the null node past the end of the list.
133
134	\ The data and return stack manipulations in find-node are pretty grim.
135	\ Reasons:
136	\ (a) We want the stack diagram for the action routine to be clean in order
137	\ to make find-node easy to use. Thus we do not wish to expose the
138	\ loop information on the data stack when the action routine is called.
139	\ (b) The arguments to the action routine are arbitrary in number, thus
140	\ we cannot store loop information underneath them.
141	\ (c) This routine needs to be reentrant, since it is used by the alarm
142	\ interrupt handler. Thus we cannot use variables.
143
144	: find-node ( ??? list acf -- ??? prev-node this-node\|0 )
145	\ Guard against null lists
146	over 0= if drop 0 exit then
147	\ get next node before the execute
148	>r >r r@ >next-node >r 0 >r ( ) ( r: acf list this 0 )
149	begin ( ) ( r: acf prev this ?? )
150	r> drop r> ( this ) ( r: acf prev )
151	dup 0= if ( this ) ( r: acf prev )
152	r> r> drop swap exit ( prev 0 ) ( r: )
153	then ( this ) ( r: acf prev )
154	dup 2r@ rot r> drop >r ( this acf prev) ( r: acf this )
155	\ get next node before you execute
156	r@ >next-node >r >r ( this acf ) ( r: acf this next prev )
157	execute ( flag ) ( r: acf this next prev )
158	until ( ) ( r: acf this next prev )
159	r> r> r> r> ( prev next this acf ) ( r: )
160	drop nip ( prev this ) ( r: )
161	;
162
163
164	\ Here's how "find-node" could be used to locate the insertion point
165	\ for a list sorted in ascending order of the second field.
166
167	\ : larger? ( key node-data-adr -- key flag ) na1+ @ over u> ;
168	\ : insertion-point ( key list -- node ) ['] larger? find-node drop ;
169
170
171	\ Locates the last node in the list. The routine used with "find-node"
172	\ is "0=", which always returns "false" because find-node is guaranteed
173	\ not to call its test routine with a 0 node.
174
175	: last-node ( list -- node-adr ) ['] 0= find-node drop ;
176
177	\ Add new nodes to the free list of "nodetype", from the block of memory
178	\ "adr len", whose length must be a multiple of that nodetype's node length.
179	: add-nodes ( adr len nodetype -- )
180	dup node-length ( adr len nodetype /node )
181
182	\ Find the end of the free list
183	swap last-node ( adr len /node last-node )
184
185	\ Link new nodes onto free list
186	2swap bounds ?do ( /node prev-node )
187	i swap ! i ( /node prev-node' )
188	over +loop ( /node prev-node' )
189	0 swap ! drop ( )
190	;
191
192	\ Adds "#nodes" more nodes to the free list for the indicated node type.
193	\ Automatically executed by "allocate-node" if necessary.
194
195	: more-nodes ( #nodes nodetype -- )
196	tuck node-length * ( nodetype total-size )
197	dup alloc-mem ( nodetype total-size adr )
198	swap rot add-nodes
199	;
200
201	\ Allocates a node of the indicated type by removing a node from the
202	\ free list. If the free list start out empty, allocate-node first
203	\ calls more-nodes to populate the free list.
204
205	: allocate-node ( nodetype -- node )
206	dup @ 0= if ( nodetype )
207	d# 10 over more-nodes ( nodetype )
208	then
209
210	dup >next-node dup >next-node ( nodetype first-node second-node )
211	rot ! ( first-node )
212	;
213
214	\ Adds the node to the free list for the indicated node type.
215
216	: free-node ( node nodetype -- ) insert-after ;