array.c

   1 /*
   2  * array.c - routines for associative arrays.
   3  */
   4
   5 /*
   6  * Copyright (C) 1986, 1988, 1989, 1991-2011 the Free Software Foundation, Inc.
   7  *
   8  * This file is part of GAWK, the GNU implementation of the
   9  * AWK Programming Language.
  10  *
  11  * GAWK is free software; you can redistribute it and/or modify
  12  * it under the terms of the GNU General Public License as published by
  13  * the Free Software Foundation; either version 3 of the License, or
  14  * (at your option) any later version.
  15  *
  16  * GAWK is distributed in the hope that it will be useful,
  17  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  18  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19  * GNU General Public License for more details.
  20  *
  21  * You should have received a copy of the GNU General Public License
  22  * along with this program; if not, write to the Free Software
  23  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA
  24  */
  25
  26 #include "awk.h"
  27
  28 /*
  29  * Tree walks (``for (iggy in foo)'') and array deletions use expensive
  30  * linear searching.  So what we do is start out with small arrays and
  31  * grow them as needed, so that our arrays are hopefully small enough,
  32  * most of the time, that they're pretty full and we're not looking at
  33  * wasted space.
  34  *
  35  * The decision is made to grow the array if the average chain length is
  36  * ``too big''. This is defined as the total number of entries in the table
  37  * divided by the size of the array being greater than some constant.
  38  *
  39  * We make the constant a variable, so that it can be tweaked
  40  * via environment variable.
  41  */
  42
  43 static size_t AVG_CHAIN_MAX = 2;        /* Modern machines are bigger, reduce this from 10. */
  44
  45 static size_t SUBSEPlen;
  46 static char *SUBSEP;
  47
  48 static NODE *assoc_find(NODE *symbol, NODE *subs, unsigned long hash1, NODE **last);
  49 static void grow_table(NODE *symbol);
  50
  51 static unsigned long gst_hash_string(const char *str, size_t len, unsigned long hsize, size_t *code);
  52 static unsigned long scramble(unsigned long x);
  53 static unsigned long awk_hash(const char *s, size_t len, unsigned long hsize, size_t *code);
  54
  55 unsigned long (*hash)(const char *s, size_t len, unsigned long hsize, size_t *code) = awk_hash;
  56
  57 /* qsort comparison function */
  58 static int sort_up_index_string(const void *, const void *);
  59 static int sort_down_index_string(const void *, const void *);
  60 static int sort_up_index_number(const void *, const void *);
  61 static int sort_down_index_number(const void *, const void *);
  62 static int sort_up_value_string(const void *, const void *);
  63 static int sort_down_value_string(const void *, const void *);
  64 static int sort_up_value_number(const void *, const void *);
  65 static int sort_down_value_number(const void *, const void *);
  66 static int sort_up_value_type(const void *, const void *);
  67 static int sort_down_value_type(const void *, const void *);
  68
  69 /* array_init --- check relevant environment variables */
  70
  71 void
  72 array_init()
  73 {
  74         const char *val;
  75         char *endptr;
  76         size_t newval;
  77
  78         if ((val = getenv("AVG_CHAIN_MAX")) != NULL && isdigit((unsigned char) *val)) {
  79                 newval = strtoul(val, & endptr, 10);
  80                 if (endptr != val && newval > 0)
  81                         AVG_CHAIN_MAX = newval;
  82         }
  83
  84         if ((val = getenv("AWK_HASH")) != NULL && strcmp(val, "gst") == 0)
  85                 hash = gst_hash_string;
  86 }
  87
  88 /* make_aname --- construct a 'vname' for a (sub)array */
  89
  90 static char *
  91 make_aname(const NODE *symbol)
  92 {
  93         static char *aname = NULL;
  94         static size_t alen;
  95         static size_t max_alen;
  96 #define SLEN 256
  97
  98         if (symbol->parent_array != NULL) {
  99                 size_t slen;
 100
 101                 (void) make_aname(symbol->parent_array);
 102                 slen = strlen(symbol->vname);   /* subscript in parent array */
 103                 if (alen + slen + 4 > max_alen) {               /* sizeof("[\"\"]") = 4 */
 104                         max_alen = alen + slen + 4 + SLEN;
 105                         erealloc(aname, char *, (max_alen + 1) * sizeof(char *), "make_aname");
 106                 }
 107                 alen += sprintf(aname + alen, "[\"%s\"]", symbol->vname);
 108         } else {
 109                 alen = strlen(symbol->vname);
 110                 if (aname == NULL) {
 111                         max_alen = alen + SLEN;
 112                         emalloc(aname, char *, (max_alen + 1) * sizeof(char *), "make_aname");
 113                 } else if (alen > max_alen) {
 114                         max_alen = alen + SLEN;
 115                         erealloc(aname, char *, (max_alen + 1) * sizeof(char *), "make_aname");
 116                 }
 117                 memcpy(aname, symbol->vname, alen + 1);
 118         }
 119         return aname;
 120 #undef SLEN
 121 }
 122
 123 /*
 124  * array_vname --- print the name of the array
 125  *
 126  * Returns a pointer to a statically maintained dynamically allocated string.
 127  * It's appropriate for printing the name once; if the caller wants
 128  * to save it, they have to make a copy.
 129  */
 130
 131 char *
 132 array_vname(const NODE *symbol)
 133 {
 134         static char *message = NULL;
 135         static size_t msglen = 0;
 136         char *s;
 137         size_t len;
 138         int n;
 139         const NODE *save_symbol = symbol;
 140         const char *from = _("from %s");
 141         const char *aname;
 142
 143         if (symbol->type != Node_array_ref
 144                         || symbol->orig_array->type != Node_var_array
 145         ) {
 146                 if (symbol->type != Node_var_array || symbol->parent_array == NULL)
 147                         return symbol->vname;
 148                 return make_aname(symbol);
 149         }
 150
 151         /* First, we have to compute the length of the string: */
 152
 153         len = 2; /* " (" */
 154         n = 0;
 155         while (symbol->type == Node_array_ref) {
 156                 len += strlen(symbol->vname);
 157                 n++;
 158                 symbol = symbol->prev_array;
 159         }
 160
 161         /* Get the (sub)array name */
 162         if (symbol->parent_array == NULL)
 163                 aname = symbol->vname;
 164         else
 165                 aname = make_aname(symbol);
 166         len += strlen(aname);
 167
 168         /*
 169          * Each node contributes by strlen(from) minus the length
 170          * of "%s" in the translation (which is at least 2)
 171          * plus 2 for ", " or ")\0"; this adds up to strlen(from).
 172          */
 173         len += n * strlen(from);
 174
 175         /* (Re)allocate memory: */
 176         if (message == NULL) {
 177                 emalloc(message, char *, len, "array_vname");
 178                 msglen = len;
 179         } else if (len > msglen) {
 180                 erealloc(message, char *, len, "array_vname");
 181                 msglen = len;
 182         } /* else
 183                 current buffer can hold new name */
 184
 185         /* We're ready to print: */
 186         symbol = save_symbol;
 187         s = message;
 188         /*
 189          * Ancient systems have sprintf() returning char *, not int.
 190          * If you have one of those, use sprintf(..); s += strlen(s) instead.
 191          */
 192
 193         s += sprintf(s, "%s (", symbol->vname);
 194         for (;;) {
 195                 symbol = symbol->prev_array;
 196                 if (symbol->type != Node_array_ref)
 197                         break;
 198                 s += sprintf(s, from, symbol->vname);
 199                 s += sprintf(s, ", ");
 200         }
 201         s += sprintf(s, from, aname);
 202         strcpy(s, ")");
 203
 204         return message;
 205 }
 206
 207
 208 /*
 209  *  get_array --- proceed to the actual Node_var_array,
 210  *      change Node_var_new to an array.
 211  *      If canfatal and type isn't good, die fatally,
 212  *      otherwise return the final actual value.
 213  */
 214
 215 NODE *
 216 get_array(NODE *symbol, int canfatal)
 217 {
 218         NODE *save_symbol = symbol;
 219         int isparam = FALSE;
 220
 221         if (symbol->type == Node_param_list && (symbol->flags & FUNC) == 0) {
 222                 save_symbol = symbol = GET_PARAM(symbol->param_cnt);
 223                 isparam = TRUE;
 224                 if (symbol->type == Node_array_ref)
 225                         symbol = symbol->orig_array;
 226         }
 227
 228         switch (symbol->type) {
 229         case Node_var_new:
 230                 symbol->type = Node_var_array;
 231                 symbol->var_array = NULL;
 232                 symbol->parent_array = NULL;    /* main array has no parent */
 233                 /* fall through */
 234         case Node_var_array:
 235                 break;
 236
 237         case Node_array_ref:
 238         case Node_param_list:
 239                 if ((symbol->flags & FUNC) == 0)
 240                         cant_happen();
 241                 /* else
 242                         fall through */
 243
 244         default:
 245                 /* notably Node_var but catches also e.g. FS[1] = "x" */
 246                 if (canfatal) {
 247                         if (symbol->type == Node_val)
 248                                 fatal(_("attempt to use a scalar value as array"));
 249
 250                         if ((symbol->flags & FUNC) != 0)
 251                                 fatal(_("attempt to use function `%s' as an array"),
 252                                                                 save_symbol->vname);
 253                         else if (isparam)
 254                                 fatal(_("attempt to use scalar parameter `%s' as an array"),
 255                                                                 save_symbol->vname);
 256                         else
 257                                 fatal(_("attempt to use scalar `%s' as an array"),
 258                                                                 save_symbol->vname);
 259                 } else
 260                         break;
 261         }
 262
 263         return symbol;
 264 }
 265
 266
 267 /* set_SUBSEP --- update SUBSEP related variables when SUBSEP assigned to */
 268
 269 void
 270 set_SUBSEP()
 271 {
 272         SUBSEP = force_string(SUBSEP_node->var_value)->stptr;
 273         SUBSEPlen = SUBSEP_node->var_value->stlen;
 274 }
 275
 276 /* concat_exp --- concatenate expression list into a single string */
 277
 278 NODE *
 279 concat_exp(int nargs, int do_subsep)
 280 {
 281         /* do_subsep is false for Node-concat */
 282         NODE *r;
 283         char *str;
 284         char *s;
 285         size_t len;
 286         size_t subseplen = 0;
 287         int i;
 288         extern NODE **args_array;
 289
 290         if (nargs == 1)
 291                 return POP_STRING();
 292
 293         if (do_subsep)
 294                 subseplen = SUBSEPlen;
 295
 296         len = 0;
 297         for (i = 1; i <= nargs; i++) {
 298                 r = POP();
 299                 if (r->type == Node_var_array) {
 300                         while (--i > 0)
 301                                 DEREF(args_array[i]);   /* avoid memory leak */
 302                         fatal(_("attempt to use array `%s' in a scalar context"), array_vname(r));
 303                 }
 304                 args_array[i] = force_string(r);
 305                 len += r->stlen;
 306         }
 307         len += (nargs - 1) * subseplen;
 308
 309         emalloc(str, char *, len + 2, "concat_exp");
 310
 311         r = args_array[nargs];
 312         memcpy(str, r->stptr, r->stlen);
 313         s = str + r->stlen;
 314         DEREF(r);
 315         for (i = nargs - 1; i > 0; i--) {
 316                 if (subseplen == 1)
 317                         *s++ = *SUBSEP;
 318                 else if (subseplen > 0) {
 319                         memcpy(s, SUBSEP, subseplen);
 320                         s += subseplen;
 321                 }
 322                 r = args_array[i];
 323                 memcpy(s, r->stptr, r->stlen);
 324                 s += r->stlen;
 325                 DEREF(r);
 326         }
 327
 328         return make_str_node(str, len, ALREADY_MALLOCED);
 329 }
 330
 331
 332 /* assoc_clear --- flush all the values in symbol[] */
 333
 334 void
 335 assoc_clear(NODE *symbol)
 336 {
 337         long i;
 338         NODE *bucket, *next;
 339
 340         if (symbol->var_array == NULL)
 341                 return;
 342
 343         for (i = 0; i < symbol->array_size; i++) {
 344                 for (bucket = symbol->var_array[i]; bucket != NULL; bucket = next) {
 345                         next = bucket->ahnext;
 346                         if (bucket->ahvalue->type == Node_var_array) {
 347                                 NODE *r = bucket->ahvalue;
 348                                 assoc_clear(r);         /* recursively clear all sub-arrays */
 349                                 efree(r->vname);
 350                                 freenode(r);
 351                         } else
 352                                 unref(bucket->ahvalue);
 353
 354                         unref(bucket);  /* unref() will free the ahname_str */
 355                 }
 356                 symbol->var_array[i] = NULL;
 357         }
 358         efree(symbol->var_array);
 359         symbol->var_array = NULL;
 360         symbol->array_size = symbol->table_size = 0;
 361         symbol->flags &= ~ARRAYMAXED;
 362 }
 363
 364 /* awk_hash --- calculate the hash function of the string in subs */
 365
 366 static unsigned long
 367 awk_hash(const char *s, size_t len, unsigned long hsize, size_t *code)
 368 {
 369         unsigned long h = 0;
 370         unsigned long htmp;
 371
 372         /*
 373          * Ozan Yigit's original sdbm hash, copied from Margo Seltzers
 374          * db package.
 375          *
 376          * This is INCREDIBLY ugly, but fast.  We break the string up into
 377          * 8 byte units.  On the first time through the loop we get the
 378          * "leftover bytes" (strlen % 8).  On every other iteration, we
 379          * perform 8 HASHC's so we handle all 8 bytes.  Essentially, this
 380          * saves us 7 cmp & branch instructions.  If this routine is
 381          * heavily used enough, it's worth the ugly coding.
 382          */
 383
 384         /*
 385          * Even more speed:
 386          * #define HASHC   h = *s++ + 65599 * h
 387          * Because 65599 = pow(2, 6) + pow(2, 16) - 1 we multiply by shifts
 388          *
 389          * 4/2011: Force the results to 32 bits, to get the same
 390          * result on both 32- and 64-bit systems. This may be a
 391          * bad idea.
 392          */
 393 #define HASHC   htmp = (h << 6);  \
 394                 h = *s++ + htmp + (htmp << 10) - h ; \
 395                 htmp &= 0xFFFFFFFF; \
 396                 h &= 0xFFFFFFFF
 397
 398         h = 0;
 399
 400         /* "Duff's Device" */
 401         if (len > 0) {
 402                 size_t loop = (len + 8 - 1) >> 3;
 403
 404                 switch (len & (8 - 1)) {
 405                 case 0:
 406                         do {    /* All fall throughs */
 407                                 HASHC;
 408                 case 7:         HASHC;
 409                 case 6:         HASHC;
 410                 case 5:         HASHC;
 411                 case 4:         HASHC;
 412                 case 3:         HASHC;
 413                 case 2:         HASHC;
 414                 case 1:         HASHC;
 415                         } while (--loop);
 416                 }
 417         }
 418
 419         if (code != NULL)
 420                 *code = h;
 421
 422         if (h >= hsize)
 423                 h %= hsize;
 424         return h;
 425 }
 426
 427 /* assoc_find --- locate symbol[subs] */
 428
 429 static NODE *                           /* NULL if not found */
 430 assoc_find(NODE *symbol, NODE *subs, unsigned long hash1, NODE **last)
 431 {
 432         NODE *bucket, *prev;
 433         const char *s1_str;
 434         size_t s1_len;
 435         NODE *s2;
 436
 437         for (prev = NULL, bucket = symbol->var_array[hash1]; bucket != NULL;
 438                         prev = bucket, bucket = bucket->ahnext) {
 439                 /*
 440                  * This used to use cmp_nodes() here.  That's wrong.
 441                  * Array indices are strings; compare as such, always!
 442                  */
 443                 s1_str = bucket->ahname_str;
 444                 s1_len = bucket->ahname_len;
 445                 s2 = subs;
 446
 447                 if (s1_len == s2->stlen) {
 448                         if (s1_len == 0         /* "" is a valid index */
 449                             || memcmp(s1_str, s2->stptr, s1_len) == 0)
 450                                 break;
 451                 }
 452         }
 453         if (last != NULL)
 454                 *last = prev;
 455         return bucket;
 456 }
 457
 458 /* in_array --- test whether the array element symbol[subs] exists or not,
 459  *              return pointer to value if it does.
 460  */
 461
 462 NODE *
 463 in_array(NODE *symbol, NODE *subs)
 464 {
 465         unsigned long hash1;
 466         NODE *ret;
 467
 468         assert(symbol->type == Node_var_array);
 469
 470         if (symbol->var_array == NULL)
 471                 return NULL;
 472
 473         hash1 = hash(subs->stptr, subs->stlen, (unsigned long) symbol->array_size, NULL);
 474         ret = assoc_find(symbol, subs, hash1, NULL);
 475         return (ret ? ret->ahvalue : NULL);
 476 }
 477
 478 /*
 479  * assoc_lookup:
 480  * Find SYMBOL[SUBS] in the assoc array.  Install it with value "" if it
 481  * isn't there. Returns a pointer ala get_lhs to where its value is stored.
 482  *
 483  * SYMBOL is the address of the node (or other pointer) being dereferenced.
 484  * SUBS is a number or string used as the subscript.
 485  */
 486
 487 NODE **
 488 assoc_lookup(NODE *symbol, NODE *subs, int reference)
 489 {
 490         unsigned long hash1;
 491         NODE *bucket;
 492         size_t code;
 493
 494         assert(symbol->type == Node_var_array);
 495
 496         (void) force_string(subs);
 497
 498         if (symbol->var_array == NULL) {
 499                 symbol->array_size = symbol->table_size = 0;    /* sanity */
 500                 symbol->flags &= ~ARRAYMAXED;
 501                 grow_table(symbol);
 502                 hash1 = hash(subs->stptr, subs->stlen,
 503                                 (unsigned long) symbol->array_size, & code);
 504         } else {
 505                 hash1 = hash(subs->stptr, subs->stlen,
 506                                 (unsigned long) symbol->array_size, & code);
 507                 bucket = assoc_find(symbol, subs, hash1, NULL);
 508                 if (bucket != NULL)
 509                         return &(bucket->ahvalue);
 510         }
 511
 512         if (do_lint && reference) {
 513                 lintwarn(_("reference to uninitialized element `%s[\"%.*s\"]'"),
 514                       array_vname(symbol), (int)subs->stlen, subs->stptr);
 515         }
 516
 517         /* It's not there, install it. */
 518         if (do_lint && subs->stlen == 0)
 519                 lintwarn(_("subscript of array `%s' is null string"),
 520                         array_vname(symbol));
 521
 522         /* first see if we would need to grow the array, before installing */
 523         symbol->table_size++;
 524         if ((symbol->flags & ARRAYMAXED) == 0
 525             && (symbol->table_size / symbol->array_size) > AVG_CHAIN_MAX) {
 526                 grow_table(symbol);
 527                 /* have to recompute hash value for new size */
 528                 hash1 = code % (unsigned long) symbol->array_size;
 529         }
 530
 531         getnode(bucket);
 532         bucket->type = Node_ahash;
 533
 534         /*
 535          * Freeze this string value --- it must never
 536          * change, no matter what happens to the value
 537          * that created it or to CONVFMT, etc.
 538          *
 539          * One day: Use an atom table to track array indices,
 540          * and avoid the extra memory overhead.
 541          */
 542         bucket->flags |= MALLOC;
 543         bucket->ahname_ref = 1;
 544
 545         emalloc(bucket->ahname_str, char *, subs->stlen + 2, "assoc_lookup");
 546         bucket->ahname_len = subs->stlen;
 547         memcpy(bucket->ahname_str, subs->stptr, subs->stlen);
 548         bucket->ahname_str[bucket->ahname_len] = '\0';
 549         bucket->ahvalue = Nnull_string;
 550
 551         bucket->ahnext = symbol->var_array[hash1];
 552         bucket->ahcode = code;
 553
 554         /*
 555          * Set the numeric value for the index if it's  available. Useful
 556          * for numeric sorting by index.  Do this only if the numeric
 557          * value is available, instead of all the time, since doing it
 558          * all the time is a big performance hit for something that may
 559          * never be used.
 560          */
 561         if ((subs->flags & NUMCUR) != 0) {
 562                 bucket->ahname_num = subs->numbr;
 563                 bucket->flags |= NUMIND;
 564         }
 565
 566         /* hook it into the symbol table */
 567         symbol->var_array[hash1] = bucket;
 568         return &(bucket->ahvalue);
 569 }
 570
 571
 572 /* adjust_fcall_stack: remove subarray(s) of symbol[] from
 573  *      function call stack.
 574  */
 575
 576 static void
 577 adjust_fcall_stack(NODE *symbol, int nsubs)
 578 {
 579         NODE *func, *r, *n;
 580         NODE **sp;
 581         int pcount;
 582
 583         /*
 584          * Solve the nasty problem of disappearing subarray arguments:
 585          *
 586          *  function f(c, d) { delete c; .. use non-existent array d .. }
 587          *  BEGIN { a[0][0] = 1; f(a, a[0]); .. }
 588          *
 589          * The fix is to convert 'd' to a local empty array; This has
 590          * to be done before clearing the parent array to avoid referring to
 591          * already free-ed memory.
 592          *
 593          * Similar situations exist for builtins accepting more than
 594          * one array argument: split, patsplit, asort and asorti. For example:
 595          *
 596          *  BEGIN { a[0][0] = 1; split("abc", a, "", a[0]) }
 597          *
 598          * These cases do not involve the function call stack, and are
 599          * handled individually in their respective routines.
 600          */
 601
 602         func = frame_ptr->func_node;
 603         if (func == NULL)       /* in main */
 604                 return;
 605         pcount = func->lnode->param_cnt;
 606         sp = frame_ptr->stack;
 607
 608         for (; pcount > 0; pcount--) {
 609                 r = *sp++;
 610                 if (r->type != Node_array_ref
 611                                 || r->orig_array->type != Node_var_array)
 612                         continue;
 613                 n = r->orig_array;
 614
 615                 /* Case 1 */
 616                 if (n == symbol
 617                         && symbol->parent_array != NULL
 618                         && nsubs > 0
 619                 ) {
 620                         /* 'symbol' is a subarray, and 'r' is the same subarray:
 621                          *
 622                          *   function f(c, d) { delete c[0]; .. }
 623                          *   BEGIN { a[0][0] = 1; f(a, a[0]); .. }
 624                          *
 625                          * But excludes cases like (nsubs = 0):
 626                          *
 627                          *   function f(c, d) { delete c; ..}
 628                          *   BEGIN { a[0][0] = 1; f(a[0], a[0]); ...}
 629                          */
 630                         char *save;
 631 local_array:
 632                         save = r->vname;
 633                         memset(r, '\0', sizeof(NODE));
 634                         r->vname = save;
 635                         r->type = Node_var_array;
 636                         continue;
 637                 }
 638
 639                 /* Case 2 */
 640                 for (n = n->parent_array; n != NULL; n = n->parent_array) {
 641                         assert(n->type == Node_var_array);
 642                         if (n == symbol) {
 643                                 /* 'r' is a subarray of 'symbol':
 644                                  *
 645                                  *    function f(c, d) { delete c; .. use d as array .. }
 646                                  *    BEGIN { a[0][0] = 1; f(a, a[0]); .. }
 647                                  *      OR
 648                                  *    BEGIN { a[0][0][0][0] = 1; f(a[0], a[0][0][0]); .. }
 649                                  *
 650                                  */
 651
 652                                 goto local_array;
 653                         }
 654                 }
 655         }
 656 }
 657
 658
 659 /* do_delete --- perform `delete array[s]' */
 660
 661 /*
 662  * `symbol' is array
 663  * `nsubs' is number of subscripts
 664  */
 665
 666 void
 667 do_delete(NODE *symbol, int nsubs)
 668 {
 669         unsigned long hash1 = 0;
 670         NODE *subs, *bucket, *last, *r;
 671         int i;
 672
 673         assert(symbol->type == Node_var_array);
 674         subs = bucket = last = r = NULL;        /* silence the compiler */
 675
 676         /*
 677          * The force_string() call is needed to make sure that
 678          * the string subscript is reasonable.  For example, with it:
 679          *
 680          * $ ./gawk --posix 'BEGIN { CONVFMT="%ld"; delete a[1.233]}'
 681          * gawk: cmd. line:1: fatal: `%l' is not permitted in POSIX awk formats
 682          *
 683          * Without it, the code does not fail.
 684          */
 685
 686 #define free_subs(n) \
 687 do {                                                            \
 688     NODE *s = PEEK(n - 1);                                      \
 689     if (s->type == Node_val) {                                  \
 690         (void) force_string(s); /* may have side effects ? */   \
 691         DEREF(s);                                               \
 692     }                                                           \
 693 } while (--n > 0)
 694
 695         if (nsubs == 0) {       /* delete array */
 696                 adjust_fcall_stack(symbol, 0);  /* fix function call stack; See above. */
 697                 assoc_clear(symbol);
 698                 return;
 699         }
 700
 701         /* NB: subscripts are in reverse order on stack */
 702
 703         for (i = nsubs; i > 0; i--) {
 704                 subs = PEEK(i - 1);
 705                 if (subs->type != Node_val) {
 706                         free_subs(i);
 707                         fatal(_("attempt to use array `%s' in a scalar context"), array_vname(subs));
 708                 }
 709                 (void) force_string(subs);
 710
 711                 last = NULL;    /* shut up gcc -Wall */
 712                 hash1 = 0;      /* ditto */
 713                 bucket = NULL;  /* array may be empty */
 714
 715                 if (symbol->var_array != NULL) {
 716                         hash1 = hash(subs->stptr, subs->stlen,
 717                                         (unsigned long) symbol->array_size, NULL);
 718                         bucket = assoc_find(symbol, subs, hash1, &last);
 719                 }
 720
 721                 if (bucket == NULL) {
 722                         if (do_lint)
 723                                 lintwarn(_("delete: index `%s' not in array `%s'"),
 724                                         subs->stptr, array_vname(symbol));
 725                         /* avoid memory leak, free all subs */
 726                         free_subs(i);
 727                         return;
 728                 }
 729
 730                 if (i > 1) {
 731                         if (bucket->ahvalue->type != Node_var_array) {
 732                                 /* e.g.: a[1] = 1; delete a[1][1] */
 733                                 free_subs(i);
 734                                 fatal(_("attempt to use scalar `%s[\"%.*s\"]' as an array"),
 735                                         array_vname(symbol),
 736                                         (int) bucket->ahname_len,
 737                                         bucket->ahname_str);
 738                         }
 739                         symbol = bucket->ahvalue;
 740                 }
 741                 DEREF(subs);
 742         }
 743
 744         r = bucket->ahvalue;
 745         if (r->type == Node_var_array) {
 746                 adjust_fcall_stack(r, nsubs);   /* fix function call stack; See above. */
 747                 assoc_clear(r);
 748                 /* cleared a sub-array, free Node_var_array */
 749                 efree(r->vname);
 750                 freenode(r);
 751         } else
 752                 unref(r);
 753
 754         if (last != NULL)
 755                 last->ahnext = bucket->ahnext;
 756         else
 757                 symbol->var_array[hash1] = bucket->ahnext;
 758
 759         unref(bucket);  /* unref() will free the ahname_str */
 760         symbol->table_size--;
 761         if (symbol->table_size <= 0) {
 762                 symbol->table_size = symbol->array_size = 0;
 763                 symbol->flags &= ~ARRAYMAXED;
 764                 if (symbol->var_array != NULL) {
 765                         efree(symbol->var_array);
 766                         symbol->var_array = NULL;
 767                 }
 768         }
 769
 770 #undef free_subs
 771 }
 772
 773
 774 /* do_delete_loop --- simulate ``for (iggy in foo) delete foo[iggy]'' */
 775
 776 /*
 777  * The primary hassle here is that `iggy' needs to have some arbitrary
 778  * array index put in it before we can clear the array, we can't
 779  * just replace the loop with `delete foo'.
 780  */
 781
 782 void
 783 do_delete_loop(NODE *symbol, NODE **lhs)
 784 {
 785         long i;
 786
 787         assert(symbol->type == Node_var_array);
 788
 789         if (symbol->var_array == NULL)
 790                 return;
 791
 792         /* get first index value */
 793         for (i = 0; i < symbol->array_size; i++) {
 794                 if (symbol->var_array[i] != NULL) {
 795                         unref(*lhs);
 796                         *lhs = make_string(symbol->var_array[i]->ahname_str,
 797                                         symbol->var_array[i]->ahname_len);
 798                         break;
 799                 }
 800         }
 801
 802         /* blast the array in one shot */
 803         adjust_fcall_stack(symbol, 0);
 804         assoc_clear(symbol);
 805 }
 806
 807 /* grow_table --- grow a hash table */
 808
 809 static void
 810 grow_table(NODE *symbol)
 811 {
 812         NODE **old, **new, *chain, *next;
 813         int i, j;
 814         unsigned long hash1;
 815         unsigned long oldsize, newsize, k;
 816         /*
 817          * This is an array of primes. We grow the table by an order of
 818          * magnitude each time (not just doubling) so that growing is a
 819          * rare operation. We expect, on average, that it won't happen
 820          * more than twice.  When things are very large (> 8K), we just
 821          * double more or less, instead of just jumping from 8K to 64K.
 822          */
 823         static const long sizes[] = {
 824                 13, 127, 1021, 8191, 16381, 32749, 65497, 131101, 262147,
 825                 524309, 1048583, 2097169, 4194319, 8388617, 16777259, 33554467,
 826                 67108879, 134217757, 268435459, 536870923, 1073741827
 827         };
 828
 829         /* find next biggest hash size */
 830         newsize = oldsize = symbol->array_size;
 831         for (i = 0, j = sizeof(sizes)/sizeof(sizes[0]); i < j; i++) {
 832                 if (oldsize < sizes[i]) {
 833                         newsize = sizes[i];
 834                         break;
 835                 }
 836         }
 837
 838         if (newsize == oldsize) {       /* table already at max (!) */
 839                 symbol->flags |= ARRAYMAXED;
 840                 return;
 841         }
 842
 843         /* allocate new table */
 844         emalloc(new, NODE **, newsize * sizeof(NODE *), "grow_table");
 845         memset(new, '\0', newsize * sizeof(NODE *));
 846
 847         /* brand new hash table, set things up and return */
 848         if (symbol->var_array == NULL) {
 849                 symbol->table_size = 0;
 850                 goto done;
 851         }
 852
 853         /* old hash table there, move stuff to new, free old */
 854         old = symbol->var_array;
 855         for (k = 0; k < oldsize; k++) {
 856                 if (old[k] == NULL)
 857                         continue;
 858
 859                 for (chain = old[k]; chain != NULL; chain = next) {
 860                         next = chain->ahnext;
 861                         hash1 = chain->ahcode % newsize;
 862
 863                         /* remove from old list, add to new */
 864                         chain->ahnext = new[hash1];
 865                         new[hash1] = chain;
 866                 }
 867         }
 868         efree(old);
 869
 870 done:
 871         /*
 872          * note that symbol->table_size does not change if an old array,
 873          * and is explicitly set to 0 if a new one.
 874          */
 875         symbol->var_array = new;
 876         symbol->array_size = newsize;
 877 }
 878
 879 /* pr_node --- print simple node info */
 880
 881 static void
 882 pr_node(NODE *n)
 883 {
 884         if ((n->flags & NUMBER) != 0)
 885                 printf("%s %g p: %p", flags2str(n->flags), n->numbr, n);
 886         else
 887                 printf("%s %.*s p: %p", flags2str(n->flags),
 888                                 (int) n->stlen, n->stptr, n);
 889 }
 890
 891
 892 static void
 893 indent(int indent_level)
 894 {
 895         int k;
 896         for (k = 0; k < indent_level; k++)
 897                 putchar('\t');
 898 }
 899
 900 /* assoc_dump --- dump the contents of an array */
 901
 902 NODE *
 903 assoc_dump(NODE *symbol, int indent_level)
 904 {
 905         long i;
 906         NODE *bucket;
 907
 908         indent(indent_level);
 909         if (symbol->var_array == NULL) {
 910                 printf(_("%s: empty (null)\n"), symbol->vname);
 911                 return make_number((AWKNUM) 0);
 912         }
 913
 914         if (symbol->table_size == 0) {
 915                 printf(_("%s: empty (zero)\n"), symbol->vname);
 916                 return make_number((AWKNUM) 0);
 917         }
 918
 919         printf(_("%s: table_size = %d, array_size = %d\n"), symbol->vname,
 920                         (int) symbol->table_size, (int) symbol->array_size);
 921
 922         for (i = 0; i < symbol->array_size; i++) {
 923                 for (bucket = symbol->var_array[i]; bucket != NULL;
 924                                 bucket = bucket->ahnext) {
 925                         indent(indent_level);
 926                         printf("%s: I: [len %d <%.*s> p: %p] V: [",
 927                                 symbol->vname,
 928                                 (int) bucket->ahname_len,
 929                                 (int) bucket->ahname_len,
 930                                 bucket->ahname_str,
 931                                 bucket->ahname_str);
 932                         if (bucket->ahvalue->type == Node_var_array) {
 933                                 printf("\n");
 934                                 assoc_dump(bucket->ahvalue, indent_level + 1);
 935                                 indent(indent_level);
 936                         } else
 937                                 pr_node(bucket->ahvalue);
 938                         printf("]\n");
 939                 }
 940         }
 941
 942         return make_number((AWKNUM) 0);
 943 }
 944
 945 /* do_adump --- dump an array: interface to assoc_dump */
 946
 947 NODE *
 948 do_adump(int nargs)
 949 {
 950         NODE *r, *a;
 951
 952         a = POP();
 953         if (a->type == Node_param_list) {
 954                 printf(_("%s: is parameter\n"), a->vname);
 955                 a = GET_PARAM(a->param_cnt);
 956         }
 957         if (a->type == Node_array_ref) {
 958                 printf(_("%s: array_ref to %s\n"), a->vname,
 959                                         a->orig_array->vname);
 960                 a = a->orig_array;
 961         }
 962         if (a->type != Node_var_array)
 963                 fatal(_("adump: argument not an array"));
 964         r = assoc_dump(a, 0);
 965         return r;
 966 }
 967
 968 /*
 969  * The following functions implement the builtin
 970  * asort function.  Initial work by Alan J. Broder,
 971  * ajb@woti.com.
 972  */
 973
 974 /* dup_table --- recursively duplicate input array "symbol" */
 975
 976 static NODE *
 977 dup_table(NODE *symbol, NODE *newsymb)
 978 {
 979         NODE **old, **new, *chain, *bucket;
 980         long i;
 981         unsigned long cursize;
 982
 983         /* find the current hash size */
 984         cursize = symbol->array_size;
 985
 986         new = NULL;
 987
 988         /* input is a brand new hash table, so there's nothing to copy */
 989         if (symbol->var_array == NULL)
 990                 newsymb->table_size = 0;
 991         else {
 992                 /* old hash table there, dupnode stuff into a new table */
 993
 994                 /* allocate new table */
 995                 emalloc(new, NODE **, cursize * sizeof(NODE *), "dup_table");
 996                 memset(new, '\0', cursize * sizeof(NODE *));
 997
 998                 /* do the copying/dupnode'ing */
 999                 old = symbol->var_array;
1000                 for (i = 0; i < cursize; i++) {
1001                         if (old[i] != NULL) {
1002                                 for (chain = old[i]; chain != NULL;
1003                                                 chain = chain->ahnext) {
1004                                         /* get a node for the linked list */
1005                                         getnode(bucket);
1006                                         bucket->type = Node_ahash;
1007                                         bucket->flags |= MALLOC;
1008                                         bucket->ahname_ref = 1;
1009                                         bucket->ahcode = chain->ahcode;
1010                                         if ((chain->flags & NUMIND) != 0) {
1011                                                 bucket->ahname_num = chain->ahname_num;
1012                                                 bucket->flags |= NUMIND;
1013                                         }
1014
1015                                         /*
1016                                          * copy the corresponding name and
1017                                          * value from the original input list
1018                                          */
1019                                         emalloc(bucket->ahname_str, char *, chain->ahname_len + 2, "dup_table");
1020                                         bucket->ahname_len = chain->ahname_len;
1021
1022                                         memcpy(bucket->ahname_str, chain->ahname_str, chain->ahname_len);
1023                                         bucket->ahname_str[bucket->ahname_len] = '\0';
1024
1025                                         if (chain->ahvalue->type == Node_var_array) {
1026                                                 NODE *r;
1027                                                 getnode(r);
1028                                                 r->type = Node_var_array;
1029                                                 r->vname = estrdup(chain->ahname_str, chain->ahname_len);
1030                                                 r->parent_array = newsymb;
1031                                                 bucket->ahvalue = dup_table(chain->ahvalue, r);
1032                                         } else
1033                                                 bucket->ahvalue = dupnode(chain->ahvalue);
1034
1035                                         /*
1036                                          * put the node on the corresponding
1037                                          * linked list in the new table
1038                                          */
1039                                         bucket->ahnext = new[i];
1040                                         new[i] = bucket;
1041                                 }
1042                         }
1043                 }
1044                 newsymb->table_size = symbol->table_size;
1045         }
1046
1047         newsymb->var_array = new;
1048         newsymb->array_size = cursize;
1049         newsymb->flags = symbol->flags; /* ARRAYMAXED */
1050         return newsymb;
1051 }
1052
1053
1054 /* asort_actual --- do the actual work to sort the input array */
1055
1056 static NODE *
1057 asort_actual(int nargs, SORT_CTXT ctxt)
1058 {
1059         NODE *array, *dest = NULL, *result;
1060         NODE *r, *subs, *s;
1061         NODE **list, **ptr;
1062 #define TSIZE   100     /* an arbitrary amount */
1063         static char buf[TSIZE+2];
1064         unsigned long num_elems, i;
1065         const char *sort_str;
1066
1067         if (nargs == 3)  /* 3rd optional arg */
1068                 s = POP_STRING();
1069         else
1070                 s = Nnull_string;       /* "" => default sorting */
1071
1072         s = force_string(s);
1073         sort_str = s->stptr;
1074         if (s->stlen == 0) {            /* default sorting */
1075                 if (ctxt == ASORT)
1076                         sort_str = "@val_type_asc";
1077                 else
1078                         sort_str = "@ind_str_asc";
1079         }
1080
1081
1082         if (nargs >= 2) {  /* 2nd optional arg */
1083                 dest = POP_PARAM();
1084                 if (dest->type != Node_var_array) {
1085                         fatal(ctxt == ASORT ?
1086                                 _("asort: second argument not an array") :
1087                                 _("asorti: second argument not an array"));
1088                 }
1089         }
1090
1091         array = POP_PARAM();
1092         if (array->type != Node_var_array) {
1093                 fatal(ctxt == ASORT ?
1094                         _("asort: first argument not an array") :
1095                         _("asorti: first argument not an array"));
1096         }
1097
1098         if (dest != NULL) {
1099                 for (r = dest->parent_array; r != NULL; r = r->parent_array) {
1100                         if (r == array)
1101                                 fatal(ctxt == ASORT ?
1102                                         _("asort: cannot use a subarray of first arg for second arg") :
1103                                         _("asorti: cannot use a subarray of first arg for second arg"));
1104                 }
1105                 for (r = array->parent_array; r != NULL; r = r->parent_array) {
1106                         if (r == dest)
1107                                 fatal(ctxt == ASORT ?
1108                                         _("asort: cannot use a subarray of second arg for first arg") :
1109                                         _("asorti: cannot use a subarray of second arg for first arg"));
1110                 }
1111         }
1112
1113         num_elems = array->table_size;
1114         if (num_elems == 0 || array->var_array == NULL) {       /* source array is empty */
1115                 if (dest != NULL && dest != array)
1116                         assoc_clear(dest);
1117                 return make_number((AWKNUM) 0);
1118         }
1119
1120         /* sorting happens inside assoc_list */
1121         list = assoc_list(array, sort_str, ctxt);
1122         DEREF(s);
1123
1124         /*
1125          * Must not assoc_clear() the source array before constructing
1126          * the output array. assoc_list() does not duplicate array values
1127          * which are needed for asort().
1128          */
1129
1130         if (dest != NULL && dest != array) {
1131                 assoc_clear(dest);
1132                 result = dest;
1133         } else {
1134                 /* use 'result' as a temporary destination array */
1135                 getnode(result);
1136                 memset(result, '\0', sizeof(NODE));
1137                 result->type = Node_var_array;
1138                 result->vname = array->vname;
1139                 result->parent_array = array->parent_array;
1140         }
1141
1142         subs = make_str_node(buf, TSIZE, ALREADY_MALLOCED);   /* fake it */
1143         subs->flags &= ~MALLOC;         /* safety */
1144         for (i = 1, ptr = list; i <= num_elems; i++) {
1145                 sprintf(buf, "%lu", i);
1146                 subs->stlen = strlen(buf);
1147                 /* make number valid in case this array gets sorted later */
1148                 subs->numbr = i;
1149                 subs->flags |= NUMCUR;
1150                 r = *ptr++;
1151                 if (ctxt == ASORTI) {
1152                         /*
1153                          * We want the indices of the source array as values
1154                          * of the 'result' array.
1155                          */
1156                         *assoc_lookup(result, subs, FALSE) =
1157                                         make_string(r->ahname_str, r->ahname_len);
1158                 } else {
1159                         NODE *val;
1160
1161                         /* We want the values of the source array. */
1162
1163                         val = r->ahvalue;
1164                         if (result != dest) {
1165                                 /* optimization for dest = NULL or dest = array */
1166
1167                                 if (val->type == Node_var_array) {
1168                                         /* update subarray index in parent array */
1169                                         efree(val->vname);
1170                                         val->vname = estrdup(subs->stptr, subs->stlen);
1171                                 }
1172                                 *assoc_lookup(result, subs, FALSE) = val;
1173                                 r->ahvalue = Nnull_string;
1174                         } else {
1175                                 if (val->type == Node_val)
1176                                         *assoc_lookup(result, subs, FALSE) = dupnode(val);
1177                                 else {
1178                                         NODE *arr;
1179
1180                                         /*
1181                                          * There isn't any reference counting for
1182                                          * subarrays, so recursively copy subarrays
1183                                          * using dup_table().
1184                                          */
1185                                         getnode(arr);
1186                                         arr->type = Node_var_array;
1187                                         arr->var_array = NULL;
1188                                         arr->vname = estrdup(subs->stptr, subs->stlen);
1189                                         arr->parent_array = array; /* actual parent, not the temporary one. */
1190                                         *assoc_lookup(result, subs, FALSE) = dup_table(val, arr);
1191                                 }
1192                         }
1193                 }
1194
1195                 unref(r);
1196         }
1197
1198         freenode(subs); /* stptr(buf) not malloc-ed */
1199         efree(list);
1200
1201         if (result != dest) {
1202                 /* dest == NULL or dest == array */
1203                 assoc_clear(array);
1204                 *array = *result;       /* copy result into array */
1205                 freenode(result);
1206         } /* else
1207                 result == dest
1208                 dest != NULL and dest != array */
1209
1210         return make_number((AWKNUM) num_elems);
1211 }
1212 #undef TSIZE
1213
1214 /* do_asort --- sort array by value */
1215
1216 NODE *
1217 do_asort(int nargs)
1218 {
1219         return asort_actual(nargs, ASORT);
1220 }
1221
1222 /* do_asorti --- sort array by index */
1223
1224 NODE *
1225 do_asorti(int nargs)
1226 {
1227         return asort_actual(nargs, ASORTI);
1228 }
1229
1230 /*
1231  * cmp_string --- compare two strings; logic similar to cmp_nodes() in eval.c
1232  *      except the extra case-sensitive comparison when the case-insensitive
1233  *      result is a match.
1234  */
1235
1236 static int
1237 cmp_string(const NODE *n1, const NODE *n2)
1238 {
1239         char *s1, *s2;
1240         size_t len1, len2;
1241         int ret;
1242         size_t lmin;
1243
1244         assert(n1->type == n2->type);
1245         if (n1->type == Node_ahash) {
1246                 s1 = n1->ahname_str;
1247                 len1 = n1->ahname_len;
1248                 s2 =  n2->ahname_str;
1249                 len2 = n2->ahname_len;
1250         } else {
1251                 s1 = n1->stptr;
1252                 len1 = n1->stlen;
1253                 s2 =  n2->stptr;
1254                 len2 = n2->stlen;
1255         }
1256
1257         if (len1 == 0)
1258                 return len2 == 0 ? 0 : -1;
1259         if (len2 == 0)
1260                 return 1;
1261
1262         /* len1 > 0 && len2 > 0 */
1263         lmin = len1 < len2 ? len1 : len2;
1264
1265         if (IGNORECASE) {
1266                 const unsigned char *cp1 = (const unsigned char *) s1;
1267                 const unsigned char *cp2 = (const unsigned char *) s2;
1268
1269 #if MBS_SUPPORT
1270                 if (gawk_mb_cur_max > 1) {
1271                         ret = strncasecmpmbs((const unsigned char *) cp1,
1272                                              (const unsigned char *) cp2, lmin);
1273                 } else
1274 #endif
1275                 for (ret = 0; lmin-- > 0 && ret == 0; cp1++, cp2++)
1276                         ret = casetable[*cp1] - casetable[*cp2];
1277                 if (ret != 0)
1278                         return ret;
1279                 /*
1280                  * If case insensitive result is "they're the same",
1281                  * use case sensitive comparison to force distinct order.
1282                  */
1283         }
1284
1285         ret = memcmp(s1, s2, lmin);
1286         if (ret != 0 || len1 == len2)
1287                 return ret;
1288         return (len1 < len2) ? -1 : 1;
1289 }
1290
1291
1292 /* sort_up_index_string --- qsort comparison function; ascending index strings. */
1293
1294 static int
1295 sort_up_index_string(const void *p1, const void *p2)
1296 {
1297         const NODE *t1, *t2;
1298
1299         /* Array indices are strings */
1300         t1 = *((const NODE *const *) p1);
1301         t2 = *((const NODE *const *) p2);
1302         return cmp_string(t1, t2);
1303 }
1304
1305
1306 /* sort_down_index_string --- descending index strings */
1307
1308 static int
1309 sort_down_index_string(const void *p1, const void *p2)
1310 {
1311         /*
1312          * Negation versus transposed arguments:  when all keys are
1313          * distinct, as with array indices here, either method will
1314          * transform an ascending sort into a descending one.  But if
1315          * there are equal keys--such as when IGNORECASE is honored--
1316          * that get disambiguated into a determisitc order, negation
1317          * will reverse those but transposed arguments would retain
1318          * their relative order within the rest of the reversed sort.
1319          */
1320         return -sort_up_index_string(p1, p2);
1321 }
1322
1323
1324 /* sort_up_index_number --- qsort comparison function; ascending index numbers. */
1325
1326 static int
1327 sort_up_index_number(const void *p1, const void *p2)
1328 {
1329         const NODE *n1, *n2;
1330         int ret;
1331
1332         n1 = *((const NODE *const *) p1);
1333         n2 = *((const NODE *const *) p2);
1334
1335         if (n1->ahname_num < n2->ahname_num)
1336                 ret = -1;
1337         else
1338                 ret = (n1->ahname_num > n2->ahname_num);
1339
1340         /* break a tie with the index string itself */
1341         if (ret == 0)
1342                 return cmp_string(n1, n2);
1343         return ret;
1344 }
1345
1346
1347 /* sort_down_index_number --- qsort comparison function; descending index numbers */
1348
1349 static int
1350 sort_down_index_number(const void *p1, const void *p2)
1351 {
1352         return -sort_up_index_number(p1, p2);
1353 }
1354
1355
1356 /* sort_up_value_string --- qsort comparison function; ascending value string */
1357
1358 static int
1359 sort_up_value_string(const void *p1, const void *p2)
1360 {
1361         const NODE *t1, *t2;
1362         NODE *n1, *n2;
1363
1364         /* we're passed a pair of index (array subscript) nodes */
1365         t1 = *(const NODE *const *) p1;
1366         t2 = *(const NODE *const *) p2;
1367
1368         /* and we want to compare the element values they refer to */
1369         n1 = t1->ahvalue;
1370         n2 = t2->ahvalue;
1371
1372         if (n1->type == Node_var_array) {
1373                 /* return 0 if n2 is a sub-array too, else return 1 */
1374                 return (n2->type != Node_var_array);
1375         }
1376         if (n2->type == Node_var_array)
1377                 return -1;              /* n1 (scalar) < n2 (sub-array) */
1378
1379         /* n1 and n2 both have string values; See sort_force_value_string(). */
1380         return cmp_string(n1, n2);
1381 }
1382
1383
1384 /* sort_down_value_string --- descending value string */
1385
1386 static int
1387 sort_down_value_string(const void *p1, const void *p2)
1388 {
1389         return -sort_up_value_string(p1, p2);
1390 }
1391
1392 /* sort_up_value_number --- qsort comparison function; ascending value number */
1393
1394 static int
1395 sort_up_value_number(const void *p1, const void *p2)
1396 {
1397         const NODE *t1, *t2;
1398         NODE *n1, *n2;
1399         int ret;
1400
1401         /* we're passed a pair of index (array subscript) nodes */
1402         t1 = *(const NODE *const *) p1;
1403         t2 = *(const NODE *const *) p2;
1404
1405         /* and we want to compare the element values they refer to */
1406         n1 = t1->ahvalue;
1407         n2 = t2->ahvalue;
1408
1409         if (n1->type == Node_var_array) {
1410                 /* return 0 if n2 is a sub-array too, else return 1 */
1411                 return (n2->type != Node_var_array);
1412         }
1413         if (n2->type == Node_var_array)
1414                 return -1;              /* n1 (scalar) < n2 (sub-array) */
1415
1416         /* n1 and n2 both Node_val, and force_number'ed */
1417         if (n1->numbr < n2->numbr)
1418                 ret = -1;
1419         else
1420                 ret = (n1->numbr > n2->numbr);
1421
1422         if (ret == 0) {
1423                 /*
1424                  * Use string value to guarantee same sort order on all
1425                  * versions of qsort().
1426                  */
1427                 n1 = force_string(n1);
1428                 n2 = force_string(n2);
1429                 ret = cmp_string(n1, n2);
1430         }
1431
1432         return ret;
1433 }
1434
1435 /* sort_down_value_number --- descending value number */
1436
1437 static int
1438 sort_down_value_number(const void *p1, const void *p2)
1439 {
1440         return -sort_up_value_number(p1, p2);
1441 }
1442
1443 /* sort_up_value_type --- qsort comparison function; ascending value type */
1444
1445 static int
1446 sort_up_value_type(const void *p1, const void *p2)
1447 {
1448         const NODE *t1, *t2;
1449         NODE *n1, *n2;
1450
1451         /* we're passed a pair of index (array subscript) nodes */
1452         t1 = *(const NODE *const *) p1;
1453         t2 = *(const NODE *const *) p2;
1454
1455         /* and we want to compare the element values they refer to */
1456         n1 = t1->ahvalue;
1457         n2 = t2->ahvalue;
1458
1459         /* 1. Arrays vs. scalar, scalar is less than array */
1460         if (n1->type == Node_var_array) {
1461                 /* return 0 if n2 is a sub-array too, else return 1 */
1462                 return (n2->type != Node_var_array);
1463         }
1464         if (n2->type == Node_var_array) {
1465                 return -1;              /* n1 (scalar) < n2 (sub-array) */
1466         }
1467
1468         /* two scalars */
1469         /* 2. Resolve MAYBE_NUM, so that have only NUMBER or STRING */
1470         if ((n1->flags & MAYBE_NUM) != 0)
1471                 (void) force_number(n1);
1472         if ((n2->flags & MAYBE_NUM) != 0)
1473                 (void) force_number(n2);
1474
1475         if ((n1->flags & NUMBER) != 0 && (n2->flags & NUMBER) != 0) {
1476                 if (n1->numbr < n2->numbr)
1477                         return -1;
1478                 else if (n1->numbr > n2->numbr)
1479                         return 1;
1480                 else
1481                         return 0;
1482         }
1483
1484         /* 3. All numbers are less than all strings. This is aribitrary. */
1485         if ((n1->flags & NUMBER) != 0 && (n2->flags & STRING) != 0) {
1486                 return -1;
1487         } else if ((n1->flags & STRING) != 0 && (n2->flags & NUMBER) != 0) {
1488                 return 1;
1489         }
1490
1491         /* 4. Two strings */
1492         return cmp_string(n1, n2);
1493 }
1494
1495 /* sort_down_value_type --- descending value type */
1496
1497 static int
1498 sort_down_value_type(const void *p1, const void *p2)
1499 {
1500         return -sort_up_value_type(p1, p2);
1501 }
1502
1503 /* sort_user_func --- user defined qsort comparison function */
1504
1505 static int
1506 sort_user_func(const void *p1, const void *p2)
1507 {
1508         const NODE *t1, *t2;
1509         NODE *idx1, *idx2, *val1, *val2;
1510         AWKNUM ret;
1511         INSTRUCTION *code;
1512
1513         t1 = *((const NODE *const *) p1);
1514         t2 = *((const NODE *const *) p2);
1515
1516         idx1 = make_string(t1->ahname_str, t1->ahname_len);
1517         idx2 = make_string(t2->ahname_str, t2->ahname_len);
1518         val1 = t1->ahvalue;
1519         val2 = t2->ahvalue;
1520
1521         code = TOP()->code_ptr; /* comparison function call instructions */
1522
1523         /* setup 4 arguments to comp_func() */
1524         PUSH(idx1);
1525         if (val1->type == Node_val)
1526                 UPREF(val1);
1527         PUSH(val1);
1528         PUSH(idx2);
1529         if (val2->type == Node_val)
1530                 UPREF(val2);
1531         PUSH(val2);
1532
1533         /* execute the comparison function */
1534         (void) interpret(code);
1535
1536         /* return value of the comparison function */
1537         POP_NUMBER(ret);
1538
1539         return (ret < 0.0) ? -1 : (ret > 0.0);
1540 }
1541
1542 /* sort_force_index_number -- pre-process list items for sorting indices as numbers */
1543
1544 static void
1545 sort_force_index_number(NODE **list, size_t num_elems)
1546 {
1547         size_t i;
1548         NODE *r;
1549         static NODE temp_node;
1550
1551         for (i = 0; i < num_elems; i++) {
1552                 r = list[i];
1553
1554                 if ((r->flags & NUMIND) != 0)   /* once in a lifetime is plenty */
1555                         continue;
1556                 temp_node.type = Node_val;
1557                 temp_node.stptr = r->ahname_str;
1558                 temp_node.stlen = r->ahname_len;
1559                 temp_node.flags = 0;    /* only interested in the return value of r_force_number */
1560                 r->ahname_num = r_force_number(& temp_node);
1561                 r->flags |= NUMIND;
1562         }
1563 }
1564
1565 /* sort_force_value_number -- pre-process list items for sorting values as numbers */
1566
1567 static void
1568 sort_force_value_number(NODE **list, size_t num_elems)
1569 {
1570         size_t i;
1571         NODE *r, *val;
1572
1573         for (i = 0; i < num_elems; i++) {
1574                 r = list[i];
1575                 val = r->ahvalue;
1576                 if (val->type == Node_val)
1577                         (void) force_number(val);
1578         }
1579 }
1580
1581 /* sort_force_value_string -- pre-process list items for sorting values as strings */
1582
1583 static void
1584 sort_force_value_string(NODE **list, size_t num_elems)
1585 {
1586         size_t i;
1587         NODE *r, *val;
1588
1589         for (i = 0; i < num_elems; i++) {
1590                 r = list[i];
1591                 val = r->ahvalue;
1592                 if (val->type == Node_val)
1593                         r->ahvalue = force_string(val);
1594         }
1595 }
1596
1597 /* assoc_list -- construct, and optionally sort, a list of array elements */
1598
1599 NODE **
1600 assoc_list(NODE *array, const char *sort_str, SORT_CTXT sort_ctxt)
1601 {
1602         typedef void (*qsort_prefunc)(NODE **, size_t);
1603         typedef int (*qsort_compfunc)(const void *, const void *);
1604
1605         static const struct qsort_funcs {
1606                 const char *name;
1607                 qsort_compfunc comp_func;
1608                 qsort_prefunc pre_func;         /* pre-processing of list items */
1609         } sort_funcs[] = {
1610                 { "@ind_str_asc",       sort_up_index_string,   0 },
1611                 { "@ind_num_asc",       sort_up_index_number,   sort_force_index_number },
1612                 { "@val_str_asc",       sort_up_value_string,   sort_force_value_string },
1613                 { "@val_num_asc",       sort_up_value_number,   sort_force_value_number },
1614                 { "@ind_str_desc",      sort_down_index_string, 0 },
1615                 { "@ind_num_desc",      sort_down_index_number, sort_force_index_number },
1616                 { "@val_str_desc",      sort_down_value_string, sort_force_value_string },
1617                 { "@val_num_desc",      sort_down_value_number, sort_force_value_number },
1618                 { "@val_type_asc",      sort_up_value_type,     0 },
1619                 { "@val_type_desc",     sort_down_value_type,   0 },
1620                 { "@unsorted",          0,      0 },
1621         };
1622         NODE **list;
1623         NODE *r;
1624         size_t num_elems, i, j;
1625         qsort_compfunc cmp_func = 0;
1626         qsort_prefunc pre_func = 0;
1627         INSTRUCTION *code = NULL;
1628         int qi;
1629         extern int currule;
1630
1631         num_elems = array->table_size;
1632         assert(num_elems > 0);
1633
1634         for (qi = 0, j = sizeof(sort_funcs)/sizeof(sort_funcs[0]); qi < j; qi++) {
1635                 if (strcmp(sort_funcs[qi].name, sort_str) == 0)
1636                         break;
1637         }
1638
1639         if (qi >= 0 && qi < j) {
1640                 cmp_func = sort_funcs[qi].comp_func;
1641                 pre_func = sort_funcs[qi].pre_func;
1642
1643         } else {                /* unrecognized */
1644                 NODE *f;
1645                 const char *sp;
1646
1647                 assert(sort_str != NULL);
1648
1649                 for (sp = sort_str; *sp != '\0'
1650                      && ! isspace((unsigned char) *sp); sp++)
1651                         continue;
1652
1653                 /* empty string or string with space(s) not valid as function name */
1654                 if (sp == sort_str || *sp != '\0')
1655                         fatal(_("`%s' is invalid as a function name"), sort_str);
1656
1657                 f = lookup(sort_str);
1658                 if (f == NULL || f->type != Node_func)
1659                         fatal(_("sort comparison function `%s' is not defined"), sort_str);
1660
1661                 cmp_func = sort_user_func;
1662                 /* pre_func is still NULL */
1663
1664                 /* make function call instructions */
1665                 code = bcalloc(Op_func_call, 2, 0);
1666                 code->func_body = f;
1667                 code->func_name = NULL;         /* not needed, func_body already assigned */
1668                 (code + 1)->expr_count = 4;     /* function takes 4 arguments */
1669                 code->nexti = bcalloc(Op_stop, 1, 0);
1670
1671                 /* make non-redirected getline, exit, `next' and `nextfile' fatal in
1672                  * callback function by setting currule in interpret()
1673                  * to undefined (0).
1674                  */
1675
1676                 (code + 1)->inrule = currule;   /* save current rule */
1677                 currule = 0;
1678
1679                 PUSH_CODE(code);
1680         }
1681
1682         /* allocate space for array; the extra space is used in for(i in a) opcode (eval.c) */
1683         emalloc(list, NODE **, (num_elems + 1) * sizeof(NODE *), "assoc_list");
1684
1685         /* populate it */
1686         for (i = j = 0; i < array->array_size; i++)
1687                 for (r = array->var_array[i]; r != NULL; r = r->ahnext)
1688                         list[j++] = dupnode(r);
1689         list[num_elems] = NULL;
1690
1691         if (! cmp_func) /* unsorted */
1692                 return list;
1693
1694         /* special pre-processing of list items */
1695         if (pre_func)
1696                 pre_func(list, num_elems);
1697
1698         qsort(list, num_elems, sizeof(NODE *), cmp_func); /* shazzam! */
1699
1700         if (cmp_func == sort_user_func) {
1701                 code = POP_CODE();
1702                 currule = (code + 1)->inrule;   /* restore current rule */
1703                 bcfree(code->nexti);            /* Op_stop */
1704                 bcfree(code);                   /* Op_func_call */
1705         }
1706
1707         return list;
1708 }
1709
1710
1711 /*
1712 From bonzini@gnu.org  Mon Oct 28 16:05:26 2002
1713 Date: Mon, 28 Oct 2002 13:33:03 +0100
1714 From: Paolo Bonzini <bonzini@gnu.org>
1715 To: arnold@skeeve.com
1716 Subject: Hash function
1717 Message-ID: <20021028123303.GA6832@biancaneve>
1718
1719 Here is the hash function I'm using in GNU Smalltalk.  The scrambling is
1720 needed if you use powers of two as the table sizes.  If you use primes it
1721 is not needed.
1722
1723 To use double-hashing with power-of-two size, you should use the
1724 _gst_hash_string(str, len) as the primary hash and
1725 scramble(_gst_hash_string (str, len)) | 1 as the secondary hash.
1726
1727 Paolo
1728
1729 */
1730 /*
1731  * ADR: Slightly modified to work w/in the context of gawk.
1732  */
1733
1734 static unsigned long
1735 gst_hash_string(const char *str, size_t len, unsigned long hsize, size_t *code)
1736 {
1737         unsigned long hashVal = 1497032417;    /* arbitrary value */
1738         unsigned long ret;
1739
1740         while (len--) {
1741                 hashVal += *str++;
1742                 hashVal += (hashVal << 10);
1743                 hashVal ^= (hashVal >> 6);
1744         }
1745
1746         ret = scramble(hashVal);
1747
1748         if (code != NULL)
1749                 *code = ret;
1750
1751         if (ret >= hsize)
1752                 ret %= hsize;
1753
1754         return ret;
1755 }
1756
1757 static unsigned long
1758 scramble(unsigned long x)
1759 {
1760         if (sizeof(long) == 4) {
1761                 int y = ~x;
1762
1763                 x += (y << 10) | (y >> 22);
1764                 x += (x << 6)  | (x >> 26);
1765                 x -= (x << 16) | (x >> 16);
1766         } else {
1767                 x ^= (~x) >> 31;
1768                 x += (x << 21) | (x >> 11);
1769                 x += (x << 5) | (x >> 27);
1770                 x += (x << 27) | (x >> 5);
1771                 x += (x << 31);
1772         }
1773
1774         return x;
1775 }