← Back to branch summary

~ubuntu-branches/ubuntu/trusty/librep/trusty

« back to all changes in this revision

Viewing changes to lisp/rep/data/queues.jl

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2005-01-14 14:18:11 UTC
  • mfrom: (2.1.2 hoary)
  • Revision ID: james.westby@ubuntu.com-20050114141811-k2x3wczuc17qai2v
Tags: 0.17-7
Build with -Oo for amd64

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/rep/data/queues.jl
1
1
#| queues.jl -- fifo queues
2
2
 
3
 
   $Id: queues.jl,v 1.5 2001/08/08 06:00:19 jsh Exp $
 
3
   $Id: queues.jl,v 1.6 2002/04/14 07:22:40 jsh Exp $
4
4
 
5
5
   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
6
6
 
44
44
                                  (declare (unused q))
45
45
                                  (write stream "#<queue>")))
46
46
 
 
47
  ;; Each queue is (TAIL . HEAD). HEAD is the list of items, TAIL
 
48
  ;; points to the last cell in HEAD, or the empty list.
 
49
 
47
50
  (define (make-queue)
48
 
    (make-datum '() type-id))
 
51
    (make-datum (cons) type-id))
49
52
 
50
53
  (define (enqueue q x)
51
 
    (datum-set q type-id (nconc (datum-ref q type-id) (list x))))
 
54
    (let ((cell (datum-ref q type-id))
 
55
          (new (list x)))
 
56
      (if (null (cdr cell))
 
57
          ;; empty queue
 
58
          (progn
 
59
            (rplacd cell new)
 
60
            (rplaca cell new))
 
61
        ;; tail pointer is set
 
62
        (rplacd (car cell) new)
 
63
        (rplaca cell new))))
52
64
 
53
65
  (define (dequeue q)
54
 
    (let ((data (datum-ref q type-id)))
55
 
      (if (null data)
 
66
    (let ((cell (datum-ref q type-id)))
 
67
      (if (null (cdr cell))
56
68
          (error "Can't dequeue from empty queue")
57
 
        (datum-set q type-id (cdr data))
58
 
        (car data))))
 
69
        (prog1 (car (cdr cell))
 
70
          (if (not (eq (car cell) (cdr cell)))
 
71
              ;; at least one element left
 
72
              (rplacd cell (cdr (cdr cell)))
 
73
            ;; queue needs to be empty now
 
74
            (rplacd cell '())
 
75
            (rplaca cell '()))))))
59
76
 
60
77
  (define (queue-empty-p q)
61
 
    (null (datum-ref q type-id)))
 
78
    (null (cdr (datum-ref q type-id))))
62
79
 
63
80
  (define (queuep q)
64
81
    (has-type-p q type-id))
65
82
 
66
83
  (define (queue->list q)
67
 
    (datum-ref q type-id))
 
84
    (cdr (datum-ref q type-id)))
68
85
 
69
86
  (define (queue-length q)
70
87
    (length (queue->list q)))
71
88
 
72
89
  (define (delete-from-queue q x)
73
 
    (datum-set q type-id (delq x (datum-ref q type-id))))
 
90
    (let ((cell (datum-ref q type-id)))
 
91
      (let loop ((ptr cell))
 
92
        (if (null (cdr ptr))
 
93
            ;; avoid pointing tail to itself..
 
94
            (if (null (cdr cell))
 
95
                (rplaca cell '())
 
96
              (rplaca cell ptr))
 
97
          (if (eq (cadr ptr) x)
 
98
              (progn
 
99
                (rplacd ptr (cddr ptr))
 
100
                (loop ptr))
 
101
            (loop (cdr ptr)))))))
74
102
 
75
103
;;; tests
76
104