array.c

   1 /*
   2  * array.c - routines for awk arrays.
   3  */
   4
   5 /*
   6  * Copyright (C) 1986, 1988, 1989, 1991-2014 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 extern FILE *output_fp;
  29 extern NODE **fmt_list;          /* declared in eval.c */
  30
  31 static size_t SUBSEPlen;
  32 static char *SUBSEP;
  33 static char indent_char[] = "    ";
  34
  35 static NODE **null_lookup(NODE *symbol, NODE *subs);
  36 static NODE **null_dump(NODE *symbol, NODE *subs);
  37 static afunc_t null_array_func[] = {
  38         (afunc_t) 0,
  39         (afunc_t) 0,
  40         null_length,
  41         null_lookup,
  42         null_afunc,
  43         null_afunc,
  44         null_afunc,
  45         null_afunc,
  46         null_afunc,
  47         null_dump,
  48         (afunc_t) 0,
  49 };
  50
  51 #define MAX_ATYPE 10
  52
  53 static afunc_t *array_types[MAX_ATYPE];
  54 static int num_array_types = 0;
  55
  56 /* array func to index mapping */
  57 #define AFUNC(F) (F ## _ind)
  58
  59 /* register_array_func --- add routines to handle arrays */
  60
  61 int
  62 register_array_func(afunc_t *afunc)
  63 {
  64         if (afunc && num_array_types < MAX_ATYPE) {
  65                 if (afunc != str_array_func && ! afunc[AFUNC(atypeof)])
  66                         return false;
  67                 array_types[num_array_types++] = afunc;
  68                 if (afunc[AFUNC(ainit)])        /* execute init routine if any */
  69                         (void) (*afunc[AFUNC(ainit)])(NULL, NULL);
  70                 return true;
  71         }
  72         return false;
  73 }
  74
  75
  76 /* array_init --- register all builtin array types */
  77
  78 void
  79 array_init()
  80 {
  81         (void) register_array_func(str_array_func);     /* the default */
  82         if (! do_mpfr) {
  83                 (void) register_array_func(int_array_func);
  84                 (void) register_array_func(cint_array_func);
  85         }
  86 }
  87
  88
  89 /* make_array --- create an array node */
  90
  91 NODE *
  92 make_array()
  93 {
  94         NODE *array;
  95         getnode(array);
  96         memset(array, '\0', sizeof(NODE));
  97         array->type = Node_var_array;
  98         array->array_funcs = null_array_func;
  99         /* vname, flags, and parent_array not set here */
 100
 101         return array;
 102 }
 103
 104
 105 /* null_array --- force symbol to be an empty typeless array */
 106
 107 void
 108 null_array(NODE *symbol)
 109 {
 110         symbol->type = Node_var_array;
 111         symbol->array_funcs = null_array_func;
 112         symbol->buckets = NULL;
 113         symbol->table_size = symbol->array_size = 0;
 114         symbol->array_capacity = 0;
 115         symbol->flags = 0;
 116
 117         assert(symbol->xarray == NULL);
 118
 119         /* vname, parent_array not (re)initialized */
 120 }
 121
 122
 123 /* null_lookup --- assign type to an empty array. */
 124
 125 static NODE **
 126 null_lookup(NODE *symbol, NODE *subs)
 127 {
 128         int i;
 129         afunc_t *afunc = NULL;
 130
 131         assert(symbol->table_size == 0);
 132
 133         /*
 134          * Check which array type wants to accept this sub; traverse
 135          * array type list in reverse order.
 136          */
 137         for (i = num_array_types - 1; i >= 1; i--) {
 138                 afunc = array_types[i];
 139                 if (afunc[AFUNC(atypeof)](symbol, subs) != NULL)
 140                         break;
 141         }
 142         if (i == 0 || afunc == NULL)
 143                 afunc = array_types[0]; /* default is str_array_func */
 144         symbol->array_funcs = afunc;
 145
 146         /* We have the right type of array; install the subscript */
 147         return symbol->alookup(symbol, subs);
 148 }
 149
 150 /* null_length --- default function for array length interface */
 151
 152 NODE **
 153 null_length(NODE *symbol, NODE *subs ATTRIBUTE_UNUSED)
 154 {
 155         static NODE *tmp;
 156         tmp = symbol;
 157         return & tmp;
 158 }
 159
 160 /* null_afunc --- default function for array interface */
 161
 162 NODE **
 163 null_afunc(NODE *symbol ATTRIBUTE_UNUSED, NODE *subs ATTRIBUTE_UNUSED)
 164 {
 165         return NULL;
 166 }
 167
 168 /* null_dump --- dump function for an empty array */
 169
 170 static NODE **
 171 null_dump(NODE *symbol, NODE *subs ATTRIBUTE_UNUSED)
 172 {
 173         fprintf(output_fp, "array `%s' is empty\n", array_vname(symbol));
 174         return NULL;
 175 }
 176
 177
 178 /* assoc_copy --- duplicate input array "symbol" */
 179
 180 NODE *
 181 assoc_copy(NODE *symbol, NODE *newsymb)
 182 {
 183         assert(newsymb->vname != NULL);
 184
 185         assoc_clear(newsymb);
 186         (void) symbol->acopy(symbol, newsymb);
 187         newsymb->array_funcs = symbol->array_funcs;
 188         newsymb->flags = symbol->flags;
 189         return newsymb;
 190 }
 191
 192
 193 /* assoc_dump --- dump array */
 194
 195 void
 196 assoc_dump(NODE *symbol, NODE *ndump)
 197 {
 198         if (symbol->adump)
 199                 (void) symbol->adump(symbol, ndump);
 200 }
 201
 202
 203 /* make_aname --- construct a 'vname' for a (sub)array */
 204
 205 const char *
 206 make_aname(const NODE *symbol)
 207 {
 208         static char *aname = NULL;
 209         static size_t alen;
 210         static size_t max_alen;
 211 #define SLEN 256
 212
 213         if (symbol->parent_array != NULL) {
 214                 size_t slen;
 215
 216                 (void) make_aname(symbol->parent_array);
 217                 slen = strlen(symbol->vname);   /* subscript in parent array */
 218                 if (alen + slen + 4 > max_alen) {               /* sizeof("[\"\"]") = 4 */
 219                         max_alen = alen + slen + 4 + SLEN;
 220                         erealloc(aname, char *, (max_alen + 1) * sizeof(char *), "make_aname");
 221                 }
 222                 alen += sprintf(aname + alen, "[\"%s\"]", symbol->vname);
 223         } else {
 224                 alen = strlen(symbol->vname);
 225                 if (aname == NULL) {
 226                         max_alen = alen + SLEN;
 227                         emalloc(aname, char *, (max_alen + 1) * sizeof(char *), "make_aname");
 228                 } else if (alen > max_alen) {
 229                         max_alen = alen + SLEN;
 230                         erealloc(aname, char *, (max_alen + 1) * sizeof(char *), "make_aname");
 231                 }
 232                 memcpy(aname, symbol->vname, alen + 1);
 233         }
 234         return aname;
 235 }
 236 #undef SLEN
 237
 238
 239 /*
 240  * array_vname --- print the name of the array
 241  *
 242  * Returns a pointer to a statically maintained dynamically allocated string.
 243  * It's appropriate for printing the name once; if the caller wants
 244  * to save it, they have to make a copy.
 245  */
 246
 247 const char *
 248 array_vname(const NODE *symbol)
 249 {
 250         static char *message = NULL;
 251         static size_t msglen = 0;
 252         char *s;
 253         size_t len;
 254         int n;
 255         const NODE *save_symbol = symbol;
 256         const char *from = _("from %s");
 257         const char *aname;
 258
 259         if (symbol->type != Node_array_ref
 260                         || symbol->orig_array->type != Node_var_array
 261         ) {
 262                 if (symbol->type != Node_var_array || symbol->parent_array == NULL)
 263                         return symbol->vname;
 264                 return make_aname(symbol);
 265         }
 266
 267         /* First, we have to compute the length of the string: */
 268
 269         len = 2; /* " (" */
 270         n = 0;
 271         while (symbol->type == Node_array_ref) {
 272                 len += strlen(symbol->vname);
 273                 n++;
 274                 symbol = symbol->prev_array;
 275         }
 276
 277         /* Get the (sub)array name */
 278         if (symbol->parent_array == NULL)
 279                 aname = symbol->vname;
 280         else
 281                 aname = make_aname(symbol);
 282         len += strlen(aname);
 283         /*
 284          * Each node contributes by strlen(from) minus the length
 285          * of "%s" in the translation (which is at least 2)
 286          * plus 2 for ", " or ")\0"; this adds up to strlen(from).
 287          */
 288         len += n * strlen(from);
 289
 290         /* (Re)allocate memory: */
 291         if (message == NULL) {
 292                 emalloc(message, char *, len, "array_vname");
 293                 msglen = len;
 294         } else if (len > msglen) {
 295                 erealloc(message, char *, len, "array_vname");
 296                 msglen = len;
 297         } /* else
 298                 current buffer can hold new name */
 299
 300         /* We're ready to print: */
 301         symbol = save_symbol;
 302         s = message;
 303         /*
 304          * Ancient systems have sprintf() returning char *, not int.
 305          * If you have one of those, use sprintf(..); s += strlen(s) instead.
 306          */
 307
 308         s += sprintf(s, "%s (", symbol->vname);
 309         for (;;) {
 310                 symbol = symbol->prev_array;
 311                 if (symbol->type != Node_array_ref)
 312                         break;
 313                 s += sprintf(s, from, symbol->vname);
 314                 s += sprintf(s, ", ");
 315         }
 316         s += sprintf(s, from, aname);
 317         strcpy(s, ")");
 318
 319         return message;
 320 }
 321
 322
 323 /*
 324  *  force_array --- proceed to the actual Node_var_array,
 325  *      change Node_var_new to an array.
 326  *      If canfatal and type isn't good, die fatally,
 327  *      otherwise return the final actual value.
 328  */
 329
 330 NODE *
 331 force_array(NODE *symbol, bool canfatal)
 332 {
 333         NODE *save_symbol = symbol;
 334         bool isparam = false;
 335
 336         if (symbol->type == Node_param_list) {
 337                 save_symbol = symbol = GET_PARAM(symbol->param_cnt);
 338                 isparam = true;
 339                 if (symbol->type == Node_array_ref)
 340                         symbol = symbol->orig_array;
 341         }
 342
 343         switch (symbol->type) {
 344         case Node_var_new:
 345                 symbol->xarray = NULL;  /* make sure union is as it should be */
 346                 null_array(symbol);
 347                 symbol->parent_array = NULL;    /* main array has no parent */
 348                 /* fall through */
 349         case Node_var_array:
 350                 break;
 351
 352         case Node_array_ref:
 353         default:
 354                 /* notably Node_var but catches also e.g. a[1] = "x"; a[1][1] = "y" */
 355                 if (canfatal) {
 356                         if (symbol->type == Node_val)
 357                                 fatal(_("attempt to use a scalar value as array"));
 358                         if (isparam)
 359                                 fatal(_("attempt to use scalar parameter `%s' as an array"),
 360                                         save_symbol->vname);
 361                         else
 362                                 fatal(_("attempt to use scalar `%s' as an array"),
 363                                         save_symbol->vname);
 364                 } else
 365                         break;
 366         }
 367
 368         return symbol;
 369 }
 370
 371
 372 /* set_SUBSEP --- update SUBSEP related variables when SUBSEP assigned to */
 373
 374 void
 375 set_SUBSEP()
 376 {
 377         SUBSEP_node->var_value = force_string(SUBSEP_node->var_value);
 378         SUBSEP = SUBSEP_node->var_value->stptr;
 379         SUBSEPlen = SUBSEP_node->var_value->stlen;
 380 }
 381
 382
 383 /* concat_exp --- concatenate expression list into a single string */
 384
 385 NODE *
 386 concat_exp(int nargs, bool do_subsep)
 387 {
 388         /* do_subsep is false for Op_concat */
 389         NODE *r;
 390         char *str;
 391         char *s;
 392         size_t len;
 393         size_t subseplen = 0;
 394         int i;
 395         extern NODE **args_array;
 396
 397         if (nargs == 1)
 398                 return POP_STRING();
 399
 400         if (do_subsep)
 401                 subseplen = SUBSEPlen;
 402
 403         len = 0;
 404         for (i = 1; i <= nargs; i++) {
 405                 r = TOP();
 406                 if (r->type == Node_var_array) {
 407                         while (--i > 0)
 408                                 DEREF(args_array[i]);   /* avoid memory leak */
 409                         fatal(_("attempt to use array `%s' in a scalar context"), array_vname(r));
 410                 }
 411                 r = POP_STRING();
 412                 args_array[i] = r;
 413                 len += r->stlen;
 414         }
 415         len += (nargs - 1) * subseplen;
 416
 417         emalloc(str, char *, len + 2, "concat_exp");
 418
 419         r = args_array[nargs];
 420         memcpy(str, r->stptr, r->stlen);
 421         s = str + r->stlen;
 422         DEREF(r);
 423         for (i = nargs - 1; i > 0; i--) {
 424                 if (subseplen == 1)
 425                         *s++ = *SUBSEP;
 426                 else if (subseplen > 0) {
 427                         memcpy(s, SUBSEP, subseplen);
 428                         s += subseplen;
 429                 }
 430                 r = args_array[i];
 431                 memcpy(s, r->stptr, r->stlen);
 432                 s += r->stlen;
 433                 DEREF(r);
 434         }
 435
 436         return make_str_node(str, len, ALREADY_MALLOCED);
 437 }
 438
 439
 440 /*
 441  * adjust_fcall_stack: remove subarray(s) of symbol[] from
 442  *      function call stack.
 443  */
 444
 445 static void
 446 adjust_fcall_stack(NODE *symbol, int nsubs)
 447 {
 448         NODE *func, *r, *n;
 449         NODE **sp;
 450         int pcount;
 451
 452         /*
 453          * Solve the nasty problem of disappearing subarray arguments:
 454          *
 455          *  function f(c, d) { delete c; .. use non-existent array d .. }
 456          *  BEGIN { a[0][0] = 1; f(a, a[0]); .. }
 457          *
 458          * The fix is to convert 'd' to a local empty array; This has
 459          * to be done before clearing the parent array to avoid referring to
 460          * already free-ed memory.
 461          *
 462          * Similar situations exist for builtins accepting more than
 463          * one array argument: split, patsplit, asort and asorti. For example:
 464          *
 465          *  BEGIN { a[0][0] = 1; split("abc", a, "", a[0]) }
 466          *
 467          * These cases do not involve the function call stack, and are
 468          * handled individually in their respective routines.
 469          */
 470
 471         func = frame_ptr->func_node;
 472         if (func == NULL)       /* in main */
 473                 return;
 474         pcount = func->param_cnt;
 475         sp = frame_ptr->stack;
 476
 477         for (; pcount > 0; pcount--) {
 478                 r = *sp++;
 479                 if (r->type != Node_array_ref
 480                                 || r->orig_array->type != Node_var_array)
 481                         continue;
 482                 n = r->orig_array;
 483
 484                 /* Case 1 */
 485                 if (n == symbol
 486                         && symbol->parent_array != NULL
 487                         && nsubs > 0
 488                 ) {
 489                         /*
 490                          * 'symbol' is a subarray, and 'r' is the same subarray:
 491                          *
 492                          *   function f(c, d) { delete c[0]; .. }
 493                          *   BEGIN { a[0][0] = 1; f(a, a[0]); .. }
 494                          *
 495                          * But excludes cases like (nsubs = 0):
 496                          *
 497                          *   function f(c, d) { delete c; ..}
 498                          *   BEGIN { a[0][0] = 1; f(a[0], a[0]); ...}
 499                          */
 500
 501                         null_array(r);
 502                         r->parent_array = NULL;
 503                         continue;
 504                 }
 505
 506                 /* Case 2 */
 507                 for (n = n->parent_array; n != NULL; n = n->parent_array) {
 508                         assert(n->type == Node_var_array);
 509                         if (n == symbol) {
 510                                 /*
 511                                  * 'r' is a subarray of 'symbol':
 512                                  *
 513                                  *    function f(c, d) { delete c; .. use d as array .. }
 514                                  *    BEGIN { a[0][0] = 1; f(a, a[0]); .. }
 515                                  *      OR
 516                                  *    BEGIN { a[0][0][0][0] = 1; f(a[0], a[0][0][0]); .. }
 517                                  *
 518                                  */
 519                                 null_array(r);
 520                                 r->parent_array = NULL;
 521                                 break;
 522                         }
 523                 }
 524         }
 525 }
 526
 527
 528 /* do_delete --- perform `delete array[s]' */
 529
 530 /*
 531  * `symbol' is array
 532  * `nsubs' is no of subscripts
 533  */
 534
 535 void
 536 do_delete(NODE *symbol, int nsubs)
 537 {
 538         NODE *val, *subs;
 539         int i;
 540
 541         assert(symbol->type == Node_var_array);
 542         subs = val = NULL;      /* silence the compiler */
 543
 544         /*
 545          * The force_string() call is needed to make sure that
 546          * the string subscript is reasonable.  For example, with it:
 547          *
 548          * $ ./gawk --posix 'BEGIN { CONVFMT="%ld"; delete a[1.233]}'
 549          * gawk: cmd. line:1: fatal: `%l' is not permitted in POSIX awk formats
 550          *
 551          * Without it, the code does not fail.
 552          */
 553
 554 #define free_subs(n)    do {                                    \
 555     NODE *s = PEEK(n - 1);                                      \
 556     if (s->type == Node_val) {                                  \
 557         (void) force_string(s); /* may have side effects. */    \
 558         DEREF(s);                                               \
 559     }                                                           \
 560 } while (--n > 0)
 561
 562         if (nsubs == 0) {
 563                 /* delete array */
 564
 565                 adjust_fcall_stack(symbol, 0);  /* fix function call stack; See above. */
 566                 assoc_clear(symbol);
 567                 return;
 568         }
 569
 570         /* NB: subscripts are in reverse order on stack */
 571
 572         for (i = nsubs; i > 0; i--) {
 573                 subs = PEEK(i - 1);
 574                 if (subs->type != Node_val) {
 575                         free_subs(i);
 576                         fatal(_("attempt to use array `%s' in a scalar context"), array_vname(subs));
 577                 }
 578
 579                 val = in_array(symbol, subs);
 580                 if (val == NULL) {
 581                         if (do_lint) {
 582                                 subs = force_string(subs);
 583                                 lintwarn(_("delete: index `%s' not in array `%s'"),
 584                                         subs->stptr, array_vname(symbol));
 585                         }
 586                         /* avoid memory leak, free all subs */
 587                         free_subs(i);
 588                         return;
 589                 }
 590
 591                 if (i > 1) {
 592                         if (val->type != Node_var_array) {
 593                                 /* e.g.: a[1] = 1; delete a[1][1] */
 594
 595                                 free_subs(i);
 596                                 subs = force_string(subs);
 597                                 fatal(_("attempt to use scalar `%s[\"%.*s\"]' as an array"),
 598                                         array_vname(symbol),
 599                                         (int) subs->stlen,
 600                                         subs->stptr);
 601                         }
 602                         symbol = val;
 603                         DEREF(subs);
 604                 }
 605         }
 606
 607         if (val->type == Node_var_array) {
 608                 adjust_fcall_stack(val, nsubs);  /* fix function call stack; See above. */
 609                 assoc_clear(val);
 610                 /* cleared a sub-array, free Node_var_array */
 611                 efree(val->vname);
 612                 freenode(val);
 613         } else
 614                 unref(val);
 615
 616         (void) assoc_remove(symbol, subs);
 617         DEREF(subs);
 618
 619 #undef free_subs
 620 }
 621
 622
 623 /* do_delete_loop --- simulate ``for (iggy in foo) delete foo[iggy]'' */
 624
 625 /*
 626  * The primary hassle here is that `iggy' needs to have some arbitrary
 627  * array index put in it before we can clear the array, we can't
 628  * just replace the loop with `delete foo'.
 629  */
 630
 631 void
 632 do_delete_loop(NODE *symbol, NODE **lhs)
 633 {
 634         NODE **list;
 635         NODE akind;
 636
 637         akind.flags = AINDEX|ADELETE;   /* need a single index */
 638         list = symbol->alist(symbol, & akind);
 639
 640         if (assoc_empty(symbol))
 641                 return;
 642
 643         unref(*lhs);
 644         *lhs = list[0];
 645         efree(list);
 646
 647         /* blast the array in one shot */
 648         adjust_fcall_stack(symbol, 0);
 649         assoc_clear(symbol);
 650 }
 651
 652
 653 /* value_info --- print scalar node info */
 654
 655 static void
 656 value_info(NODE *n)
 657 {
 658
 659 #define PREC_NUM -1
 660 #define PREC_STR -1
 661
 662         if (n == Nnull_string || n == Null_field) {
 663                 fprintf(output_fp, "<(null)>");
 664                 return;
 665         }
 666
 667         if ((n->flags & (STRING|STRCUR)) != 0) {
 668                 fprintf(output_fp, "<");
 669                 fprintf(output_fp, "\"%.*s\"", PREC_STR, n->stptr);
 670                 if ((n->flags & (NUMBER|NUMCUR)) != 0) {
 671 #ifdef HAVE_MPFR
 672                         if (is_mpg_float(n))
 673                                 fprintf(output_fp, ":%s",
 674                                         mpg_fmt("%.*R*g", PREC_NUM, ROUND_MODE, n->mpg_numbr));
 675                         else if (is_mpg_integer(n))
 676                                 fprintf(output_fp, ":%s", mpg_fmt("%Zd", n->mpg_i));
 677                         else
 678 #endif
 679                         fprintf(output_fp, ":%.*g", PREC_NUM, n->numbr);
 680                 }
 681                 fprintf(output_fp, ">");
 682         } else {
 683 #ifdef HAVE_MPFR
 684                 if (is_mpg_float(n))
 685                         fprintf(output_fp, "<%s>",
 686                                 mpg_fmt("%.*R*g", PREC_NUM, ROUND_MODE, n->mpg_numbr));
 687                 else if (is_mpg_integer(n))
 688                         fprintf(output_fp, "<%s>", mpg_fmt("%Zd", n->mpg_i));
 689                 else
 690 #endif
 691                 fprintf(output_fp, "<%.*g>", PREC_NUM, n->numbr);
 692         }
 693
 694         fprintf(output_fp, ":%s", flags2str(n->flags));
 695
 696         if ((n->flags & FIELD) == 0)
 697                 fprintf(output_fp, ":%ld", n->valref);
 698         else
 699                 fprintf(output_fp, ":");
 700
 701         if ((n->flags & (STRING|STRCUR)) == STRCUR) {
 702                 fprintf(output_fp, "][");
 703                 fprintf(output_fp, "stfmt=%d, ", n->stfmt);
 704                 fprintf(output_fp, "CONVFMT=\"%s\"", n->stfmt <= -1 ? "%ld"
 705                                         : fmt_list[n->stfmt]->stptr);
 706         }
 707
 708 #undef PREC_NUM
 709 #undef PREC_STR
 710 }
 711
 712
 713 void
 714 indent(int indent_level)
 715 {
 716         int i;
 717         for (i = 0; i < indent_level; i++)
 718                 fprintf(output_fp, "%s", indent_char);
 719 }
 720
 721 /* assoc_info --- print index, value info */
 722
 723 void
 724 assoc_info(NODE *subs, NODE *val, NODE *ndump, const char *aname)
 725 {
 726         int indent_level = ndump->alevel;
 727
 728         indent_level++;
 729         indent(indent_level);
 730         fprintf(output_fp, "I: [%s:", aname);
 731         if ((subs->flags & (MPFN|MPZN|INTIND)) == INTIND)
 732                 fprintf(output_fp, "<%ld>", (long) subs->numbr);
 733         else
 734                 value_info(subs);
 735         fprintf(output_fp, "]\n");
 736
 737         indent(indent_level);
 738         if (val->type == Node_val) {
 739                 fprintf(output_fp, "V: [scalar: ");
 740                 value_info(val);
 741         } else {
 742                 fprintf(output_fp, "V: [");
 743                 ndump->alevel++;
 744                 ndump->adepth--;
 745                 assoc_dump(val, ndump);
 746                 ndump->adepth++;
 747                 ndump->alevel--;
 748                 indent(indent_level);
 749         }
 750         fprintf(output_fp, "]\n");
 751 }
 752
 753
 754 /* do_adump --- dump an array: interface to assoc_dump */
 755
 756 NODE *
 757 do_adump(int nargs)
 758 {
 759         NODE *symbol, *tmp;
 760         static NODE ndump;
 761         long depth = 0;
 762
 763         /*
 764          * depth < 0, no index and value info.
 765          *       = 0, main array index and value info; does not descend into sub-arrays.
 766          *       > 0, descends into 'depth' sub-arrays, and prints index and value info.
 767          */
 768
 769         if (nargs == 2) {
 770                 tmp = POP_NUMBER();
 771                 depth = get_number_si(tmp);
 772                 DEREF(tmp);
 773         }
 774         symbol = POP_PARAM();
 775         if (symbol->type != Node_var_array)
 776                 fatal(_("adump: first argument not an array"));
 777
 778         ndump.type = Node_dump_array;
 779         ndump.adepth = depth;
 780         ndump.alevel = 0;
 781         assoc_dump(symbol, & ndump);
 782         return make_number((AWKNUM) 0);
 783 }
 784
 785
 786 /* asort_actual --- do the actual work to sort the input array */
 787
 788 static NODE *
 789 asort_actual(int nargs, sort_context_t ctxt)
 790 {
 791         NODE *array, *dest = NULL, *result;
 792         NODE *r, *subs, *s;
 793         NODE **list = NULL, **ptr, **lhs;
 794         unsigned long num_elems, i;
 795         const char *sort_str;
 796
 797         if (nargs == 3)  /* 3rd optional arg */
 798                 s = POP_STRING();
 799         else
 800                 s = dupnode(Nnull_string);      /* "" => default sorting */
 801
 802         s = force_string(s);
 803         sort_str = s->stptr;
 804         if (s->stlen == 0) {            /* default sorting */
 805                 if (ctxt == ASORT)
 806                         sort_str = "@val_type_asc";
 807                 else
 808                         sort_str = "@ind_str_asc";
 809         }
 810
 811         if (nargs >= 2) {  /* 2nd optional arg */
 812                 dest = POP_PARAM();
 813                 if (dest->type != Node_var_array) {
 814                         fatal(ctxt == ASORT ?
 815                                 _("asort: second argument not an array") :
 816                                 _("asorti: second argument not an array"));
 817                 }
 818         }
 819
 820         array = POP_PARAM();
 821         if (array->type != Node_var_array) {
 822                 fatal(ctxt == ASORT ?
 823                         _("asort: first argument not an array") :
 824                         _("asorti: first argument not an array"));
 825         }
 826
 827         if (dest != NULL) {
 828                 for (r = dest->parent_array; r != NULL; r = r->parent_array) {
 829                         if (r == array)
 830                                 fatal(ctxt == ASORT ?
 831                                         _("asort: cannot use a subarray of first arg for second arg") :
 832                                         _("asorti: cannot use a subarray of first arg for second arg"));
 833                 }
 834                 for (r = array->parent_array; r != NULL; r = r->parent_array) {
 835                         if (r == dest)
 836                                 fatal(ctxt == ASORT ?
 837                                         _("asort: cannot use a subarray of second arg for first arg") :
 838                                         _("asorti: cannot use a subarray of second arg for first arg"));
 839                 }
 840         }
 841
 842         /* sorting happens inside assoc_list */
 843         list = assoc_list(array, sort_str, ctxt);
 844         DEREF(s);
 845
 846         num_elems = assoc_length(array);
 847         if (num_elems == 0 || list == NULL) {
 848                 /* source array is empty */
 849                 if (dest != NULL && dest != array)
 850                         assoc_clear(dest);
 851                 if (list != NULL)
 852                         efree(list);
 853                 return make_number((AWKNUM) 0);
 854         }
 855
 856         /*
 857          * Must not assoc_clear() the source array before constructing
 858          * the output array. assoc_list() does not duplicate array values
 859          * which are needed for asort().
 860          */
 861
 862         if (dest != NULL && dest != array) {
 863                 assoc_clear(dest);
 864                 result = dest;
 865         } else {
 866                 /* use 'result' as a temporary destination array */
 867                 result = make_array();
 868                 result->vname = array->vname;
 869                 result->parent_array = array->parent_array;
 870         }
 871
 872         if (ctxt == ASORTI) {
 873                 /* We want the indices of the source array. */
 874
 875                 for (i = 1, ptr = list; i <= num_elems; i++, ptr += 2) {
 876                         subs = make_number(i);
 877                         lhs = assoc_lookup(result, subs);
 878                         unref(*lhs);
 879                         *lhs = *ptr;
 880                         if (result->astore != NULL)
 881                                 (*result->astore)(result, subs);
 882                         unref(subs);
 883                 }
 884         } else {
 885                 /* We want the values of the source array. */
 886
 887                 for (i = 1, ptr = list; i <= num_elems; i++) {
 888                         subs = make_number(i);
 889
 890                         /* free index node */
 891                         r = *ptr++;
 892                         unref(r);
 893
 894                         /* value node */
 895                         r = *ptr++;
 896
 897                         if (r->type == Node_val) {
 898                                 lhs = assoc_lookup(result, subs);
 899                                 unref(*lhs);
 900                                 *lhs = dupnode(r);
 901                         } else {
 902                                 NODE *arr;
 903                                 arr = make_array();
 904                                 subs = force_string(subs);
 905                                 arr->vname = subs->stptr;
 906                                 subs->stptr = NULL;
 907                                 subs->flags &= ~STRCUR;
 908                                 arr->parent_array = array; /* actual parent, not the temporary one. */
 909                                 lhs = assoc_lookup(result, subs);
 910                                 unref(*lhs);
 911                                 *lhs = assoc_copy(r, arr);
 912                         }
 913                         if (result->astore != NULL)
 914                                 (*result->astore)(result, subs);
 915                         unref(subs);
 916                 }
 917         }
 918
 919         efree(list);
 920
 921         if (result != dest) {
 922                 /* dest == NULL or dest == array */
 923                 assoc_clear(array);
 924                 *array = *result;       /* copy result into array */
 925                 freenode(result);
 926         } /* else
 927                 result == dest
 928                 dest != NULL and dest != array */
 929
 930         return make_number((AWKNUM) num_elems);
 931 }
 932
 933 /* do_asort --- sort array by value */
 934
 935 NODE *
 936 do_asort(int nargs)
 937 {
 938         return asort_actual(nargs, ASORT);
 939 }
 940
 941 /* do_asorti --- sort array by index */
 942
 943 NODE *
 944 do_asorti(int nargs)
 945 {
 946         return asort_actual(nargs, ASORTI);
 947 }
 948
 949
 950 /*
 951  * cmp_strings --- compare two strings; logic similar to cmp_nodes() in eval.c
 952  *      except the extra case-sensitive comparison when the case-insensitive
 953  *      result is a match.
 954  */
 955
 956 static int
 957 cmp_strings(const NODE *n1, const NODE *n2)
 958 {
 959         char *s1, *s2;
 960         size_t len1, len2;
 961         int ret;
 962         size_t lmin;
 963
 964         s1 = n1->stptr;
 965         len1 = n1->stlen;
 966         s2 =  n2->stptr;
 967         len2 = n2->stlen;
 968
 969         if (len1 == 0)
 970                 return len2 == 0 ? 0 : -1;
 971         if (len2 == 0)
 972                 return 1;
 973
 974         /* len1 > 0 && len2 > 0 */
 975         lmin = len1 < len2 ? len1 : len2;
 976
 977         if (IGNORECASE) {
 978                 const unsigned char *cp1 = (const unsigned char *) s1;
 979                 const unsigned char *cp2 = (const unsigned char *) s2;
 980
 981 #if MBS_SUPPORT
 982                 if (gawk_mb_cur_max > 1) {
 983                         ret = strncasecmpmbs((const unsigned char *) cp1,
 984                                              (const unsigned char *) cp2, lmin);
 985                 } else
 986 #endif
 987                 for (ret = 0; lmin-- > 0 && ret == 0; cp1++, cp2++)
 988                         ret = casetable[*cp1] - casetable[*cp2];
 989                 if (ret != 0)
 990                         return ret;
 991                 /*
 992                  * If case insensitive result is "they're the same",
 993                  * use case sensitive comparison to force distinct order.
 994                  */
 995         }
 996
 997         ret = memcmp(s1, s2, lmin);
 998         if (ret != 0 || len1 == len2)
 999                 return ret;
1000         return (len1 < len2) ? -1 : 1;
1001 }
1002
1003 /* sort_up_index_string --- qsort comparison function; ascending index strings. */
1004
1005 static int
1006 sort_up_index_string(const void *p1, const void *p2)
1007 {
1008         const NODE *t1, *t2;
1009
1010         /* Array indices are strings */
1011         t1 = *((const NODE *const *) p1);
1012         t2 = *((const NODE *const *) p2);
1013         return cmp_strings(t1, t2);
1014 }
1015
1016
1017 /* sort_down_index_str --- qsort comparison function; descending index strings. */
1018
1019 static int
1020 sort_down_index_string(const void *p1, const void *p2)
1021 {
1022         /*
1023          * Negation versus transposed arguments:  when all keys are
1024          * distinct, as with array indices here, either method will
1025          * transform an ascending sort into a descending one.  But if
1026          * there are equal keys--such as when IGNORECASE is honored--
1027          * that get disambiguated into a determisitc order, negation
1028          * will reverse those but transposed arguments would retain
1029          * their relative order within the rest of the reversed sort.
1030          */
1031         return -sort_up_index_string(p1, p2);
1032 }
1033
1034
1035 /* sort_up_index_number --- qsort comparison function; ascending index numbers. */
1036
1037 static int
1038 sort_up_index_number(const void *p1, const void *p2)
1039 {
1040         const NODE *t1, *t2;
1041         int ret;
1042
1043         t1 = *((const NODE *const *) p1);
1044         t2 = *((const NODE *const *) p2);
1045
1046         ret = cmp_numbers(t1, t2);
1047         if (ret != 0)
1048                 return ret;
1049
1050         /* break a tie with the index string itself */
1051         t1 = force_string((NODE *) t1);
1052         t2 = force_string((NODE *) t2);
1053         return cmp_strings(t1, t2);
1054 }
1055
1056 /* sort_down_index_number --- qsort comparison function; descending index numbers */
1057
1058 static int
1059 sort_down_index_number(const void *p1, const void *p2)
1060 {
1061         return -sort_up_index_number(p1, p2);
1062 }
1063
1064
1065 /* sort_up_value_string --- qsort comparison function; ascending value string */
1066
1067 static int
1068 sort_up_value_string(const void *p1, const void *p2)
1069 {
1070         const NODE *t1, *t2;
1071
1072         t1 = *((const NODE *const *) p1 + 1);
1073         t2 = *((const NODE *const *) p2 + 1);
1074
1075         if (t1->type == Node_var_array) {
1076                 /* return 0 if t2 is a sub-array too, else return 1 */
1077                 return (t2->type != Node_var_array);
1078         }
1079         if (t2->type == Node_var_array)
1080                 return -1;              /* t1 (scalar) < t2 (sub-array) */
1081
1082         /* t1 and t2 both have string values */
1083         return cmp_strings(t1, t2);
1084 }
1085
1086
1087 /* sort_down_value_string --- qsort comparison function; descending value string */
1088
1089 static int
1090 sort_down_value_string(const void *p1, const void *p2)
1091 {
1092         return -sort_up_value_string(p1, p2);
1093 }
1094
1095
1096 /* sort_up_value_number --- qsort comparison function; ascending value number */
1097
1098 static int
1099 sort_up_value_number(const void *p1, const void *p2)
1100 {
1101         NODE *t1, *t2;
1102         int ret;
1103
1104         t1 = *((NODE *const *) p1 + 1);
1105         t2 = *((NODE *const *) p2 + 1);
1106
1107         if (t1->type == Node_var_array) {
1108                 /* return 0 if t2 is a sub-array too, else return 1 */
1109                 return (t2->type != Node_var_array);
1110         }
1111         if (t2->type == Node_var_array)
1112                 return -1;              /* t1 (scalar) < t2 (sub-array) */
1113
1114         ret = cmp_numbers(t1, t2);
1115         if (ret != 0)
1116                 return ret;
1117
1118         /*
1119          * Use string value to guarantee same sort order on all
1120          * versions of qsort().
1121          */
1122         t1 = force_string(t1);
1123         t2 = force_string(t2);
1124         return cmp_strings(t1, t2);
1125 }
1126
1127
1128 /* sort_down_value_number --- qsort comparison function; descending value number */
1129
1130 static int
1131 sort_down_value_number(const void *p1, const void *p2)
1132 {
1133         return -sort_up_value_number(p1, p2);
1134 }
1135
1136
1137 /* sort_up_value_type --- qsort comparison function; ascending value type */
1138
1139 static int
1140 sort_up_value_type(const void *p1, const void *p2)
1141 {
1142         NODE *n1, *n2;
1143
1144         /* we want to compare the element values */
1145         n1 = *((NODE *const *) p1 + 1);
1146         n2 = *((NODE *const *) p2 + 1);
1147
1148         /* 1. Arrays vs. scalar, scalar is less than array */
1149         if (n1->type == Node_var_array) {
1150                 /* return 0 if n2 is a sub-array too, else return 1 */
1151                 return (n2->type != Node_var_array);
1152         }
1153         if (n2->type == Node_var_array) {
1154                 return -1;              /* n1 (scalar) < n2 (sub-array) */
1155         }
1156
1157         /* two scalars */
1158         /* 2. Resolve MAYBE_NUM, so that have only NUMBER or STRING */
1159         if ((n1->flags & MAYBE_NUM) != 0)
1160                 (void) force_number(n1);
1161         if ((n2->flags & MAYBE_NUM) != 0)
1162                 (void) force_number(n2);
1163
1164         /* 2.5. Resolve INTIND, so that is STRING, and not NUMBER */
1165         if ((n1->flags & INTIND) != 0)
1166                 (void) force_string(n1);
1167         if ((n2->flags & INTIND) != 0)
1168                 (void) force_string(n2);
1169
1170         if ((n1->flags & NUMBER) != 0 && (n2->flags & NUMBER) != 0) {
1171                 return cmp_numbers(n1, n2);
1172         }
1173
1174         /* 3. All numbers are less than all strings. This is aribitrary. */
1175         if ((n1->flags & NUMBER) != 0 && (n2->flags & STRING) != 0) {
1176                 return -1;
1177         } else if ((n1->flags & STRING) != 0 && (n2->flags & NUMBER) != 0) {
1178                 return 1;
1179         }
1180
1181         /* 4. Two strings */
1182         return cmp_strings(n1, n2);
1183 }
1184
1185 /* sort_down_value_type --- qsort comparison function; descending value type */
1186
1187 static int
1188 sort_down_value_type(const void *p1, const void *p2)
1189 {
1190         return -sort_up_value_type(p1, p2);
1191 }
1192
1193 /* sort_user_func --- user defined qsort comparison function */
1194
1195 static int
1196 sort_user_func(const void *p1, const void *p2)
1197 {
1198         NODE *idx1, *idx2, *val1, *val2, *r;
1199         int ret;
1200         INSTRUCTION *code;
1201
1202         idx1 = *((NODE *const *) p1);
1203         idx2 = *((NODE *const *) p2);
1204         val1 = *((NODE *const *) p1 + 1);
1205         val2 = *((NODE *const *) p2 + 1);
1206
1207         code = TOP()->code_ptr; /* comparison function call instructions */
1208
1209         /* setup 4 arguments to comp_func() */
1210         UPREF(idx1);
1211         PUSH(idx1);
1212         if (val1->type == Node_val)
1213                 UPREF(val1);
1214         PUSH(val1);
1215
1216         UPREF(idx2);
1217         PUSH(idx2);
1218         if (val2->type == Node_val)
1219                 UPREF(val2);
1220         PUSH(val2);
1221
1222         /* execute the comparison function */
1223         (void) (*interpret)(code);
1224
1225         /* return value of the comparison function */
1226         r = POP_NUMBER();
1227 #ifdef HAVE_MPFR
1228         /*
1229          * mpfr_sgn(mpz_sgn): Returns a positive value if op > 0,
1230          * zero if op = 0, and a negative value if op < 0.
1231          */
1232         if (is_mpg_float(r))
1233                 ret = mpfr_sgn(r->mpg_numbr);
1234         else if (is_mpg_integer(r))
1235                 ret = mpz_sgn(r->mpg_i);
1236         else
1237 #endif
1238                 ret = (r->numbr < 0.0) ? -1 : (r->numbr > 0.0);
1239         DEREF(r);
1240         return ret;
1241 }
1242
1243
1244 /* assoc_list -- construct, and optionally sort, a list of array elements */
1245
1246 NODE **
1247 assoc_list(NODE *symbol, const char *sort_str, sort_context_t sort_ctxt)
1248 {
1249         typedef int (*qsort_compfunc)(const void *, const void *);
1250
1251         static const struct qsort_funcs {
1252                 const char *name;
1253                 qsort_compfunc comp_func;
1254                 assoc_kind_t kind;
1255         } sort_funcs[] = {
1256 { "@ind_str_asc",       sort_up_index_string,   AINDEX|AISTR|AASC },
1257 { "@ind_num_asc",       sort_up_index_number,   AINDEX|AINUM|AASC },
1258 { "@val_str_asc",       sort_up_value_string,   AVALUE|AVSTR|AASC },
1259 { "@val_num_asc",       sort_up_value_number,   AVALUE|AVNUM|AASC },
1260 { "@ind_str_desc",      sort_down_index_string, AINDEX|AISTR|ADESC },
1261 { "@ind_num_desc",      sort_down_index_number, AINDEX|AINUM|ADESC },
1262 { "@val_str_desc",      sort_down_value_string, AVALUE|AVSTR|ADESC },
1263 { "@val_num_desc",      sort_down_value_number, AVALUE|AVNUM|ADESC },
1264 { "@val_type_asc",      sort_up_value_type,     AVALUE|AASC },
1265 { "@val_type_desc",     sort_down_value_type,   AVALUE|ADESC },
1266 { "@unsorted",          0,                      AINDEX },
1267 };
1268
1269         /*
1270          * N.B.: AASC and ADESC are hints to the specific array types.
1271          *      See cint_list() in cint_array.c.
1272          */
1273
1274         NODE **list;
1275         NODE akind;
1276         unsigned long num_elems, j;
1277         int elem_size, qi;
1278         qsort_compfunc cmp_func = 0;
1279         INSTRUCTION *code = NULL;
1280         extern int currule;
1281         int save_rule = 0;
1282         assoc_kind_t assoc_kind = ANONE;
1283
1284         elem_size = 1;
1285
1286         for (qi = 0, j = sizeof(sort_funcs)/sizeof(sort_funcs[0]); qi < j; qi++) {
1287                 if (strcmp(sort_funcs[qi].name, sort_str) == 0)
1288                         break;
1289         }
1290
1291         if (qi < j) {
1292                 cmp_func = sort_funcs[qi].comp_func;
1293                 assoc_kind = sort_funcs[qi].kind;
1294
1295                 if (symbol->array_funcs != cint_array_func)
1296                         assoc_kind &= ~(AASC|ADESC);
1297
1298                 if (sort_ctxt != SORTED_IN || (assoc_kind & AVALUE) != 0) {
1299                         /* need index and value pair in the list */
1300
1301                         assoc_kind |= (AINDEX|AVALUE);
1302                         elem_size = 2;
1303                 }
1304
1305         } else {        /* unrecognized */
1306                 NODE *f;
1307                 const char *sp;
1308
1309                 for (sp = sort_str; *sp != '\0' && ! isspace((unsigned char) *sp); sp++)
1310                         continue;
1311
1312                 /* empty string or string with space(s) not valid as function name */
1313                 if (sp == sort_str || *sp != '\0')
1314                         fatal(_("`%s' is invalid as a function name"), sort_str);
1315
1316                 f = lookup(sort_str);
1317                 if (f == NULL || f->type != Node_func)
1318                         fatal(_("sort comparison function `%s' is not defined"), sort_str);
1319
1320                 cmp_func = sort_user_func;
1321
1322                 /* need index and value pair in the list */
1323                 assoc_kind |= (AVALUE|AINDEX);
1324                 elem_size = 2;
1325
1326                 /* make function call instructions */
1327                 code = bcalloc(Op_func_call, 2, 0);
1328                 code->func_body = f;
1329                 code->func_name = NULL;         /* not needed, func_body already assigned */
1330                 (code + 1)->expr_count = 4;     /* function takes 4 arguments */
1331                 code->nexti = bcalloc(Op_stop, 1, 0);
1332
1333                 /*
1334                  * make non-redirected getline, exit, `next' and `nextfile' fatal in
1335                  * callback function by setting currule in interpret()
1336                  * to undefined (0).
1337                  */
1338
1339                 save_rule = currule;    /* save current rule */
1340                 currule = 0;
1341
1342                 PUSH_CODE(code);
1343         }
1344
1345         akind.flags = (unsigned int) assoc_kind;        /* kludge */
1346         list = symbol->alist(symbol, & akind);
1347         assoc_kind = (assoc_kind_t) akind.flags;        /* symbol->alist can modify it */
1348
1349         if (list == NULL || ! cmp_func || (assoc_kind & (AASC|ADESC)) != 0)
1350                 return list;    /* empty list or unsorted, or list already sorted */
1351
1352         num_elems = assoc_length(symbol);
1353
1354         qsort(list, num_elems, elem_size * sizeof(NODE *), cmp_func); /* shazzam! */
1355
1356         if (cmp_func == sort_user_func) {
1357                 code = POP_CODE();
1358                 currule = save_rule;            /* restore current rule */
1359                 bcfree(code->nexti);            /* Op_stop */
1360                 bcfree(code);                   /* Op_func_call */
1361         }
1362
1363         if (sort_ctxt == SORTED_IN && (assoc_kind & (AINDEX|AVALUE)) == (AINDEX|AVALUE)) {
1364                 /* relocate all index nodes to the first half of the list. */
1365                 for (j = 1; j < num_elems; j++)
1366                         list[j] = list[2 * j];
1367
1368                 /* give back extra memory */
1369
1370                 erealloc(list, NODE **, num_elems * sizeof(NODE *), "assoc_list");
1371         }
1372
1373         return list;
1374 }