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 >
Text File  |  1989-12-21  |  5KB  |  125 lines
  1. \
  2. \  DOUBLE LINKED LISTS
  3. \
  4. \  Copyright (c) 1989 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 29 November 1989
  17. \
  18. \  Dependencies:
  19. \       (forth) structures, blocks
  20. \
  21. \  Description:
  22. \       Allows definition and basic manipulation of queue data structures.
  23. \
  24. \  Copying:
  25. \       This program is free software; you can redistribute it and\or modify
  26. \       it under the terms of the GNU General Public License as published by
  27. \       the Free Software Foundation; either version 1, or (at your option)
  28. \       any later version.
  29. \
  30. \       This program is distributed in the hope that it will be useful,
  31. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. \       GNU General Public License for more details.
  34. \
  35. \       You should have received a copy of the GNU General Public License
  36. \       along with this program; see the file COPYING.  If not, write to
  37. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  38.  
  39. .( Loading Queue definitions... ) cr
  40.  
  41. #include structures.f83
  42. #include blocks.f83
  43.  
  44. blocks structures queues definitions
  45.  
  46. struct.type QUEUE ( -- )
  47.   ptr +succ private                    ( Pointer to successor)
  48.   ptr +pred private                    ( Pointer to predessor)
  49. struct.init ( queue -- )
  50.   dup over +succ !                     ( Initiate as an empty queue)
  51.   dup +pred !
  52. struct.end 
  53.  
  54. : succ ( queue -- succ)
  55.   +succ @ ;                            ( Access successor item)
  56.  
  57. : pred ( queue -- pred)
  58.   +pred @ ;                            ( Access predecessor item)
  59.  
  60. #ifundef ?empty        ( Check if the kernel supports queues)
  61.  
  62. : ?empty ( queue -- boolean)
  63.   dup +succ @ = ;                      ( Pointer to itself)
  64.  
  65. : into ( item queue -- )
  66.   over over +pred @ swap +pred !       ( item.pred = queue.pred)
  67.   over over swap +succ !               ( item.succ = queue)
  68.   over over +pred @ +succ !            ( queue.pred.succ = item)
  69.   +pred ! ;                            ( queue.pred = item)
  70.  
  71. : out ( item -- )
  72.   dup +succ @ over +pred !             ( item.pred = item.succ)
  73.   dup +pred @ swap +succ ! ;           ( item.succ = item.pred)
  74.  
  75. #then
  76.  
  77. : empty ( queue -- )
  78.   dup over +succ !                     ( Initiate as an empty queue)
  79.   dup +pred ! ;
  80.  
  81. : map ( queue block[item -- ] -- )
  82.   over >r                              ( Save pointer to queue header)
  83.   begin
  84.     over +succ @ >r                    ( Save pointer to next item)
  85.     dup >r                             ( Save block on return stack)
  86.     call                               ( Call the block with the item)
  87.     r> r> swap over                    ( Restore the parameters)
  88.     r@ =                               ( Check if end of queue)
  89.   until
  90.   r> drop drop drop ;                  ( Drop all temporary parameters)
  91.  
  92. : ?map ( queue block[item -- flag] -- )
  93.   over >r                              ( Save pointer to queue header)
  94.   begin
  95.     over +succ @ >r                    ( Save pointer to next item)
  96.     dup >r                             ( Save block on return stack)
  97.     call                               ( Call the block with the item)
  98.     if r> drop r> drop r> drop         ( Drop all saved parameters )
  99.       exit                             ( and exit the mapping function)
  100.     then
  101.     r> r> swap over                    ( Restore the parameters)
  102.     r@ =                               ( Check if end of queue)
  103.   until
  104.   r> drop drop drop ;                  ( Drop all temporary parameters)
  105.  
  106. : print ( queue -- )
  107.   block[ . ];  map ;                   ( Print address of each queue item)
  108.  
  109. : length ( queue -- length )
  110.   0 swap block[ drop 1+ ]; map ;       ( Map increment for each queue item)
  111.  
  112. : ?member ( item queue -- flag)
  113.   block[ ( item0 item -- [item0 false] or [false true])
  114.     over =                             ( Check if this item is the searched)
  115.     if drop false true                 ( Drop the item and return false)
  116.     else false then                    ( Try the next item)
  117.   ]; ?map boolean not ;                        ( Map the block over the items)
  118.  
  119. : .queue ( queue -- )
  120.   ." queue#" dup .                     ( Print address of queue)
  121.   ." succ: " dup +succ @ .             ( Print successor)
  122.   ." pred: " +pred @ . ;               ( Print predessor)
  123.  
  124. forth only
  125.