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