cgit.sxemacs.org Git - sxemacs/blob - modules/ase/ase-heap.c

   1 /*
   2   ase-heap.c -- Heaps
   3   Copyright (C) 2007 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt <hroptatyr@sxemacs.org>
   6
   7   * This file is part of SXEmacs.
   8   *
   9   * Redistribution and use in source and binary forms, with or without
  10   * modification, are permitted provided that the following conditions
  11   * are met:
  12   *
  13   * 1. Redistributions of source code must retain the above copyright
  14   *    notice, this list of conditions and the following disclaimer.
  15   *
  16   * 2. Redistributions in binary form must reproduce the above copyright
  17   *    notice, this list of conditions and the following disclaimer in the
  18   *    documentation and/or other materials provided with the distribution.
  19   *
  20   * 3. Neither the name of the author nor the names of any contributors
  21   *    may be used to endorse or promote products derived from this
  22   *    software without specific prior written permission.
  23   *
  24   * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  25   * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  26   * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27   * DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  28   * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  29   * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  30   * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  31   * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  32   * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  33   * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  34   * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35   */
  36
  37 /* Synched up with: Not in FSF. */
  38
  39 #include "config.h"
  40 #include "sxemacs.h"
  41 #include "ent/ent.h"
  42 #include "ase-heap.h"
  43 #include "opaque.h"
  44
  45 #ifdef ALL_DEBUG_FLAGS
  46 #undef EMOD_ASE_DEBUG_FLAG
  47 #define EMOD_ASE_DEBUG_FLAG
  48 #endif
  49
  50 #define EMOD_ASE_DEBUG_HEAP(args...)    EMOD_ASE_DEBUG("[HEAP]: " args)
  51
  52 PROVIDE(ase_heap);
  53
  54 Lisp_Object Qase_heap, Qase_heapp;
  55 Lisp_Object Qase_yheap, Qase_yheapp;
  56 Lisp_Object Qase_dheap, Qase_dheapp;
  57 Lisp_Object Qase_wheap, Qase_wheapp;
  58 Lisp_Object Qase_heap_default_kind;
  59
  60 Lisp_Object Qweak, Qdense, Qdynamic, Q_kind, Q_relation, Q_coloured;
  61
  62 #define ASE_HEAP_MIN_SIZE       4096    /* 65536 */
  63 #define ALIGNED(n)      __attribute__((aligned(n), packed))
  64
  65 /* the op tables */
  66 struct ase_heap_ops_s ase_heap_ops[NUMBER_OF_ASE_HEAP_KINDS] =
  67 {{(ase_heap_constr_f)_ase_make_yheap, (ase_heap_wrap_f)_ase_wrap_yheap,
  68   (ase_heap_add_f)ase_add_yheap, (ase_heap_pop_f)ase_pop_yheap},
  69  {(ase_heap_constr_f)_ase_make_dheap, (ase_heap_wrap_f)_ase_wrap_dheap,
  70   (ase_heap_add_f)ase_add_dheap, (ase_heap_pop_f)ase_pop_dheap},
  71  {(ase_heap_constr_f)_ase_make_wheap, (ase_heap_wrap_f)_ase_wrap_wheap,
  72   (ase_heap_add_f)ase_add_wheap, (ase_heap_pop_f)ase_pop_wheap}};
  73
  74 /* hidden structs */
  75 struct ase_yheap_cell_s {
  76         Lisp_Object data;
  77         Lisp_Object colour;
  78
  79         ase_yheap_cell_t left;
  80         ase_yheap_cell_t right;
  81
  82         ase_yheap_cell_t mother;
  83         ase_yheap_t father;
  84
  85         ase_yheap_cell_t prev;
  86         ase_yheap_cell_t next;
  87 };
  88
  89 \f
  90 /* auxiliary stuff */
  91 static inline void
  92 __ase_array_swap(Lisp_Object *d, int idx1, int idx2)
  93         __attribute__((always_inline));
  94 static inline void
  95 __ase_array_swap(Lisp_Object *d, int idx1, int idx2)
  96 {
  97         Lisp_Object tmp = d[idx1];
  98         d[idx1] = d[idx2];
  99         d[idx2] = tmp;
 100         return;
 101 }
 102
 103 static inline void
 104 _ase_dheap_swap(ase_dheap_t h, int idx1, int idx2)
 105         __attribute__((always_inline));
 106 static inline void
 107 _ase_dheap_swap(ase_dheap_t h, int idx1, int idx2)
 108 {
 109         Lisp_Object *d;
 110
 111         /* swap priority data */
 112         d = ase_dheap_cells(h);
 113         __ase_array_swap(d, idx1, idx2);
 114
 115         if (!ase_heap_opts_coloured(h))
 116                 return;
 117
 118         /* swap colours too */
 119         d = ase_dheap_colours(h);
 120         __ase_array_swap(d, idx1, idx2);
 121         return;
 122 }
 123
 124 static inline void
 125 _ase_wheap_swap(ase_wheap_t h, int idx1, int idx2)
 126         __attribute__((always_inline));
 127 static inline void
 128 _ase_wheap_swap(ase_wheap_t h, int idx1, int idx2)
 129 {
 130         Lisp_Object *d;
 131
 132         /* swap priority data */
 133         d = ase_wheap_cells(h);
 134         __ase_array_swap(d, idx1, idx2);
 135
 136         if (!ase_heap_opts_coloured(h))
 137                 return;
 138
 139         /* swap colours too */
 140         d = ase_wheap_colours(h);
 141         __ase_array_swap(d, idx1, idx2);
 142         return;
 143 }
 144
 145 static inline void
 146 _ase_yheap_cell_swap_data(ase_yheap_cell_t c1, ase_yheap_cell_t c2)
 147         __attribute__((always_inline));
 148 static inline void
 149 _ase_yheap_cell_swap_data(ase_yheap_cell_t c1, ase_yheap_cell_t c2)
 150 {
 151         Lisp_Object l1 = ase_yheap_cell_data(c1);
 152         Lisp_Object l2 = ase_yheap_cell_data(c2);
 153
 154         ase_yheap_cell_data(c1) = l2;
 155         ase_yheap_cell_data(c2) = l1;
 156
 157         /* for coloured heaps */
 158         l1 = ase_yheap_cell_colour(c1);
 159         l2 = ase_yheap_cell_colour(c2);
 160         ase_yheap_cell_colour(c1) = l2;
 161         ase_yheap_cell_colour(c2) = l1;
 162         return;
 163 }
 164
 165 /* stuff for the dynacat, printers */
 166 static inline void
 167 _ase_yheap_prnt_cell(ase_yheap_cell_t c, Lisp_Object pcf)
 168 {
 169         write_c_string(" ", pcf);
 170         print_internal(ase_yheap_cell_data(c), pcf, 0);
 171 }
 172
 173 static inline void
 174 _ase_yheap_prnt(ase_yheap_t a, Lisp_Object pcf)
 175 {
 176         ase_yheap_cell_t c = ase_yheap_root(a);
 177
 178         if (c == NULL) {
 179                 write_c_string(" empty", pcf);
 180                 return;
 181         }
 182
 183         while (c && ase_yheap_cell_data(c) != Qnull_pointer) {
 184                 _ase_yheap_prnt_cell(c, pcf);
 185                 c = ase_yheap_cell_next(c);
 186         }
 187         return;
 188 }
 189
 190 static void
 191 ase_yheap_prnt(Lisp_Object obj, Lisp_Object pcf, int SXE_UNUSED(foo))
 192 {
 193         ase_yheap_t h = XASE_YHEAP(obj);
 194
 195         EMOD_ASE_DEBUG_HEAP("h:0x%08lx@0x%08lx shall be printed...\n",
 196                             (long unsigned int)h, (long unsigned int)obj);
 197         write_c_string("#<ase:heap :dynamic", pcf);
 198
 199         write_c_string(" :size ", pcf);
 200         write_fmt_str(pcf, "%u", (unsigned int)ase_yheap_size(h));
 201
 202         if (ase_yheap_root(h) != NULL &&
 203             ase_yheap_cell_data(ase_yheap_root(h)) != Qnull_pointer) {
 204                 write_c_string(" :elements", pcf);
 205                 _ase_yheap_prnt(h, pcf);
 206         } else {
 207                 write_c_string(" :empty>", pcf);
 208                 return;
 209         }
 210         write_c_string(">", pcf);
 211 }
 212
 213 static inline void
 214 _ase_dheap_prnt(ase_dheap_t h, Lisp_Object pcf)
 215 {
 216         size_t size = ase_dheap_size(h);
 217         Lisp_Object *d = ase_dheap_cells(h);
 218         unsigned int i;
 219
 220         for (i = 0; i < size; i++) {
 221                 write_c_string(" ", pcf);
 222                 print_internal(d[i], pcf, 0);
 223         }
 224         return;
 225 }
 226
 227 static void
 228 ase_dheap_prnt(Lisp_Object obj, Lisp_Object pcf, int SXE_UNUSED(foo))
 229 {
 230         ase_dheap_t h = XASE_DHEAP(obj);
 231
 232         EMOD_ASE_DEBUG_HEAP("d:0x%08lx@0x%08lx shall be printed...\n",
 233                             (long unsigned int)h, (long unsigned int)obj);
 234
 235         write_fmt_str(pcf, "#<ase:heap :dense :size %u",
 236                       (unsigned int)ase_dheap_size(h));
 237
 238         if (ase_heap_opts_coloured(h)) {
 239                 write_c_string(" :coloured", pcf);
 240         }
 241
 242         if (ase_dheap_size(h)) {
 243                 write_c_string(" :elements", pcf);
 244                 _ase_dheap_prnt(h, pcf);
 245         } else {
 246                 write_c_string(" :empty>", pcf);
 247                 return;
 248         }
 249         write_c_string(">", pcf);
 250 }
 251
 252 static inline void
 253 _ase_wheap_prnt(ase_wheap_t h, Lisp_Object pcf)
 254 {
 255         size_t size = ase_wheap_size(h);
 256         Lisp_Object *d = ase_wheap_cells(h);
 257         unsigned int i;
 258
 259         for (i = 0; i < size; i++) {
 260                 write_c_string(" ", pcf);
 261                 print_internal(d[i], pcf, 0);
 262         }
 263         return;
 264 }
 265
 266 static void
 267 ase_wheap_prnt(Lisp_Object obj, Lisp_Object pcf, int SXE_UNUSED(foo))
 268 {
 269         ase_wheap_t h = XASE_WHEAP(obj);
 270
 271         EMOD_ASE_DEBUG_HEAP("w:0x%08lx@0x%08lx shall be printed...\n",
 272                             (long unsigned int)h, (long unsigned int)obj);
 273         write_fmt_string(pcf, "#<ase:heap :weak :size %u",
 274                          (unsigned int)ase_wheap_size(h));
 275
 276         if (ase_heap_opts_coloured(h)) {
 277                 write_c_string(" :coloured", pcf);
 278         }
 279
 280         if (ase_wheap_size(h)) {
 281                 write_c_string(" :elements", pcf);
 282                 _ase_wheap_prnt(h, pcf);
 283         } else {
 284                 write_c_string(" :empty>", pcf);
 285                 return;
 286         }
 287         write_c_string(">", pcf);
 288 }
 289
 290 static inline void
 291 _ase_yheap_cell_fini(ase_yheap_cell_t c)
 292         __attribute__((always_inline));
 293 static inline void
 294 _ase_yheap_cell_fini(ase_yheap_cell_t c)
 295 {
 296         EMOD_ASE_DEBUG_HEAP("c:0x%08lx shall be freed...\n",
 297                             (long unsigned int)c);
 298
 299         memset(c, 0, sizeof(struct ase_yheap_cell_s));
 300         xfree(c);
 301         return;
 302 }
 303
 304 static inline void
 305 _ase_yheap_fini(ase_yheap_t h)
 306         __attribute__((always_inline));
 307 static inline void
 308 _ase_yheap_fini(ase_yheap_t h)
 309 {
 310         ase_yheap_cell_t c;
 311         ase_heap_lock(h);
 312         EMOD_ASE_DEBUG_HEAP("h:0x%08lx freeing used/free cells...\n",
 313                             (long unsigned int)h);
 314         c = ase_yheap_root(h);
 315         while (c) {
 316                 ase_yheap_cell_t tmp = ase_yheap_cell_next(c);
 317                 _ase_yheap_cell_fini(c);
 318                 c = tmp;
 319         }
 320
 321         ase_heap_unlock(h);
 322         ase_heap_fini_mutex(h);
 323         xfree(ase_heap_options(h));
 324         return;
 325 }
 326
 327 static void
 328 ase_yheap_fini(Lisp_Object obj, int SXE_UNUSED(foo))
 329 {
 330         ase_yheap_t h = XASE_YHEAP(obj);
 331
 332         EMOD_ASE_DEBUG_HEAP("h:0x%08lx@0x%08lx shall be freed...\n",
 333                             (long unsigned int)h, (long unsigned int)obj);
 334
 335         _ase_yheap_fini(h);
 336         memset(h, 0, sizeof(struct ase_yheap_s));
 337         xfree(h);
 338         return;
 339 }
 340
 341 static inline void
 342 _ase_dheap_fini(ase_dheap_t h)
 343         __attribute__((always_inline));
 344 static inline void
 345 _ase_dheap_fini(ase_dheap_t h)
 346 {
 347         ase_heap_lock(h);
 348         xfree(ase_dheap_cells(h));
 349         if (ase_dheap_colours(h)) {
 350                 xfree(ase_dheap_colours(h));
 351         }
 352         ase_heap_unlock(h);
 353         ase_heap_fini_mutex(h);
 354         xfree(ase_heap_options(h));
 355         return;
 356 }
 357
 358 static void
 359 ase_dheap_fini(Lisp_Object obj, int SXE_UNUSED(foo))
 360 {
 361         ase_dheap_t h = XASE_DHEAP(obj);
 362
 363         EMOD_ASE_DEBUG_HEAP("d:0x%08lx@0x%08lx shall be freed...\n",
 364                             (long unsigned int)h, (long unsigned int)obj);
 365
 366         _ase_dheap_fini(h);
 367         memset(h, 0, sizeof(struct ase_dheap_s));
 368         xfree(h);
 369         return;
 370 }
 371
 372 static inline void
 373 _ase_wheap_fini(ase_wheap_t h)
 374         __attribute__((always_inline));
 375 static inline void
 376 _ase_wheap_fini(ase_wheap_t h)
 377 {
 378         ase_heap_lock(h);
 379         xfree(ase_wheap_cells(h));
 380         xfree(ase_wheap_rbits(h));
 381         if (ase_dheap_colours(h)) {
 382                 xfree(ase_wheap_colours(h));
 383         }
 384         ase_heap_unlock(h);
 385         ase_heap_fini_mutex(h);
 386         xfree(ase_heap_options(h));
 387         return;
 388 }
 389
 390 static void
 391 ase_wheap_fini(Lisp_Object obj, int SXE_UNUSED(foo))
 392 {
 393         ase_wheap_t h = XASE_WHEAP(obj);
 394
 395         EMOD_ASE_DEBUG_HEAP("w:0x%08lx@0x%08lx shall be freed...\n",
 396                             (long unsigned int)h, (long unsigned int)obj);
 397
 398         _ase_wheap_fini(h);
 399         memset(h, 0, sizeof(struct ase_wheap_s));
 400         xfree(h);
 401         return;
 402 }
 403
 404 static inline void
 405 _ase_yheap_mark_cell(ase_yheap_cell_t c)
 406 {
 407         if (c == NULL || ase_yheap_cell_data(c) == Qnull_pointer)
 408                 return;
 409         mark_object(ase_yheap_cell_data(c));
 410         mark_object(ase_yheap_cell_colour(c));
 411 }
 412
 413 static void
 414 ase_yheap_mark(Lisp_Object obj)
 415 {
 416         ase_yheap_t h = XASE_YHEAP(obj);
 417         ase_yheap_cell_t c = ase_yheap_root(h);
 418
 419         EMOD_ASE_DEBUG_HEAP("h:0x%08lx@0x%08lx shall be marked...\n",
 420                             (long unsigned int)h, (long unsigned int)obj);
 421
 422         ase_heap_lock(h);
 423         while (c && ase_yheap_cell_data(c) != Qnull_pointer) {
 424                 _ase_yheap_mark_cell(c);
 425                 c = ase_yheap_cell_next(c);
 426         }
 427         ase_heap_unlock(h);
 428         return;
 429 }
 430
 431 static void
 432 ase_dheap_mark(Lisp_Object obj)
 433 {
 434         ase_dheap_t h = XASE_DHEAP(obj);
 435         Lisp_Object *d, *c;
 436         size_t size;
 437         unsigned int i;
 438
 439         EMOD_ASE_DEBUG_HEAP("d:0x%08lx@0x%08lx shall be marked...\n",
 440                             (long unsigned int)h, (long unsigned int)obj);
 441
 442         ase_heap_lock(h);
 443         d = ase_dheap_cells(h);
 444         c = ase_dheap_colours(h);
 445         size = ase_dheap_size(h);
 446         for (i = 0; i < size; i++) {
 447                 mark_object(d[i]);
 448         }
 449         if (c) {
 450                 for (i = 0; i < size; i++) {
 451                         mark_object(c[i]);
 452                 }
 453         }
 454         ase_heap_unlock(h);
 455         return;
 456 }
 457
 458 static void
 459 ase_wheap_mark(Lisp_Object obj)
 460 {
 461         ase_wheap_t h = XASE_WHEAP(obj);
 462         Lisp_Object *d, *c;
 463         size_t size;
 464         unsigned int i;
 465
 466         EMOD_ASE_DEBUG_HEAP("w:0x%08lx@0x%08lx shall be marked...\n",
 467                             (long unsigned int)h, (long unsigned int)obj);
 468
 469         ase_heap_lock(h);
 470         d = ase_wheap_cells(h);
 471         c = ase_wheap_colours(h);
 472         size = ase_wheap_size(h);
 473         for (i = 0; i < size; i++) {
 474                 mark_object(d[i]);
 475         }
 476         if (c) {
 477                 for (i = 0; i < size; i++) {
 478                         mark_object(c[i]);
 479                 }
 480         }
 481         ase_heap_unlock(h);
 482         return;
 483 }
 484
 485 \f
 486 static inline ase_yheap_cell_t
 487 _ase_make_initial_heap_cell(void)
 488         __attribute__((always_inline));
 489 static inline ase_yheap_cell_t
 490 _ase_make_initial_heap_cell(void)
 491 {
 492         ase_yheap_cell_t c = xnew(struct ase_yheap_cell_s);
 493
 494         ase_yheap_cell_data(c) = Qnull_pointer;
 495         ase_yheap_cell_colour(c) = Qnil;
 496         ase_yheap_cell_left(c) = NULL;
 497         ase_yheap_cell_right(c) = NULL;
 498         ase_yheap_cell_mother(c) = NULL;
 499         ase_yheap_cell_father(c) = NULL;
 500         ase_yheap_cell_prev(c) = NULL;
 501         ase_yheap_cell_next(c) = NULL;
 502
 503         EMOD_ASE_DEBUG_HEAP("c:0x%08lx shall be created...\n",
 504                             (long unsigned int)c);
 505         return c;
 506 }
 507
 508 static inline ase_yheap_cell_t
 509 _ase_make_heap_cell(ase_yheap_cell_t mother)
 510         __attribute__((always_inline));
 511 static inline ase_yheap_cell_t
 512 _ase_make_heap_cell(ase_yheap_cell_t mother)
 513 {
 514         ase_yheap_cell_t c = xnew(struct ase_yheap_cell_s);
 515
 516         ase_yheap_cell_data(c) = Qnull_pointer;
 517         ase_yheap_cell_colour(c) = Qnil;
 518         ase_yheap_cell_left(c) = NULL;
 519         ase_yheap_cell_right(c) = NULL;
 520         ase_yheap_cell_mother(c) = mother;
 521         ase_yheap_cell_father(c) = ase_yheap_cell_father(mother);
 522         ase_yheap_cell_prev(c) = NULL;
 523         ase_yheap_cell_next(c) = NULL;
 524
 525         EMOD_ASE_DEBUG_HEAP("c:0x%08lx shall be created...\n",
 526                             (long unsigned int)c);
 527         return c;
 528 }
 529
 530 Lisp_Object
 531 _ase_wrap_yheap(ase_yheap_t h)
 532 {
 533         Lisp_Object result;
 534
 535         result = make_dynacat(h);
 536         XDYNACAT(result)->type = Qase_yheap;
 537
 538         set_dynacat_printer(result, ase_yheap_prnt);
 539         set_dynacat_marker(result, ase_yheap_mark);
 540         set_dynacat_finaliser(result, ase_yheap_fini);
 541         set_dynacat_intprinter(
 542                 result, (dynacat_intprinter_f)_ase_yheap_prnt);
 543
 544         EMOD_ASE_DEBUG_HEAP("h:0x%08lx shall be wrapped to 0x%08lx...\n",
 545                             (long unsigned int)h, (long unsigned int)result);
 546
 547         return result;
 548 }
 549
 550 Lisp_Object
 551 _ase_wrap_dheap(ase_dheap_t h)
 552 {
 553         Lisp_Object result;
 554
 555         result = make_dynacat(h);
 556         XDYNACAT(result)->type = Qase_dheap;
 557
 558         set_dynacat_printer(result, ase_dheap_prnt);
 559         set_dynacat_marker(result, ase_dheap_mark);
 560         set_dynacat_finaliser(result, ase_dheap_fini);
 561         set_dynacat_intprinter(
 562                 result, (dynacat_intprinter_f)_ase_dheap_prnt);
 563
 564         EMOD_ASE_DEBUG_HEAP("d:0x%08lx shall be wrapped to 0x%08lx...\n",
 565                             (long unsigned int)h, (long unsigned int)result);
 566
 567         return result;
 568 }
 569
 570 ase_dheap_t
 571 _ase_make_dheap(ase_heap_options_t opts)
 572 {
 573         ase_dheap_t h = xnew(struct ase_dheap_s);
 574         size_t all = ase_heap_options_min_size(opts);
 575         Lisp_Object *d;
 576
 577         /* status so far */
 578         ase_dheap_size(h) = 0;
 579         ase_heap_init_mutex(h);
 580         ase_dheap_heapp(h) = 1;
 581
 582         /* options */
 583         ase_heap_options(h) = opts;
 584
 585         d = xnew_array_and_zero(Lisp_Object, all);
 586         ase_dheap_cells(h) = d;
 587         ase_dheap_colours(h) = NULL;
 588         ase_dheap_alloc(h) = all;
 589
 590         if (ase_heap_options_coloured(opts))
 591                 ase_dheap_colours(h) = xnew_array_and_zero(Lisp_Object, all);
 592
 593         EMOD_ASE_DEBUG_HEAP("d:0x%08lx shall be created...\n",
 594                             (long unsigned int)h);
 595
 596         return h;
 597 }
 598
 599 Lisp_Object ase_make_dheap(ase_heap_options_t opts)
 600 {
 601         ase_dheap_t h = NULL;
 602
 603         h = _ase_make_dheap(opts);
 604         return _ase_wrap_dheap(h);
 605 }
 606
 607 Lisp_Object
 608 _ase_wrap_wheap(ase_wheap_t h)
 609 {
 610         Lisp_Object result;
 611
 612         result = make_dynacat(h);
 613         XDYNACAT(result)->type = Qase_wheap;
 614
 615         set_dynacat_printer(result, ase_wheap_prnt);
 616         set_dynacat_marker(result, ase_wheap_mark);
 617         set_dynacat_finaliser(result, ase_wheap_fini);
 618         set_dynacat_intprinter(
 619                 result, (dynacat_intprinter_f)_ase_wheap_prnt);
 620
 621         EMOD_ASE_DEBUG_HEAP("w:0x%08lx shall be wrapped to 0x%08lx...\n",
 622                             (long unsigned int)h, (long unsigned int)result);
 623
 624         return result;
 625 }
 626
 627 ase_wheap_t
 628 _ase_make_wheap(ase_heap_options_t opts)
 629 {
 630         ase_wheap_t h = xnew(struct ase_wheap_s);
 631         size_t all = ase_heap_options_min_size(opts);
 632         Lisp_Object *d;
 633         int *r;
 634
 635         /* status so far */
 636         ase_wheap_size(h) = 0;
 637         ase_heap_init_mutex(h);
 638         ase_wheap_heapp(h) = 1;
 639
 640         /* options */
 641         ase_heap_options(h) = opts;
 642
 643         d = xnew_array_and_zero(Lisp_Object, all);
 644         r = xnew_array_and_zero(int, all / sizeof(int) / 8);
 645         ase_wheap_cells(h) = d;
 646         ase_wheap_rbits(h) = r;
 647         ase_wheap_colours(h) = NULL;
 648         ase_wheap_alloc(h) = all;
 649
 650         if (ase_heap_options_coloured(opts))
 651                 ase_dheap_colours(h) = xnew_array_and_zero(Lisp_Object, all);
 652
 653         EMOD_ASE_DEBUG_HEAP("w:0x%08lx shall be created...\n",
 654                             (long unsigned int)h);
 655
 656         return h;
 657 }
 658
 659 Lisp_Object ase_make_wheap(ase_heap_options_t opts)
 660 {
 661         ase_wheap_t h = NULL;
 662
 663         h = _ase_make_wheap(opts);
 664         return _ase_wrap_wheap(h);
 665 }
 666
 667 inline ase_yheap_t
 668 _ase_make_yheap(ase_heap_options_t opts)
 669 {
 670         ase_yheap_t h = xnew(struct ase_yheap_s);
 671         ase_yheap_cell_t c;
 672
 673         /* status so far */
 674         ase_heap_init_mutex(h);
 675         ase_yheap_heapp(h) = 1;
 676
 677         /* options */
 678         ase_heap_options(h) = opts;
 679
 680         /* create one empty cell */
 681         c = _ase_make_initial_heap_cell();
 682         ase_yheap_cell_father(c) = h;
 683         ase_yheap_root(h) = NULL;
 684         ase_yheap_first_free(h) = ase_yheap_last_free(h) = c;
 685         ase_yheap_size(h) = 0;
 686         ase_yheap_alloc(h) = 1;
 687
 688         EMOD_ASE_DEBUG_HEAP("h:0x%08lx shall be created...\n",
 689                             (long unsigned int)h);
 690         return h;
 691 }
 692
 693 Lisp_Object ase_make_yheap(ase_heap_options_t opts)
 694 {
 695         ase_yheap_t h = NULL;
 696
 697         h = _ase_make_yheap(opts);
 698         return _ase_wrap_yheap(h);
 699 }
 700
 701 \f
 702 static inline void
 703 _ase_fixup_heap_cell(ase_yheap_t h, ase_yheap_cell_t c)
 704         __attribute__((always_inline));
 705 static inline void
 706 _ase_fixup_heap_cell(ase_yheap_t h, ase_yheap_cell_t c)
 707 {
 708         /* create new free cells */
 709         if (ase_yheap_cell_left(c) == NULL &&
 710             ase_yheap_cell_right(c) == NULL) {
 711                 ase_yheap_cell_t l = ase_yheap_last_free(h);
 712                 ase_yheap_cell_t n = _ase_make_heap_cell(c);
 713
 714                 ase_yheap_cell_left(c) = n;
 715                 /* append c to l */
 716                 ase_yheap_cell_prev(n) = l;
 717                 ase_yheap_cell_next(l) = n;
 718                 l = ase_yheap_last_free(h) = n;
 719                 ase_yheap_alloc(h)++;
 720
 721                 n = _ase_make_heap_cell(c);
 722                 ase_yheap_cell_right(c) = n;
 723                 /* append c to l */
 724                 ase_yheap_cell_prev(n) = l;
 725                 ase_yheap_cell_next(l) = n;
 726                 ase_yheap_last_free(h) = n;
 727                 ase_yheap_alloc(h)++;
 728         }
 729 }
 730
 731 static inline void
 732 _ase_dheap_realloc(ase_dheap_t h, size_t new_alloc)
 733         __attribute__((always_inline));
 734 static inline void
 735 _ase_dheap_realloc(ase_dheap_t h, size_t new_alloc)
 736 {
 737         Lisp_Object *oldd = ase_dheap_cells(h);
 738         Lisp_Object *newd = NULL;
 739         size_t s = ase_dheap_size(h);
 740
 741         newd = xnew_array_and_zero(Lisp_Object, new_alloc);
 742         memcpy(newd, oldd, sizeof(Lisp_Object)*s);
 743         xfree(oldd);
 744         ase_dheap_cells(h) = newd;
 745         ase_dheap_alloc(h) = new_alloc;
 746
 747         if (!ase_heap_opts_coloured(h))
 748                 return;
 749
 750         oldd = ase_dheap_colours(h);
 751         newd = xnew_array_and_zero(Lisp_Object, new_alloc);
 752         memcpy(newd, oldd, sizeof(Lisp_Object)*s);
 753         xfree(oldd);
 754         ase_dheap_colours(h) = newd;
 755         return;
 756 }
 757
 758 static inline void
 759 _ase_dheap_check_resize(ase_dheap_t h)
 760         __attribute__((always_inline));
 761 static inline void
 762 _ase_dheap_check_resize(ase_dheap_t h)
 763 {
 764         size_t s = ase_dheap_size(h), all = ase_dheap_alloc(h);
 765
 766         if (s < ase_heap_opts_min_size(h))
 767                 return;
 768
 769         if (s >= all) {
 770                 EMOD_ASE_DEBUG_HEAP("d:0x%08lx upsize from %d to %d\n",
 771                                     (long unsigned int)h,
 772                                     (int)all, (int)(all*2));
 773                 _ase_dheap_realloc(h, 2*all);
 774                 return;
 775         }
 776         if (s <= all/4) {
 777                 EMOD_ASE_DEBUG_HEAP("d:0x%08lx downsize from %d to %d\n",
 778                                     (long unsigned int)h,
 779                                     (int)all, (int)(all/2));
 780                 _ase_dheap_realloc(h, all/2);
 781                 return;
 782         }
 783 }
 784
 785 static inline void
 786 _ase_wheap_realloc(ase_wheap_t h, size_t new_alloc)
 787         __attribute__((always_inline));
 788 static inline void
 789 _ase_wheap_realloc(ase_wheap_t h, size_t new_alloc)
 790 {
 791         Lisp_Object *oldd = ase_wheap_cells(h);
 792         Lisp_Object *newd = NULL;
 793         int *oldr = ase_wheap_rbits(h);
 794         int *newr = NULL;
 795         size_t s = ase_wheap_size(h);
 796
 797         newd = xnew_array_and_zero(Lisp_Object, new_alloc);
 798         newr = xnew_array_and_zero(int, new_alloc/sizeof(int)/8);
 799         memcpy(newd, oldd, sizeof(Lisp_Object)*s);
 800         memcpy(newr, oldr, s/8);
 801         xfree(oldd);
 802         xfree(oldr);
 803         ase_wheap_cells(h) = newd;
 804         ase_wheap_rbits(h) = newr;
 805         ase_wheap_alloc(h) = new_alloc;
 806
 807         if (!ase_heap_opts_coloured(h))
 808                 return;
 809
 810         oldd = ase_wheap_colours(h);
 811         newd = xnew_array_and_zero(Lisp_Object, new_alloc);
 812         memcpy(newd, oldd, sizeof(Lisp_Object)*s);
 813         xfree(oldd);
 814         ase_wheap_colours(h) = newd;
 815         return;
 816 }
 817
 818 static inline void
 819 _ase_wheap_check_resize(ase_wheap_t h)
 820         __attribute__((always_inline));
 821 static inline void
 822 _ase_wheap_check_resize(ase_wheap_t h)
 823 {
 824         size_t s = ase_wheap_size(h), all = ase_wheap_alloc(h);
 825
 826         if (s < ase_heap_opts_min_size(h))
 827                 return;
 828
 829         if (s >= all) {
 830                 EMOD_ASE_DEBUG_HEAP("w:0x%08lx upsize from %d to %d\n",
 831                                     (long unsigned int)h,
 832                                     (int)all, (int)(all*2));
 833                 _ase_wheap_realloc(h, 2*all);
 834                 return;
 835         }
 836         if (s <= all/4) {
 837                 EMOD_ASE_DEBUG_HEAP("w:0x%08lx downsize from %d to %d\n",
 838                                     (long unsigned int)h,
 839                                     (int)all, (int)(all/2));
 840                 _ase_wheap_realloc(h, all/2);
 841                 return;
 842         }
 843 }
 844
 845 /* dense heap navigation */
 846 static inline int
 847 ase_dheap_cell_mother(int c)
 848         __attribute__((always_inline));
 849 static inline int
 850 ase_dheap_cell_mother(int c)
 851 {
 852         return (c-1) >> 1;
 853 }
 854
 855 static inline int
 856 ase_dheap_cell_left(int c)
 857         __attribute__((always_inline));
 858 static inline int
 859 ase_dheap_cell_left(int c)
 860 {
 861         return 2*c+1;
 862 }
 863
 864 static inline int
 865 ase_dheap_cell_right(int c)
 866         __attribute__((always_inline));
 867 static inline int
 868 ase_dheap_cell_right(int c)
 869 {
 870         return 2*c+2;
 871 }
 872
 873 /* weak heap navigation */
 874 static inline int
 875 ase_wheap_cell_rbit(ase_wheap_t h, int c)
 876         __attribute__((always_inline));
 877 static inline int
 878 ase_wheap_cell_rbit(ase_wheap_t h, int c)
 879 {
 880         int *r = ase_wheap_rbits(h);
 881         int w = sizeof(int) * 8;
 882         int cell = c / w, bit = c % w;
 883         int bit2 = 1 << bit;
 884
 885         if (r[cell] & bit2)
 886                 return 1;
 887         else
 888                 return 0;
 889 }
 890
 891 static inline int
 892 ase_wheap_cell_rbit_neg(ase_wheap_t h, int c)
 893         __attribute__((always_inline));
 894 static inline int
 895 ase_wheap_cell_rbit_neg(ase_wheap_t h, int c)
 896 {
 897         int *r = ase_wheap_rbits(h);
 898         int w = sizeof(int) * 8;
 899         int cell = c / w, bit = c % w;
 900         int bit2 = 1 << bit;
 901
 902         return r[cell] ^= bit2;
 903 }
 904
 905 static inline int
 906 ase_wheap_cell_mother(ase_wheap_t SXE_UNUSED(h), int c)
 907         __attribute__((always_inline));
 908 static inline int
 909 ase_wheap_cell_mother(ase_wheap_t SXE_UNUSED(h), int c)
 910 {
 911         return (c >> 1);
 912 }
 913
 914 static inline int
 915 ase_wheap_cell_nana(ase_wheap_t h, int c)
 916         __attribute__((always_inline));
 917 static inline int
 918 ase_wheap_cell_nana(ase_wheap_t h, int c)
 919 {
 920         /* used to use odd(c), but simpler is odd(c) := c & 1 */
 921         while ((c&1) == ase_wheap_cell_rbit(h, (c>>1)))
 922                 c = ase_wheap_cell_mother(h, c);
 923         return ase_wheap_cell_mother(h, c);
 924 }
 925
 926 static inline int
 927 ase_wheap_cell_left(ase_wheap_t h, int c)
 928         __attribute__((always_inline));
 929 static inline int
 930 ase_wheap_cell_left(ase_wheap_t h, int c)
 931 {
 932         return 2*c + ase_wheap_cell_rbit(h, c);
 933 }
 934
 935 static inline int
 936 ase_wheap_cell_right(ase_wheap_t h, int c)
 937         __attribute__((always_inline));
 938 static inline int
 939 ase_wheap_cell_right(ase_wheap_t h, int c)
 940 {
 941         return 2*c + 1 - ase_wheap_cell_rbit(h, c);
 942 }
 943
 944 \f
 945 static void
 946 _ase_yheapify_sink(ase_yheap_cell_t c)
 947 {
 948         /* iterative approach */
 949         Lisp_Object cdata = ase_yheap_cell_data(c);
 950         ase_yheap_cell_t l, r;
 951         ase_binary_relation_t rel = ase_heap_opts_po(ase_yheap_cell_father(c));
 952
 953         if (cdata == Qnull_pointer) {
 954                 return;
 955         }
 956         while ((l = ase_yheap_cell_left(c))) {
 957                 Lisp_Object ldata = 0, rdata = 0;
 958                 ase_yheap_cell_t chosen = l;
 959
 960                 if (l == NULL ||
 961                     (ldata = ase_yheap_cell_data(l)) == Qnull_pointer) {
 962                         return;
 963                 }
 964
 965                 if ((r = ase_yheap_cell_right(c)) &&
 966                     (rdata = ase_yheap_cell_data(r)) &&
 967                     ent_binrel(rel, rdata, ldata)) {
 968                         chosen = r;
 969                         ldata = rdata;
 970                 }
 971
 972                 if (ent_binrel(rel, ldata, cdata)) {
 973                         _ase_yheap_cell_swap_data(c, chosen);
 974                         c = chosen;
 975                 } else {
 976                         return;
 977                 }
 978         }
 979         return;
 980 }
 981
 982 static inline void
 983 _ase_dheapify_sink(ase_dheap_t h, int c)
 984         __attribute__((always_inline));
 985 static inline void
 986 _ase_dheapify_sink(ase_dheap_t h, int c)
 987 {
 988         /* iterative approach */
 989         size_t size = ase_dheap_size(h);
 990         Lisp_Object *d = ase_dheap_cells(h);
 991         Lisp_Object cdata = d[c];
 992         ase_binary_relation_t rel = ase_heap_opts_po(h);
 993         unsigned int l, r;
 994
 995         if (cdata == Qnull_pointer) {
 996                 return;
 997         }
 998         while ((l = ase_dheap_cell_left(c)) && l < size && d[l]) {
 999                 int chosen = l;
1000
1001                 if ((r = l+1) && r < size && d[r] &&
1002                     ent_binrel(rel, d[r], d[l])) {
1003                         chosen = r;
1004                 }
1005
1006                 if (ent_binrel(rel, d[chosen], cdata)) {
1007                         _ase_dheap_swap(h, c, chosen);
1008                         c = chosen;
1009                         continue;
1010                 }
1011                 return;
1012         }
1013         return;
1014 }
1015
1016 static void
1017 _ase_yheapify(ase_yheap_cell_t c)
1018 {
1019         Lisp_Object cdata = ase_yheap_cell_data(c);
1020         ase_yheap_cell_t l = ase_yheap_cell_left(c);
1021         ase_yheap_cell_t r = ase_yheap_cell_right(c);
1022
1023         if (cdata == Qnull_pointer || (l == NULL && r == NULL))
1024                 return;
1025
1026         if (l) {
1027                 _ase_yheapify(l);
1028         }
1029         if (r) {
1030                 _ase_yheapify(r);
1031         }
1032
1033         _ase_yheapify_sink(c);
1034 }
1035
1036 void
1037 ase_yheapify(ase_yheap_t h)
1038 {
1039         _ase_yheapify(ase_yheap_root(h));
1040         ase_yheap_heapp(h) = 1;
1041         return;
1042 }
1043
1044 static inline void
1045 _ase_dheap_sift(ase_dheap_t h, int start, int count)
1046         __attribute__((always_inline));
1047 static inline void
1048 _ase_dheap_sift(ase_dheap_t h, int start, int count)
1049 {
1050         int root = start, child;
1051         ase_binary_relation_t po = ase_heap_opts_po(h);
1052         Lisp_Object *d = ase_dheap_cells(h);
1053
1054         while ((child = ase_dheap_cell_left(root)) < count) {
1055                 if (child < count-1 &&
1056                     ent_binrel(po, d[child], d[child+1])) {
1057                         child++; /* choose the right child */
1058                 }
1059                 if (ent_binrel(po, d[root], d[child])) {
1060                         _ase_dheap_swap(h, root, child);
1061                         root = child;
1062                 } else {
1063                         return;
1064                 }
1065         }
1066         return;
1067 }
1068
1069 static inline int
1070 __ase_wheapify_sink(ase_wheap_t h, int i, int j)
1071         __attribute__((always_inline));
1072 static inline int
1073 __ase_wheapify_sink(ase_wheap_t h, int i, int j)
1074 {
1075 /* aka Merge(i, j) in Edelkamp/Wegener's paper */
1076         Lisp_Object *d = ase_wheap_cells(h);
1077         ase_binary_relation_t po = ase_heap_opts_po(h);
1078         int res = 0;
1079
1080         EMOD_ASE_DEBUG_HEAP("Merge(%d, %d)\n", i, j);
1081         if ((res = ent_binrel(po, d[j], d[i]))) {
1082                 /* swap(nana(idx), idx) */
1083                 _ase_wheap_swap(h, i, j);
1084                 /* update bit field */
1085                 ase_wheap_cell_rbit_neg(h, j);
1086         }
1087         return res;
1088 }
1089
1090 static inline void
1091 _ase_wheapify_sink(ase_wheap_t h, int idx)
1092         __attribute__((always_inline));
1093 static inline void
1094 _ase_wheapify_sink(ase_wheap_t h, int m)
1095 {
1096 /* aka MergeForest(m) in Edelkamp/Wegener's paper */
1097         int l, x = 1;
1098
1099         EMOD_ASE_DEBUG_HEAP("MergeForest(%d)\n", m);
1100         if (m <= 1)
1101                 return;
1102
1103         while ((l = ase_wheap_cell_left(h, x)) < m) {
1104                 x = l;
1105         }
1106         while (x > 0) {
1107                 /* merge(m,x) */
1108                 __ase_wheapify_sink(h, m, x);
1109                 /* move on to mother cell */
1110                 x = ase_wheap_cell_mother(h, x);
1111         }
1112         return;
1113 }
1114
1115 void
1116 _ase_wheapify(ase_wheap_t h)
1117 {
1118         int i;
1119         for (i = ase_wheap_size(h)-1; i >= 1; i--) {
1120                 __ase_wheapify_sink(h, ase_wheap_cell_nana(h, i), i);
1121         }
1122 }
1123
1124 void
1125 ase_wheap_sort(ase_wheap_t h)
1126 {
1127         int s = ase_wheap_size(h), i, j;
1128
1129         /* normally WeakHeapify is called first
1130          * howbeit, our wheaps always suffice the weak property */
1131         for (--s; s >= 2; s--) {
1132                 _ase_wheapify_sink(h, s);
1133         }
1134         /* now the i-th most extreme value is at index ase_wheap_size-i */
1135         s = (ase_wheap_size(h)+1)>>1;
1136         for (i = 1, j = ase_wheap_size(h)-1; i < s; i++, j--) {
1137                 _ase_wheap_swap(h, i, j);
1138         }
1139 }
1140
1141 void
1142 ase_dheap_sort(ase_dheap_t h)
1143 {
1144         size_t size = ase_dheap_size(h);
1145         int start = size/2 - 1, end = size-1;
1146
1147         while (start >= 0) {
1148                 _ase_dheap_sift(h, start, size);
1149                 start--;
1150         }
1151         while (end > 0) {
1152                 _ase_dheap_swap(h, end, 0);
1153                 _ase_dheap_sift(h, 0, end);
1154                 end--;
1155         }
1156         return;
1157 }
1158
1159 #if defined __GNUC__
1160 static Lisp_Object
1161 ase_add_yheap_unwind_protect(Lisp_Object unwind_obj)
1162         __attribute__((unused));
1163 #endif
1164 static Lisp_Object
1165 ase_add_yheap_unwind_protect(Lisp_Object unwind_obj)
1166 {
1167         ase_yheap_t h = get_opaque_ptr(unwind_obj);
1168         ase_heap_unlock(h);
1169         free_opaque_ptr(unwind_obj);
1170         return Qnil;
1171 }
1172
1173 void
1174 ase_add_yheap(ase_yheap_t h, Lisp_Object o, Lisp_Object colour)
1175 {
1176         ase_yheap_cell_t c, mother;
1177 #if 0
1178         int speccount = specpdl_depth();
1179 #endif
1180
1181         EMOD_ASE_DEBUG_HEAP("c:0x%08lx shall be populated...\n",
1182                             (long unsigned int)c);
1183
1184 #if 0
1185         record_unwind_protect(ase_add_yheap_unwind_protect,
1186                               make_opaque_ptr(h));
1187 #endif
1188
1189         ase_heap_lock(h);
1190         c = ase_yheap_first_free(h);
1191         if (c == NULL) {
1192                 EMOD_ASE_CRITICAL("broken heap 0x%08lx\n",
1193                                   (long unsigned int)h);
1194                 ase_heap_unlock(h);
1195                 return;
1196         }
1197
1198         ase_yheap_cell_data(c) = o;
1199         ase_yheap_cell_colour(c) = colour;
1200
1201         /* it may violate the heap property now */
1202         ase_yheap_heapp(h) = 0;
1203
1204         if (ase_yheap_cell_left(c) == NULL) {
1205                 _ase_fixup_heap_cell(h, c);
1206         }
1207         ase_yheap_first_free(h) = ase_yheap_cell_next(c);
1208         ase_yheap_size(h)++;
1209
1210         if (ase_yheap_root(h) == NULL) {
1211                 ase_yheap_root(h) = c;
1212         }
1213
1214         /* bottom-up heapify now */
1215         mother = c;
1216         while ((mother = ase_yheap_cell_mother(mother))) {
1217                 _ase_yheapify_sink(mother);
1218         }
1219         ase_heap_unlock(h);
1220         return;
1221 }
1222
1223 #if defined __GNUC__
1224 static Lisp_Object
1225 ase_add_dheap_unwind_protect(Lisp_Object unwind_obj)
1226         __attribute__((unused));
1227 #endif
1228 static Lisp_Object
1229 ase_add_dheap_unwind_protect(Lisp_Object unwind_obj)
1230 {
1231         ase_dheap_t h = get_opaque_ptr(unwind_obj);
1232         ase_heap_unlock(h);
1233         free_opaque_ptr(unwind_obj);
1234         return Qnil;
1235 }
1236
1237 void
1238 ase_add_dheap(ase_dheap_t h, Lisp_Object o, Lisp_Object colour)
1239 {
1240         int idx, mother;
1241 #if 0
1242         int speccount = specpdl_depth();
1243 #endif
1244         Lisp_Object *d, *c;
1245
1246         EMOD_ASE_DEBUG_HEAP("c:%d shall be populated...\n", idx);
1247
1248 #if 0
1249         record_unwind_protect(ase_add_dheap_unwind_protect,
1250                               make_opaque_ptr(h));
1251 #endif
1252
1253         /* lock the heap */
1254         ase_heap_lock(h);
1255         mother = idx = ase_dheap_size(h)++;
1256         d = ase_dheap_cells(h);
1257         c = ase_dheap_colours(h);
1258
1259         d[idx] = o;
1260         if (c) {
1261                 c[idx] = colour;
1262         }
1263
1264         /* it may violate the heap property now */
1265         ase_dheap_heapp(h) = 0;
1266
1267         /* bottom-up heapify now */
1268         mother = idx;
1269         while ((mother = ase_dheap_cell_mother(mother)) != -1) {
1270                 _ase_dheapify_sink(h, mother);
1271         }
1272
1273         _ase_dheap_check_resize(h);
1274         ase_heap_unlock(h);
1275         return;
1276 }
1277
1278 #if defined __GNUC__
1279 static Lisp_Object
1280 ase_add_wheap_unwind_protect(Lisp_Object unwind_obj)
1281         __attribute__((unused));
1282 #endif
1283 static Lisp_Object
1284 ase_add_wheap_unwind_protect(Lisp_Object unwind_obj)
1285 {
1286         ase_wheap_t h = get_opaque_ptr(unwind_obj);
1287         ase_heap_unlock(h);
1288         free_opaque_ptr(unwind_obj);
1289         return Qnil;
1290 }
1291
1292 void
1293 ase_add_wheap(ase_wheap_t h, Lisp_Object o, Lisp_Object colour)
1294 {
1295         int idx;
1296 #if 0
1297         int speccount = specpdl_depth();
1298 #endif
1299         Lisp_Object *d;
1300
1301         EMOD_ASE_DEBUG_HEAP("c:%d shall be populated...\n", idx);
1302
1303 #if 0
1304         record_unwind_protect(ase_add_wheap_unwind_protect,
1305                               make_opaque_ptr(h));
1306 #endif
1307
1308         /* lock the heap */
1309         ase_heap_lock(h);
1310         idx = ase_wheap_size(h)++;
1311         d = ase_wheap_cells(h);
1312
1313         d[idx] = o;
1314         if (ase_heap_opts_coloured(h)) {
1315                 ase_wheap_colours(h)[idx] = colour;
1316         }
1317
1318         /* it may violate the heap property now */
1319         ase_wheap_heapp(h) = 0;
1320
1321         /* bottom-up wheapify now */
1322         while (idx) {
1323                 int nana = ase_wheap_cell_nana(h, idx);
1324                 if (!__ase_wheapify_sink(h, nana, idx))
1325                         break;
1326                 idx = nana;
1327         }
1328
1329         _ase_wheap_check_resize(h);
1330         ase_heap_unlock(h);
1331         return;
1332 }
1333
1334 /* popping (dequeue operation) */
1335 Lisp_Object
1336 ase_pop_yheap(ase_yheap_t h)
1337 {
1338         ase_yheap_cell_t rc, c;
1339         Lisp_Object result = Qnil, swap;
1340
1341         /* lock the heap */
1342         ase_heap_lock(h);
1343         rc = ase_yheap_root(h);
1344         if (rc == NULL || ase_yheap_cell_data(rc) == Qnull_pointer) {
1345                 ase_heap_unlock(h);
1346                 return Qnil;
1347         }
1348
1349         if (!ase_heap_opts_coloured(h)) {
1350                 result = ase_yheap_cell_data(rc);
1351         } else {
1352                 result = ase_yheap_cell_colour(rc);
1353         }
1354         c = ase_yheap_cell_prev(ase_yheap_first_free(h));
1355         swap = ase_yheap_cell_data(c);
1356         ase_yheap_first_free(h) = c;
1357         ase_yheap_size(h)--;
1358
1359         ase_yheap_cell_data(rc) = swap;
1360         ase_yheap_cell_data(c) = Qnull_pointer;
1361         ase_yheap_cell_colour(c) = Qnull_pointer;
1362         _ase_yheapify_sink(rc);
1363
1364         ase_heap_unlock(h);
1365         return result;
1366 }
1367
1368 Lisp_Object
1369 ase_pop_dheap(ase_dheap_t h)
1370 {
1371         Lisp_Object *d, result;
1372         int end_idx;
1373
1374         /* lock */
1375         ase_heap_lock(h);
1376         d = ase_dheap_cells(h);
1377
1378         if (d[0] == Qnull_pointer) {
1379                 ase_heap_unlock(h);
1380                 return Qnil;
1381         }
1382
1383         /* pop off the most extreme element */
1384         if (!ase_heap_opts_coloured(h)) {
1385                 result = d[0];
1386         } else {
1387                 result = ase_dheap_colours(h)[0];
1388                 ase_dheap_colours(h)[0] = Qnull_pointer;
1389         }
1390
1391         end_idx = --ase_dheap_size(h);
1392         _ase_dheap_swap(h, 0, end_idx);
1393         d[end_idx] = Qnull_pointer;
1394
1395         /* reestablish heap property */
1396         _ase_dheapify_sink(h, 0);
1397         _ase_dheap_check_resize(h);
1398
1399         ase_heap_unlock(h);
1400         return result;
1401 }
1402
1403 Lisp_Object
1404 ase_pop_wheap(ase_wheap_t h)
1405 {
1406         Lisp_Object *d, *c, result;
1407         int end_idx;
1408
1409         /* lock */
1410         ase_heap_lock(h);
1411         d = ase_wheap_cells(h);
1412         c = ase_wheap_colours(h);
1413
1414         if (d[0] == Qnull_pointer) {
1415                 ase_heap_unlock(h);
1416                 return Qnil;
1417         }
1418
1419         /* pop off the most extreme element */
1420         if (!ase_heap_opts_coloured(h)) {
1421                 result = d[0];
1422         } else {
1423                 result = c[0];
1424         }
1425
1426         /* MergeForest(end_idx) */
1427         end_idx = --ase_wheap_size(h);
1428         _ase_wheapify_sink(h, end_idx);
1429
1430         d[0] = d[end_idx];
1431         d[end_idx] = Qnull_pointer;
1432
1433         if (ase_heap_opts_coloured(h)) {
1434                 c[0] = c[end_idx];
1435                 c[end_idx] = Qnull_pointer;
1436         }
1437
1438         /* maybe resize? */
1439         _ase_wheap_check_resize(h);
1440
1441         ase_heap_unlock(h);
1442         return result;
1443 }
1444
1445 Lisp_Object
1446 ase_yheap_top(ase_yheap_t h)
1447 {
1448         ase_yheap_cell_t rc;
1449         Lisp_Object result = Qnil;
1450
1451         /* lock the heap */
1452         ase_heap_lock(h);
1453         rc = ase_yheap_root(h);
1454         if (rc == NULL || ase_yheap_cell_data(rc) == Qnull_pointer) {
1455                 ase_heap_unlock(h);
1456                 return Qnil;
1457         }
1458
1459         /* grab the most extreme element */
1460         if (!ase_heap_opts_coloured(h)) {
1461                 result = ase_yheap_cell_data(rc);
1462         } else {
1463                 result = ase_yheap_cell_colour(rc);
1464         }
1465
1466         ase_heap_unlock(h);
1467         return result;
1468 }
1469
1470 Lisp_Object
1471 ase_dheap_top(ase_dheap_t h)
1472 {
1473         Lisp_Object *d, *c, result;
1474
1475         /* lock */
1476         ase_heap_lock(h);
1477         d = ase_dheap_cells(h);
1478         c = ase_dheap_colours(h);
1479
1480         if (d[0] == Qnull_pointer) {
1481                 ase_heap_unlock(h);
1482                 return Qnil;
1483         }
1484
1485         /* grab the most extreme element */
1486         if (!ase_heap_opts_coloured(h)) {
1487                 result = d[0];
1488         } else {
1489                 result = c[0];
1490         }
1491
1492         ase_heap_unlock(h);
1493         return result;
1494 }
1495
1496 Lisp_Object
1497 ase_wheap_top(ase_wheap_t h)
1498 {
1499         Lisp_Object *d, *c, result;
1500
1501         /* lock */
1502         ase_heap_lock(h);
1503         d = ase_wheap_cells(h);
1504         c = ase_wheap_colours(h);
1505
1506         if (d[0] == Qnull_pointer) {
1507                 ase_heap_unlock(h);
1508                 return Qnil;
1509         }
1510
1511         /* grab the most extreme element */
1512         if (!ase_heap_opts_coloured(h)) {
1513                 result = d[0];
1514         } else {
1515                 result = c[0];
1516         }
1517
1518         ase_heap_unlock(h);
1519         return result;
1520 }
1521
1522 Lisp_Object
1523 ase_yheap_top_rank(ase_yheap_t h)
1524 {
1525         ase_yheap_cell_t rc;
1526         Lisp_Object result = Qnil;
1527
1528         /* lock the heap */
1529         ase_heap_lock(h);
1530         rc = ase_yheap_root(h);
1531
1532         result = ase_yheap_cell_data(rc);
1533         ase_heap_unlock(h);
1534         if (result != Qnull_pointer) {
1535                 return result;
1536         }
1537         return Qnil;
1538 }
1539
1540 Lisp_Object
1541 ase_dheap_top_rank(ase_dheap_t h)
1542 {
1543         Lisp_Object *d, result;
1544
1545         /* lock */
1546         ase_heap_lock(h);
1547         d = ase_dheap_cells(h);
1548
1549         result = d[0];
1550         ase_heap_unlock(h);
1551
1552         if (result != Qnull_pointer) {
1553                 return result;
1554         }
1555         return Qnil;
1556 }
1557
1558 Lisp_Object
1559 ase_wheap_top_rank(ase_wheap_t h)
1560 {
1561         Lisp_Object *d, result;
1562
1563         /* lock */
1564         ase_heap_lock(h);
1565         d = ase_wheap_cells(h);
1566
1567         result = d[0];
1568         ase_heap_unlock(h);
1569
1570         if (result != Qnull_pointer) {
1571                 return result;
1572         }
1573         return Qnil;
1574 }
1575
1576 \f
1577 static inline Lisp_Object
1578 _ase_heap_to_listX(void *h, ase_heap_pop_f popfun)
1579         __attribute__((always_inline));
1580 static inline Lisp_Object
1581 _ase_heap_to_listX(void *h, ase_heap_pop_f popfun)
1582 {
1583         Lisp_Object result = Qnil, tmp, trv;
1584
1585         result = trv = Fcons(Qnil, Qnil);
1586         while (!NILP(tmp = popfun(h))) {
1587                 trv = (XCDR(trv) = Fcons(tmp, Qnil));
1588         }
1589         return XCDR(result);
1590 }
1591
1592 Lisp_Object
1593 ase_yheap_to_listX(ase_yheap_t h)
1594 {
1595         return _ase_heap_to_listX(h, (ase_heap_pop_f)ase_pop_yheap);
1596 }
1597
1598 Lisp_Object
1599 ase_dheap_to_listX(ase_dheap_t h)
1600 {
1601         return _ase_heap_to_listX(h, (ase_heap_pop_f)ase_pop_dheap);
1602 }
1603
1604 Lisp_Object
1605 ase_wheap_to_listX(ase_wheap_t h)
1606 {
1607         return _ase_heap_to_listX(h, (ase_heap_pop_f)ase_pop_wheap);
1608 }
1609
1610 Lisp_Object
1611 ase_yheap_to_list(ase_yheap_t h)
1612 {
1613         Lisp_Object res, tmp;
1614
1615         res = tmp = ase_yheap_to_listX(h);
1616         /* now add them all back to the heap */
1617         while (!NILP(tmp)) {
1618                 ase_add_yheap(h, XCAR(tmp), Qnil);
1619                 tmp = XCDR(tmp);
1620         }
1621         return res;
1622 }
1623
1624 Lisp_Object
1625 ase_dheap_to_list(ase_dheap_t h)
1626 {
1627         size_t size = ase_yheap_size(h);
1628         Lisp_Object *d = ase_dheap_cells(h);
1629         Lisp_Object result = Qnil;
1630         int i;
1631
1632         ase_dheap_sort(h);
1633         for (i = size-1; i >= 0; i--) {
1634                 result = Fcons(d[i], result);
1635         }
1636         return result;
1637 }
1638
1639 Lisp_Object
1640 ase_wheap_to_list(ase_wheap_t h)
1641 {
1642         size_t size = ase_wheap_size(h);
1643         Lisp_Object *d = ase_wheap_cells(h);
1644         Lisp_Object result = Qnil;
1645         int i;
1646
1647         ase_wheap_sort(h);
1648         for (i = size-1; i >= 0; i--) {
1649                 result = Fcons(d[i], result);
1650         }
1651         return result;
1652 }
1653
1654 static inline Lisp_Object
1655 _ase_heap_to_vectorX(void *h, ase_heap_pop_f popfun, size_t size)
1656         __attribute__((always_inline));
1657 static inline Lisp_Object
1658 _ase_heap_to_vectorX(void *h, ase_heap_pop_f popfun, size_t size)
1659 {
1660         size_t i = 0;
1661         Lisp_Object result = make_vector(size, Qnil), tmp;
1662
1663         while (!NILP(tmp = popfun(h))) {
1664                 XVECTOR_DATA(result)[i++] = tmp;
1665         }
1666         return result;
1667 }
1668
1669 Lisp_Object
1670 ase_yheap_to_vectorX(ase_yheap_t h)
1671 {
1672         size_t s = ase_yheap_size(h);
1673         return _ase_heap_to_vectorX(h, (ase_heap_pop_f)ase_pop_yheap, s);
1674 }
1675
1676 Lisp_Object
1677 ase_dheap_to_vectorX(ase_dheap_t h)
1678 {
1679         size_t s = ase_dheap_size(h);
1680         return _ase_heap_to_vectorX(h, (ase_heap_pop_f)ase_pop_dheap, s);
1681 }
1682
1683 Lisp_Object
1684 ase_wheap_to_vectorX(ase_wheap_t h)
1685 {
1686         size_t s = ase_wheap_size(h);
1687         return _ase_heap_to_vectorX(h, (ase_heap_pop_f)ase_pop_wheap, s);
1688 }
1689
1690 Lisp_Object
1691 ase_yheap_to_vector(ase_yheap_t h)
1692 {
1693         Lisp_Object res;
1694         int i;
1695
1696         res = ase_yheap_to_vectorX(h);
1697         /* now add them all back to the heap */
1698         i = XVECTOR_LENGTH(res);
1699         while (--i >= 0) {
1700                 ase_add_yheap(h, XVECTOR_DATA(res)[i], Qnil);
1701         }
1702         return res;
1703 }
1704
1705 Lisp_Object
1706 ase_dheap_to_vector(ase_dheap_t h)
1707 {
1708         size_t size = ase_dheap_size(h);
1709         Lisp_Object *d = ase_dheap_cells(h);
1710         Lisp_Object result = make_vector(size, Qnil);
1711         size_t i = 0;
1712
1713         ase_dheap_sort(h);
1714         for (i = 0; i < size; i++) {
1715                 XVECTOR_DATA(result)[i] = d[i];
1716         }
1717         return result;
1718 }
1719
1720 Lisp_Object
1721 ase_wheap_to_vector(ase_wheap_t h)
1722 {
1723         size_t size = ase_wheap_size(h);
1724         Lisp_Object *d = ase_wheap_cells(h);
1725         Lisp_Object result = make_vector(size, Qnil);
1726         size_t i = 0;
1727
1728         ase_wheap_sort(h);
1729         for (i = 0; i < size; i++) {
1730                 XVECTOR_DATA(result)[i] = d[i];
1731         }
1732         return result;
1733 }
1734
1735 static inline Lisp_Object
1736 _ase_heap_to_dllistX(void *h, ase_heap_pop_f popfun)
1737         __attribute__((always_inline));
1738 static inline Lisp_Object
1739 _ase_heap_to_dllistX(void *h, ase_heap_pop_f popfun)
1740 {
1741         dllist_t resdll = make_dllist();
1742         Lisp_Object result = Qnil, tmp;
1743
1744         while (!NILP(tmp = popfun(h))) {
1745                 dllist_append(resdll, (void*)tmp);
1746         }
1747
1748         XSETDLLIST(result, resdll);
1749         return result;
1750 }
1751
1752 Lisp_Object
1753 ase_yheap_to_dllistX(ase_yheap_t h)
1754 {
1755         return _ase_heap_to_dllistX(h, (ase_heap_pop_f)ase_pop_yheap);
1756 }
1757
1758 Lisp_Object
1759 ase_dheap_to_dllistX(ase_dheap_t h)
1760 {
1761         return _ase_heap_to_dllistX(h, (ase_heap_pop_f)ase_pop_dheap);
1762 }
1763
1764 Lisp_Object
1765 ase_wheap_to_dllistX(ase_wheap_t h)
1766 {
1767         return _ase_heap_to_dllistX(h, (ase_heap_pop_f)ase_pop_wheap);
1768 }
1769
1770 Lisp_Object
1771 ase_yheap_to_dllist(ase_yheap_t h)
1772 {
1773         Lisp_Object res;
1774
1775         res = ase_yheap_to_dllistX(h);
1776         /* now add them all back to the heap */
1777         WITH_DLLIST_TRAVERSE(
1778                 XDLLIST(res),
1779                 ase_add_yheap(h, (Lisp_Object)dllist_item, Qnil));
1780         return res;
1781 }
1782
1783 Lisp_Object
1784 ase_dheap_to_dllist(ase_dheap_t h)
1785 {
1786         size_t size = ase_dheap_size(h);
1787         Lisp_Object *d = ase_dheap_cells(h);
1788         Lisp_Object result = Qnil;
1789         dllist_t resdll = make_dllist();
1790         size_t i;
1791
1792         ase_dheap_sort(h);
1793         for (i = 0; i < size; i++) {
1794                 dllist_append(resdll, (void*)d[i]);
1795         }
1796
1797         XSETDLLIST(result, resdll);
1798         return result;
1799 }
1800
1801 Lisp_Object
1802 ase_wheap_to_dllist(ase_wheap_t h)
1803 {
1804         size_t size = ase_wheap_size(h);
1805         Lisp_Object *d = ase_wheap_cells(h);
1806         Lisp_Object result = Qnil;
1807         dllist_t resdll = make_dllist();
1808         size_t i;
1809
1810         ase_wheap_sort(h);
1811         for (i = 0; i < size; i++) {
1812                 dllist_append(resdll, (void*)d[i]);
1813         }
1814
1815         XSETDLLIST(result, resdll);
1816         return result;
1817 }
1818
1819 static inline ase_heap_kind_t
1820 ase_determine_heap_kind(Lisp_Object o)
1821         __attribute__((always_inline));
1822 static inline ase_heap_kind_t
1823 ase_determine_heap_kind(Lisp_Object o)
1824 {
1825         if (EQ(o, Qweak)) {
1826                 return ASE_HEAP_WEAK;
1827         } else if (EQ(o, Qdense)) {
1828                 return ASE_HEAP_DENSE;
1829         } else if (EQ(o, Qdynamic)) {
1830                 return ASE_HEAP_DYNAMIC;
1831         }
1832
1833         return ASE_HEAP_WEAK;
1834 }
1835
1836 \f
1837 /* ###autoload */
1838 DEFUN("ase-heap", Fase_heap, 0, MANY, 0, /*
1839 Return a new heap object.
1840
1841 Arguments: &rest keys
1842 :kind  kind of the heap, can be one of 'weak (default), 'dense, or 'dynamic
1843 :relation
1844 */
1845       (int nargs, Lisp_Object *args))
1846 {
1847         ase_heap_options_t opts = xnew(struct ase_heap_options_s);
1848         ase_heap_constr_f constrf;
1849         ase_heap_wrap_f wrapf;
1850         ase_heap_kind_t kind;
1851         int i;
1852
1853         /* standard options */
1854         ase_heap_options_po(opts) = ASE_BINARY_REL_GREATERP;
1855         ase_heap_options_pof(opts) = NULL;
1856         kind = ase_heap_options_kind(opts) =
1857                 ase_determine_heap_kind(Qase_heap_default_kind);
1858         ase_heap_options_min_size(opts) = ASE_HEAP_MIN_SIZE;
1859         ase_heap_options_coloured(opts) = 0;
1860
1861         for (i = 0; i < nargs-1; i++) {
1862                 if (EQ(args[i], Q_kind)) {
1863                         kind = ase_heap_options_kind(opts) =
1864                                 ase_determine_heap_kind(args[++i]);
1865                 }
1866                 if (EQ(args[i], Q_relation)) {
1867                 }
1868                 if (EQ(args[i], Q_coloured)) {
1869                         if (!NILP(args[++i]))
1870                                 ase_heap_options_coloured(opts) = 1;
1871                 }
1872         }
1873
1874         constrf = ase_heap_ops[kind].constrf;
1875         wrapf = ase_heap_ops[kind].wrapf;
1876         return wrapf(constrf(opts));
1877 }
1878
1879 DEFUN("ase-add-heap", Fase_add_heap, 2, 3, 0, /*
1880 Add OBJECT to HEAP and (optionally) COLOUR it.
1881 */
1882       (heap, object, colour))
1883 {
1884         void *h = NULL;
1885         ase_heap_add_f addfun = NULL;
1886
1887         CHECK_ASE_HEAP(heap);
1888
1889         if (ASE_WHEAPP(heap)) {
1890                 addfun = ase_heap_ops[ASE_HEAP_WEAK].addf;
1891                 h = XASE_WHEAP(heap);
1892         } else if (ASE_DHEAPP(heap)) {
1893                 addfun = ase_heap_ops[ASE_HEAP_DENSE].addf;
1894                 h = XASE_DHEAP(heap);
1895         } else if (ASE_YHEAPP(heap)) {
1896                 addfun = ase_heap_ops[ASE_HEAP_DYNAMIC].addf;
1897                 h = XASE_YHEAP(heap);
1898         }
1899         addfun(h, object, colour);
1900         return heap;
1901 }
1902
1903 DEFUN("ase-pop-heap", Fase_pop_heap, 1, 1, 0, /*
1904 Pop off and return the most extreme element of HEAP.
1905 */
1906       (heap))
1907 {
1908         void *h = NULL;
1909         ase_heap_pop_f popfun = NULL;
1910
1911         CHECK_ASE_HEAP(heap);
1912
1913         if (ASE_WHEAPP(heap)) {
1914                 popfun = ase_heap_ops[ASE_HEAP_WEAK].popf;
1915                 h = XASE_WHEAP(heap);
1916         } else if (ASE_DHEAPP(heap)) {
1917                 popfun = ase_heap_ops[ASE_HEAP_DENSE].popf;
1918                 h = XASE_DHEAP(heap);
1919         } else if (ASE_YHEAPP(heap)) {
1920                 popfun = ase_heap_ops[ASE_HEAP_DYNAMIC].popf;
1921                 h = XASE_YHEAP(heap);
1922         }
1923         return popfun(h);
1924 }
1925
1926 \f
1927 /* convenience funs */
1928 DEFUN("ase-heap-size", Fase_heap_size, 1, 1, 0, /*
1929 Return the number of elements inside HEAP.
1930 */
1931       (heap))
1932 {
1933         CHECK_ASE_HEAP(heap);
1934
1935         if (ASE_WHEAPP(heap)) {
1936                 return make_int(ase_wheap_size(XASE_WHEAP(heap)));
1937         } else if (ASE_DHEAPP(heap)) {
1938                 return make_int(ase_dheap_size(XASE_DHEAP(heap)));
1939         } else if (ASE_YHEAPP(heap)) {
1940                 return make_int(ase_yheap_size(XASE_YHEAP(heap)));
1941         }
1942         return Qnull_pointer;
1943 }
1944
1945 DEFUN("ase-heap-top", Fase_heap_top, 1, 1, 0, /*
1946 Return the topmost element of HEAP.
1947 */
1948       (heap))
1949 {
1950         CHECK_ASE_HEAP(heap);
1951
1952         if (ASE_WHEAPP(heap)) {
1953                 return ase_wheap_top(XASE_WHEAP(heap));
1954         } else if (ASE_DHEAPP(heap)) {
1955                 return ase_dheap_top(XASE_DHEAP(heap));
1956         } else if (ASE_YHEAPP(heap)) {
1957                 return ase_yheap_top(XASE_YHEAP(heap));
1958         }
1959         return Qnull_pointer;
1960 }
1961
1962 DEFUN("ase-heap-top-rank", Fase_heap_top_rank, 1, 1, 0, /*
1963 Return the rank (priority) of the topmost element of HEAP.
1964 */
1965       (heap))
1966 {
1967         CHECK_ASE_HEAP(heap);
1968
1969         if (ASE_WHEAPP(heap)) {
1970                 return ase_wheap_top_rank(XASE_WHEAP(heap));
1971         } else if (ASE_DHEAPP(heap)) {
1972                 return ase_dheap_top_rank(XASE_DHEAP(heap));
1973         } else if (ASE_YHEAPP(heap)) {
1974                 return ase_yheap_top_rank(XASE_YHEAP(heap));
1975         }
1976         return Qnull_pointer;
1977 }
1978
1979 DEFUN("ase-heap-to-list", Fase_heap_to_list, 1, 1, 0, /*
1980 Return a (sorted) list with the elements of HEAP.
1981 HEAP is kept alive.  See also `ase-heap-to-list*'
1982 */
1983       (heap))
1984 {
1985         CHECK_ASE_HEAP(heap);
1986         if (ASE_WHEAPP(heap)) {
1987                 return ase_wheap_to_list(XASE_WHEAP(heap));
1988         } else if (ASE_DHEAPP(heap)) {
1989                 return ase_dheap_to_list(XASE_DHEAP(heap));
1990         } else if (ASE_YHEAPP(heap)) {
1991                 return ase_yheap_to_list(XASE_YHEAP(heap));
1992         }
1993         return Qnull_pointer;
1994 }
1995
1996 DEFUN("ase-heap-to-list*", Fase_heap_to_listX, 1, 1, 0, /*
1997 Return a (sorted) list with the elements of HEAP.
1998 HEAP is destroyed by side-effect, each element from HEAP is
1999 popped off and consed to the result list.
2000 */
2001       (heap))
2002 {
2003         CHECK_ASE_HEAP(heap);
2004         if (ASE_WHEAPP(heap)) {
2005                 return ase_wheap_to_listX(XASE_WHEAP(heap));
2006         } else if (ASE_DHEAPP(heap)) {
2007                 return ase_dheap_to_listX(XASE_DHEAP(heap));
2008         } else if (ASE_YHEAPP(heap)) {
2009                 return ase_yheap_to_listX(XASE_YHEAP(heap));
2010         }
2011         return Qnull_pointer;
2012 }
2013
2014 DEFUN("ase-heap-to-vector", Fase_heap_to_vector, 1, 1, 0, /*
2015 Return a (sorted) vector with the elements of HEAP.
2016 HEAP is kept alive hereby.  See also `ase-heap-to-vector*'.
2017 */
2018       (heap))
2019 {
2020         CHECK_ASE_HEAP(heap);
2021         if (ASE_WHEAPP(heap)) {
2022                 return ase_wheap_to_vector(XASE_WHEAP(heap));
2023         } else if (ASE_DHEAPP(heap)) {
2024                 return ase_dheap_to_vector(XASE_DHEAP(heap));
2025         } else if (ASE_YHEAPP(heap)) {
2026                 return ase_yheap_to_vector(XASE_YHEAP(heap));
2027         }
2028         return Qnull_pointer;
2029 }
2030
2031 DEFUN("ase-heap-to-vector*", Fase_heap_to_vectorX, 1, 1, 0, /*
2032 Return a (sorted) vector with the elements of HEAP.
2033 HEAP is destroyed by side-effect, each element from HEAP is
2034 popped off and written into the result vector.
2035 */
2036       (heap))
2037 {
2038         CHECK_ASE_HEAP(heap);
2039         if (ASE_WHEAPP(heap)) {
2040                 return ase_wheap_to_vectorX(XASE_WHEAP(heap));
2041         } else if (ASE_DHEAPP(heap)) {
2042                 return ase_dheap_to_vectorX(XASE_DHEAP(heap));
2043         } else if (ASE_YHEAPP(heap)) {
2044                 return ase_yheap_to_vectorX(XASE_YHEAP(heap));
2045         }
2046         return Qnull_pointer;
2047 }
2048
2049 DEFUN("ase-heap-to-dllist", Fase_heap_to_dllist, 1, 1, 0, /*
2050 Return a (sorted) list with the elements of HEAP.
2051 HEAP is kept intact.  See also `ase-heap-to-dllist*'.
2052 */
2053       (heap))
2054 {
2055         CHECK_ASE_HEAP(heap);
2056         if (ASE_WHEAPP(heap)) {
2057                 return ase_wheap_to_dllist(XASE_WHEAP(heap));
2058         } else if (ASE_DHEAPP(heap)) {
2059                 return ase_dheap_to_dllist(XASE_DHEAP(heap));
2060         } else if (ASE_YHEAPP(heap)) {
2061                 return ase_yheap_to_dllist(XASE_YHEAP(heap));
2062         }
2063         return Qnull_pointer;
2064 }
2065
2066 DEFUN("ase-heap-to-dllist*", Fase_heap_to_dllistX, 1, 1, 0, /*
2067 Return a (sorted) list with the elements of HEAP.
2068 HEAP is destroyed by side-effect, each element from HEAP is
2069 popped off and appended to the result dllist.
2070 */
2071       (heap))
2072 {
2073         CHECK_ASE_HEAP(heap);
2074         if (ASE_WHEAPP(heap)) {
2075                 return ase_wheap_to_dllistX(XASE_WHEAP(heap));
2076         } else if (ASE_DHEAPP(heap)) {
2077                 return ase_dheap_to_dllistX(XASE_DHEAP(heap));
2078         } else if (ASE_YHEAPP(heap)) {
2079                 return ase_yheap_to_dllistX(XASE_YHEAP(heap));
2080         }
2081         return Qnull_pointer;
2082 }
2083
2084 \f
2085 /* initialiser code */
2086 #define EMODNAME        ase_heap
2087
2088 void
2089 EMOD_PUBINIT(void)
2090 {
2091         DEFSUBR(Fase_heap);
2092         DEFSUBR(Fase_add_heap);
2093         DEFSUBR(Fase_pop_heap);
2094
2095         DEFSUBR(Fase_heap_to_list);
2096         DEFSUBR(Fase_heap_to_listX);
2097         DEFSUBR(Fase_heap_to_vector);
2098         DEFSUBR(Fase_heap_to_vectorX);
2099         DEFSUBR(Fase_heap_to_dllist);
2100         DEFSUBR(Fase_heap_to_dllistX);
2101
2102         DEFSUBR(Fase_heap_size);
2103         DEFSUBR(Fase_heap_top);
2104         DEFSUBR(Fase_heap_top_rank);
2105
2106         DEFASETYPE_WITH_OPS(Qase_heap, "ase:heap");
2107         defsymbol(&Qase_heapp, "ase:heapp");
2108         defsymbol(&Qase_yheap, "ase:yheap");
2109         defsymbol(&Qase_yheapp, "ase:yheapp");
2110         defsymbol(&Qase_dheap, "ase:dheap");
2111         defsymbol(&Qase_dheapp, "ase:dheapp");
2112         defsymbol(&Qase_wheap, "ase:wheap");
2113         defsymbol(&Qase_wheapp, "ase:wheapp");
2114
2115         DEFSYMBOL(Qweak);
2116         DEFSYMBOL(Qdense);
2117         DEFSYMBOL(Qdynamic);
2118
2119         DEFKEYWORD(Q_kind);
2120         DEFKEYWORD(Q_relation);
2121         DEFKEYWORD(Q_coloured);
2122
2123         Fprovide(intern("ase-heap"));
2124
2125         DEFVAR_LISP("ase:heap-default-kind", &Qase_heap_default_kind /*
2126 *Default kind of newly created heaps.
2127
2128 Default: 'weak
2129                                                                      */);
2130         Qase_heap_default_kind = Qweak;
2131 }
2132
2133 void
2134 EMOD_PUBREINIT(void)
2135 {
2136 }
2137
2138 void
2139 EMOD_PUBDEINIT(void)
2140 {
2141         Frevoke(intern("ase-heap"));
2142 }
2143
2144
2145 /* ase-heap.c ends here */