OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [s-auxdec.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                       S Y S T E M . A U X _ D E C                        --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/Or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
pragma Style_Checks (All_Checks);
33
--  Turn off alpha ordering check on subprograms, this unit is laid
34
--  out to correspond to the declarations in the DEC 83 System unit.
35
 
36
with System.Soft_Links;
37
 
38
package body System.Aux_DEC is
39
 
40
   package SSL renames System.Soft_Links;
41
 
42
   -----------------------------------
43
   -- Operations on Largest_Integer --
44
   -----------------------------------
45
 
46
   --  It would be nice to replace these with intrinsics, but that does
47
   --  not work yet (the back end would be ok, but GNAT itself objects)
48
 
49
   type LIU is mod 2 ** Largest_Integer'Size;
50
   --  Unsigned type of same length as Largest_Integer
51
 
52
   function To_LI   is new Ada.Unchecked_Conversion (LIU, Largest_Integer);
53
   function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU);
54
 
55
   function "not" (Left : Largest_Integer) return Largest_Integer is
56
   begin
57
      return To_LI (not From_LI (Left));
58
   end "not";
59
 
60
   function "and" (Left, Right : Largest_Integer) return Largest_Integer is
61
   begin
62
      return To_LI (From_LI (Left) and From_LI (Right));
63
   end "and";
64
 
65
   function "or"  (Left, Right : Largest_Integer) return Largest_Integer is
66
   begin
67
      return To_LI (From_LI (Left) or From_LI (Right));
68
   end "or";
69
 
70
   function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
71
   begin
72
      return To_LI (From_LI (Left) xor From_LI (Right));
73
   end "xor";
74
 
75
   --------------------------------------
76
   -- Arithmetic Operations on Address --
77
   --------------------------------------
78
 
79
   --  It would be nice to replace these with intrinsics, but that does
80
   --  not work yet (the back end would be ok, but GNAT itself objects)
81
 
82
   Asiz : constant Integer := Integer (Address'Size) - 1;
83
 
84
   type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
85
   --  Signed type of same size as Address
86
 
87
   function To_A   is new Ada.Unchecked_Conversion (SA, Address);
88
   function From_A is new Ada.Unchecked_Conversion (Address, SA);
89
 
90
   function "+" (Left : Address; Right : Integer) return Address is
91
   begin
92
      return To_A (From_A (Left) + SA (Right));
93
   end "+";
94
 
95
   function "+" (Left : Integer; Right : Address) return Address is
96
   begin
97
      return To_A (SA (Left) + From_A (Right));
98
   end "+";
99
 
100
   function "-" (Left : Address; Right : Address) return Integer is
101
      pragma Unsuppress (All_Checks);
102
      --  Because this can raise Constraint_Error for 64-bit addresses
103
   begin
104
      return Integer (From_A (Left) - From_A (Right));
105
   end "-";
106
 
107
   function "-" (Left : Address; Right : Integer) return Address is
108
   begin
109
      return To_A (From_A (Left) - SA (Right));
110
   end "-";
111
 
112
   ------------------------
113
   -- Fetch_From_Address --
114
   ------------------------
115
 
116
   function Fetch_From_Address (A : Address) return Target is
117
      type T_Ptr is access all Target;
118
      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
119
      Ptr : constant T_Ptr := To_T_Ptr (A);
120
   begin
121
      return Ptr.all;
122
   end Fetch_From_Address;
123
 
124
   -----------------------
125
   -- Assign_To_Address --
126
   -----------------------
127
 
128
   procedure Assign_To_Address (A : Address; T : Target) is
129
      type T_Ptr is access all Target;
130
      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
131
      Ptr : constant T_Ptr := To_T_Ptr (A);
132
   begin
133
      Ptr.all := T;
134
   end Assign_To_Address;
135
 
136
   ---------------------------------
137
   -- Operations on Unsigned_Byte --
138
   ---------------------------------
139
 
140
   --  It would be nice to replace these with intrinsics, but that does
141
   --  not work yet (the back end would be ok, but GNAT itself objects)
142
 
143
   type BU is mod 2 ** Unsigned_Byte'Size;
144
   --  Unsigned type of same length as Unsigned_Byte
145
 
146
   function To_B   is new Ada.Unchecked_Conversion (BU, Unsigned_Byte);
147
   function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU);
148
 
149
   function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
150
   begin
151
      return To_B (not From_B (Left));
152
   end "not";
153
 
154
   function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
155
   begin
156
      return To_B (From_B (Left) and From_B (Right));
157
   end "and";
158
 
159
   function "or"  (Left, Right : Unsigned_Byte) return Unsigned_Byte is
160
   begin
161
      return To_B (From_B (Left) or From_B (Right));
162
   end "or";
163
 
164
   function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
165
   begin
166
      return To_B (From_B (Left) xor From_B (Right));
167
   end "xor";
168
 
169
   ---------------------------------
170
   -- Operations on Unsigned_Word --
171
   ---------------------------------
172
 
173
   --  It would be nice to replace these with intrinsics, but that does
174
   --  not work yet (the back end would be ok, but GNAT itself objects)
175
 
176
   type WU is mod 2 ** Unsigned_Word'Size;
177
   --  Unsigned type of same length as Unsigned_Word
178
 
179
   function To_W   is new Ada.Unchecked_Conversion (WU, Unsigned_Word);
180
   function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU);
181
 
182
   function "not" (Left : Unsigned_Word) return Unsigned_Word is
183
   begin
184
      return To_W (not From_W (Left));
185
   end "not";
186
 
187
   function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
188
   begin
189
      return To_W (From_W (Left) and From_W (Right));
190
   end "and";
191
 
192
   function "or"  (Left, Right : Unsigned_Word) return Unsigned_Word is
193
   begin
194
      return To_W (From_W (Left) or From_W (Right));
195
   end "or";
196
 
197
   function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
198
   begin
199
      return To_W (From_W (Left) xor From_W (Right));
200
   end "xor";
201
 
202
   -------------------------------------
203
   -- Operations on Unsigned_Longword --
204
   -------------------------------------
205
 
206
   --  It would be nice to replace these with intrinsics, but that does
207
   --  not work yet (the back end would be ok, but GNAT itself objects)
208
 
209
   type LWU is mod 2 ** Unsigned_Longword'Size;
210
   --  Unsigned type of same length as Unsigned_Longword
211
 
212
   function To_LW   is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword);
213
   function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU);
214
 
215
   function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
216
   begin
217
      return To_LW (not From_LW (Left));
218
   end "not";
219
 
220
   function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
221
   begin
222
      return To_LW (From_LW (Left) and From_LW (Right));
223
   end "and";
224
 
225
   function "or"  (Left, Right : Unsigned_Longword) return Unsigned_Longword is
226
   begin
227
      return To_LW (From_LW (Left) or From_LW (Right));
228
   end "or";
229
 
230
   function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
231
   begin
232
      return To_LW (From_LW (Left) xor From_LW (Right));
233
   end "xor";
234
 
235
   -------------------------------
236
   -- Operations on Unsigned_32 --
237
   -------------------------------
238
 
239
   --  It would be nice to replace these with intrinsics, but that does
240
   --  not work yet (the back end would be ok, but GNAT itself objects)
241
 
242
   type U32 is mod 2 ** Unsigned_32'Size;
243
   --  Unsigned type of same length as Unsigned_32
244
 
245
   function To_U32   is new Ada.Unchecked_Conversion (U32, Unsigned_32);
246
   function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32);
247
 
248
   function "not" (Left : Unsigned_32) return Unsigned_32 is
249
   begin
250
      return To_U32 (not From_U32 (Left));
251
   end "not";
252
 
253
   function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
254
   begin
255
      return To_U32 (From_U32 (Left) and From_U32 (Right));
256
   end "and";
257
 
258
   function "or"  (Left, Right : Unsigned_32) return Unsigned_32 is
259
   begin
260
      return To_U32 (From_U32 (Left) or From_U32 (Right));
261
   end "or";
262
 
263
   function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
264
   begin
265
      return To_U32 (From_U32 (Left) xor From_U32 (Right));
266
   end "xor";
267
 
268
   -------------------------------------
269
   -- Operations on Unsigned_Quadword --
270
   -------------------------------------
271
 
272
   --  It would be nice to replace these with intrinsics, but that does
273
   --  not work yet (the back end would be ok, but GNAT itself objects)
274
 
275
   type QWU is mod 2 ** 64;  -- 64 = Unsigned_Quadword'Size
276
   --  Unsigned type of same length as Unsigned_Quadword
277
 
278
   function To_QW   is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword);
279
   function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU);
280
 
281
   function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
282
   begin
283
      return To_QW (not From_QW (Left));
284
   end "not";
285
 
286
   function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
287
   begin
288
      return To_QW (From_QW (Left) and From_QW (Right));
289
   end "and";
290
 
291
   function "or"  (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
292
   begin
293
      return To_QW (From_QW (Left) or From_QW (Right));
294
   end "or";
295
 
296
   function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
297
   begin
298
      return To_QW (From_QW (Left) xor From_QW (Right));
299
   end "xor";
300
 
301
   -----------------------
302
   -- Clear_Interlocked --
303
   -----------------------
304
 
305
   procedure Clear_Interlocked
306
     (Bit       : in out Boolean;
307
      Old_Value : out Boolean)
308
   is
309
   begin
310
      SSL.Lock_Task.all;
311
      Old_Value := Bit;
312
      Bit := False;
313
      SSL.Unlock_Task.all;
314
   end Clear_Interlocked;
315
 
316
   procedure Clear_Interlocked
317
     (Bit          : in out Boolean;
318
      Old_Value    : out Boolean;
319
      Retry_Count  : Natural;
320
      Success_Flag : out Boolean)
321
   is
322
      pragma Warnings (Off, Retry_Count);
323
 
324
   begin
325
      SSL.Lock_Task.all;
326
      Old_Value := Bit;
327
      Bit := False;
328
      Success_Flag := True;
329
      SSL.Unlock_Task.all;
330
   end Clear_Interlocked;
331
 
332
   ---------------------
333
   -- Set_Interlocked --
334
   ---------------------
335
 
336
   procedure Set_Interlocked
337
     (Bit       : in out Boolean;
338
      Old_Value : out Boolean)
339
   is
340
   begin
341
      SSL.Lock_Task.all;
342
      Old_Value := Bit;
343
      Bit := True;
344
      SSL.Unlock_Task.all;
345
   end Set_Interlocked;
346
 
347
   procedure Set_Interlocked
348
     (Bit          : in out Boolean;
349
      Old_Value    : out Boolean;
350
      Retry_Count  : Natural;
351
      Success_Flag : out Boolean)
352
   is
353
      pragma Warnings (Off, Retry_Count);
354
 
355
   begin
356
      SSL.Lock_Task.all;
357
      Old_Value := Bit;
358
      Bit := True;
359
      Success_Flag := True;
360
      SSL.Unlock_Task.all;
361
   end Set_Interlocked;
362
 
363
   ---------------------
364
   -- Add_Interlocked --
365
   ---------------------
366
 
367
   procedure Add_Interlocked
368
     (Addend : Short_Integer;
369
      Augend : in out Aligned_Word;
370
      Sign   : out Integer)
371
   is
372
   begin
373
      SSL.Lock_Task.all;
374
      Augend.Value := Augend.Value + Addend;
375
 
376
      if Augend.Value < 0 then
377
         Sign := -1;
378
      elsif Augend.Value > 0 then
379
         Sign := +1;
380
      else
381
         Sign := 0;
382
      end if;
383
 
384
      SSL.Unlock_Task.all;
385
   end Add_Interlocked;
386
 
387
   ----------------
388
   -- Add_Atomic --
389
   ----------------
390
 
391
   procedure Add_Atomic
392
     (To     : in out Aligned_Integer;
393
      Amount : Integer)
394
   is
395
   begin
396
      SSL.Lock_Task.all;
397
      To.Value := To.Value + Amount;
398
      SSL.Unlock_Task.all;
399
   end Add_Atomic;
400
 
401
   procedure Add_Atomic
402
     (To           : in out Aligned_Integer;
403
      Amount       : Integer;
404
      Retry_Count  : Natural;
405
      Old_Value    : out Integer;
406
      Success_Flag : out Boolean)
407
   is
408
      pragma Warnings (Off, Retry_Count);
409
 
410
   begin
411
      SSL.Lock_Task.all;
412
      Old_Value := To.Value;
413
      To.Value  := To.Value + Amount;
414
      Success_Flag := True;
415
      SSL.Unlock_Task.all;
416
   end Add_Atomic;
417
 
418
   procedure Add_Atomic
419
     (To     : in out Aligned_Long_Integer;
420
      Amount : Long_Integer)
421
   is
422
   begin
423
      SSL.Lock_Task.all;
424
      To.Value := To.Value + Amount;
425
      SSL.Unlock_Task.all;
426
   end Add_Atomic;
427
 
428
   procedure Add_Atomic
429
     (To           : in out Aligned_Long_Integer;
430
      Amount       : Long_Integer;
431
      Retry_Count  : Natural;
432
      Old_Value    : out Long_Integer;
433
      Success_Flag : out Boolean)
434
   is
435
      pragma Warnings (Off, Retry_Count);
436
 
437
   begin
438
      SSL.Lock_Task.all;
439
      Old_Value := To.Value;
440
      To.Value  := To.Value + Amount;
441
      Success_Flag := True;
442
      SSL.Unlock_Task.all;
443
   end Add_Atomic;
444
 
445
   ----------------
446
   -- And_Atomic --
447
   ----------------
448
 
449
   type IU is mod 2 ** Integer'Size;
450
   type LU is mod 2 ** Long_Integer'Size;
451
 
452
   function To_IU   is new Ada.Unchecked_Conversion (Integer, IU);
453
   function From_IU is new Ada.Unchecked_Conversion (IU, Integer);
454
 
455
   function To_LU   is new Ada.Unchecked_Conversion (Long_Integer, LU);
456
   function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer);
457
 
458
   procedure And_Atomic
459
     (To   : in out Aligned_Integer;
460
      From : Integer)
461
   is
462
   begin
463
      SSL.Lock_Task.all;
464
      To.Value  := From_IU (To_IU (To.Value) and To_IU (From));
465
      SSL.Unlock_Task.all;
466
   end And_Atomic;
467
 
468
   procedure And_Atomic
469
     (To           : in out Aligned_Integer;
470
      From         : Integer;
471
      Retry_Count  : Natural;
472
      Old_Value    : out Integer;
473
      Success_Flag : out Boolean)
474
   is
475
      pragma Warnings (Off, Retry_Count);
476
 
477
   begin
478
      SSL.Lock_Task.all;
479
      Old_Value := To.Value;
480
      To.Value  := From_IU (To_IU (To.Value) and To_IU (From));
481
      Success_Flag := True;
482
      SSL.Unlock_Task.all;
483
   end And_Atomic;
484
 
485
   procedure And_Atomic
486
     (To   : in out Aligned_Long_Integer;
487
      From : Long_Integer)
488
   is
489
   begin
490
      SSL.Lock_Task.all;
491
      To.Value  := From_LU (To_LU (To.Value) and To_LU (From));
492
      SSL.Unlock_Task.all;
493
   end And_Atomic;
494
 
495
   procedure And_Atomic
496
     (To           : in out Aligned_Long_Integer;
497
      From         : Long_Integer;
498
      Retry_Count  : Natural;
499
      Old_Value    : out Long_Integer;
500
      Success_Flag : out Boolean)
501
   is
502
      pragma Warnings (Off, Retry_Count);
503
 
504
   begin
505
      SSL.Lock_Task.all;
506
      Old_Value := To.Value;
507
      To.Value  := From_LU (To_LU (To.Value) and To_LU (From));
508
      Success_Flag := True;
509
      SSL.Unlock_Task.all;
510
   end And_Atomic;
511
 
512
   ---------------
513
   -- Or_Atomic --
514
   ---------------
515
 
516
   procedure Or_Atomic
517
     (To   : in out Aligned_Integer;
518
      From : Integer)
519
   is
520
   begin
521
      SSL.Lock_Task.all;
522
      To.Value  := From_IU (To_IU (To.Value) or To_IU (From));
523
      SSL.Unlock_Task.all;
524
   end Or_Atomic;
525
 
526
   procedure Or_Atomic
527
     (To           : in out Aligned_Integer;
528
      From         : Integer;
529
      Retry_Count  : Natural;
530
      Old_Value    : out Integer;
531
      Success_Flag : out Boolean)
532
   is
533
      pragma Warnings (Off, Retry_Count);
534
 
535
   begin
536
      SSL.Lock_Task.all;
537
      Old_Value := To.Value;
538
      To.Value  := From_IU (To_IU (To.Value) or To_IU (From));
539
      Success_Flag := True;
540
      SSL.Unlock_Task.all;
541
   end Or_Atomic;
542
 
543
   procedure Or_Atomic
544
     (To   : in out Aligned_Long_Integer;
545
      From : Long_Integer)
546
   is
547
   begin
548
      SSL.Lock_Task.all;
549
      To.Value  := From_LU (To_LU (To.Value) or To_LU (From));
550
      SSL.Unlock_Task.all;
551
   end Or_Atomic;
552
 
553
   procedure Or_Atomic
554
     (To           : in out Aligned_Long_Integer;
555
      From         : Long_Integer;
556
      Retry_Count  : Natural;
557
      Old_Value    : out Long_Integer;
558
      Success_Flag : out Boolean)
559
   is
560
      pragma Warnings (Off, Retry_Count);
561
 
562
   begin
563
      SSL.Lock_Task.all;
564
      Old_Value := To.Value;
565
      To.Value  := From_LU (To_LU (To.Value) or To_LU (From));
566
      Success_Flag := True;
567
      SSL.Unlock_Task.all;
568
   end Or_Atomic;
569
 
570
   ------------------------------------
571
   -- Declarations for Queue Objects --
572
   ------------------------------------
573
 
574
   type QR;
575
 
576
   type QR_Ptr is access QR;
577
 
578
   type QR is record
579
      Forward  : QR_Ptr;
580
      Backward : QR_Ptr;
581
   end record;
582
 
583
   function To_QR_Ptr   is new Ada.Unchecked_Conversion (Address, QR_Ptr);
584
   function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address);
585
 
586
   ------------
587
   -- Insqhi --
588
   ------------
589
 
590
   procedure Insqhi
591
     (Item   : Address;
592
      Header : Address;
593
      Status : out Insq_Status)
594
   is
595
      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
596
      Next : constant QR_Ptr := Hedr.Forward;
597
      Itm  : constant QR_Ptr := To_QR_Ptr (Item);
598
 
599
   begin
600
      SSL.Lock_Task.all;
601
 
602
      Itm.Forward  := Next;
603
      Itm.Backward := Hedr;
604
      Hedr.Forward := Itm;
605
 
606
      if Next = null then
607
         Status := OK_First;
608
 
609
      else
610
         Next.Backward := Itm;
611
         Status := OK_Not_First;
612
      end if;
613
 
614
      SSL.Unlock_Task.all;
615
   end Insqhi;
616
 
617
   ------------
618
   -- Remqhi --
619
   ------------
620
 
621
   procedure Remqhi
622
     (Header : Address;
623
      Item   : out Address;
624
      Status : out Remq_Status)
625
   is
626
      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
627
      Next : constant QR_Ptr := Hedr.Forward;
628
 
629
   begin
630
      SSL.Lock_Task.all;
631
 
632
      Item := From_QR_Ptr (Next);
633
 
634
      if Next = null then
635
         Status := Fail_Was_Empty;
636
 
637
      else
638
         Hedr.Forward := To_QR_Ptr (Item).Forward;
639
 
640
         if Hedr.Forward = null then
641
            Status := OK_Empty;
642
 
643
         else
644
            Hedr.Forward.Backward := Hedr;
645
            Status := OK_Not_Empty;
646
         end if;
647
      end if;
648
 
649
      SSL.Unlock_Task.all;
650
   end Remqhi;
651
 
652
   ------------
653
   -- Insqti --
654
   ------------
655
 
656
   procedure Insqti
657
     (Item   : Address;
658
      Header : Address;
659
      Status : out Insq_Status)
660
   is
661
      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
662
      Prev : constant QR_Ptr := Hedr.Backward;
663
      Itm  : constant QR_Ptr := To_QR_Ptr (Item);
664
 
665
   begin
666
      SSL.Lock_Task.all;
667
 
668
      Itm.Backward  := Prev;
669
      Itm.Forward   := Hedr;
670
      Hedr.Backward := Itm;
671
 
672
      if Prev = null then
673
         Status := OK_First;
674
 
675
      else
676
         Prev.Forward := Itm;
677
         Status := OK_Not_First;
678
      end if;
679
 
680
      SSL.Unlock_Task.all;
681
   end Insqti;
682
 
683
   ------------
684
   -- Remqti --
685
   ------------
686
 
687
   procedure Remqti
688
     (Header : Address;
689
      Item   : out Address;
690
      Status : out Remq_Status)
691
   is
692
      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
693
      Prev : constant QR_Ptr := Hedr.Backward;
694
 
695
   begin
696
      SSL.Lock_Task.all;
697
 
698
      Item := From_QR_Ptr (Prev);
699
 
700
      if Prev = null then
701
         Status := Fail_Was_Empty;
702
 
703
      else
704
         Hedr.Backward := To_QR_Ptr (Item).Backward;
705
 
706
         if Hedr.Backward = null then
707
            Status := OK_Empty;
708
 
709
         else
710
            Hedr.Backward.Forward := Hedr;
711
            Status := OK_Not_Empty;
712
         end if;
713
      end if;
714
 
715
      SSL.Unlock_Task.all;
716
   end Remqti;
717
 
718
end System.Aux_DEC;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.