home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
rtsi.com
/
2014.01.www.rtsi.com.tar
/
www.rtsi.com
/
OS9
/
OSK
/
EFFO
/
pd6.lzh
/
LIB
/
TILE
/
queues.f83
< prev
next >
Wrap
Text File
|
1989-12-21
|
5KB
|
125 lines
\
\ DOUBLE LINKED LISTS
\
\ Copyright (c) 1989 by Mikael R.K. Patel
\
\ Computer Aided Design Laboratory (CADLAB)
\ Department of Computer and Information Science
\ Linkoping University
\ S-581 83 LINKOPING
\ SWEDEN
\
\ Email: mip@ida.liu.se
\
\ Started on: 30 June 1988
\
\ Last updated on: 29 November 1989
\
\ Dependencies:
\ (forth) structures, blocks
\
\ Description:
\ Allows definition and basic manipulation of queue data structures.
\
\ Copying:
\ This program is free software; you can redistribute it and\or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 1, or (at your option)
\ any later version.
\
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with this program; see the file COPYING. If not, write to
\ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
.( Loading Queue definitions... ) cr
#include structures.f83
#include blocks.f83
blocks structures queues definitions
struct.type QUEUE ( -- )
ptr +succ private ( Pointer to successor)
ptr +pred private ( Pointer to predessor)
struct.init ( queue -- )
dup over +succ ! ( Initiate as an empty queue)
dup +pred !
struct.end
: succ ( queue -- succ)
+succ @ ; ( Access successor item)
: pred ( queue -- pred)
+pred @ ; ( Access predecessor item)
#ifundef ?empty ( Check if the kernel supports queues)
: ?empty ( queue -- boolean)
dup +succ @ = ; ( Pointer to itself)
: into ( item queue -- )
over over +pred @ swap +pred ! ( item.pred = queue.pred)
over over swap +succ ! ( item.succ = queue)
over over +pred @ +succ ! ( queue.pred.succ = item)
+pred ! ; ( queue.pred = item)
: out ( item -- )
dup +succ @ over +pred ! ( item.pred = item.succ)
dup +pred @ swap +succ ! ; ( item.succ = item.pred)
#then
: empty ( queue -- )
dup over +succ ! ( Initiate as an empty queue)
dup +pred ! ;
: map ( queue block[item -- ] -- )
over >r ( Save pointer to queue header)
begin
over +succ @ >r ( Save pointer to next item)
dup >r ( Save block on return stack)
call ( Call the block with the item)
r> r> swap over ( Restore the parameters)
r@ = ( Check if end of queue)
until
r> drop drop drop ; ( Drop all temporary parameters)
: ?map ( queue block[item -- flag] -- )
over >r ( Save pointer to queue header)
begin
over +succ @ >r ( Save pointer to next item)
dup >r ( Save block on return stack)
call ( Call the block with the item)
if r> drop r> drop r> drop ( Drop all saved parameters )
exit ( and exit the mapping function)
then
r> r> swap over ( Restore the parameters)
r@ = ( Check if end of queue)
until
r> drop drop drop ; ( Drop all temporary parameters)
: print ( queue -- )
block[ . ]; map ; ( Print address of each queue item)
: length ( queue -- length )
0 swap block[ drop 1+ ]; map ; ( Map increment for each queue item)
: ?member ( item queue -- flag)
block[ ( item0 item -- [item0 false] or [false true])
over = ( Check if this item is the searched)
if drop false true ( Drop the item and return false)
else false then ( Try the next item)
]; ?map boolean not ; ( Map the block over the items)
: .queue ( queue -- )
." queue#" dup . ( Print address of queue)
." succ: " dup +succ @ . ( Print successor)
." pred: " +pred @ . ; ( Print predessor)
forth only