nl-list.c

   1 /* n-list.c
   2
   3     Copyright (C) 2008 Lutz Mueller
   4
   5     This program is free software: you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation, either version 3 of the License, or
   8     (at your option) any later version.
   9
  10     This program is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 */
  19
  20
  21 #include "newlisp.h"
  22 #include "protos.h"
  23 #include <search.h>
  24
  25 extern SYMBOL * starSymbol;
  26 extern SYMBOL * plusSymbol;
  27 extern SYMBOL * sysSymbol[];
  28
  29 extern CELL * firstFreeCell;
  30
  31 /* following used in count, difference, intersect, uniwue and sort 8.6.2 */
  32 CELL * * listToSortedVector(CELL * list, ssize_t * length, CELL * func, int indexFlag);
  33 CELL * resortVectorToList(CELL * * vector, ssize_t length);
  34 void binsort(CELL * * x, ssize_t n, CELL * pCell);
  35
  36
  37 CELL * p_map(CELL * params)
  38 {
  39 CELL * argsPtr;
  40 CELL * arg;
  41 CELL * sPtr;
  42 CELL * cell;
  43 CELL * expr;
  44 CELL * results;
  45 CELL * res;
  46 CELL * qCell;
  47 int resultIdxSave;
  48
  49 sPtr = evaluateExpression(params);
  50
  51 /* get first of argument lists */
  52 params = params->next;
  53 argsPtr = cell = copyCell(evaluateExpression(params));
  54 if(!isList(cell->type))
  55         return(errorProcExt(ERR_LIST_EXPECTED, params));
  56
  57 while ((params = params->next) != nilCell)
  58         {
  59         cell->next = copyCell(evaluateExpression(params));
  60         cell = cell->next;
  61
  62         if(!isList(cell->type))
  63             return(errorProcExt(ERR_LIST_EXPECTED, params));
  64         }
  65
  66 results = getCell(CELL_EXPRESSION);
  67 res = NULL;
  68 resultIdxSave = resultStackIdx;
  69 while(argsPtr->contents != (UINT)nilCell) /* for all instances of a arg */
  70         {
  71         expr = getCell(CELL_EXPRESSION);
  72         cell = copyCell(sPtr);
  73         expr->contents = (UINT)cell;
  74         arg = argsPtr;
  75         while(arg != nilCell)              /* for all args */
  76                 {
  77                 qCell = getCell(CELL_QUOTE);
  78                 cell->next = qCell;
  79                 cell = (CELL *)arg->contents; /* pop out first */
  80                 arg->contents = (UINT)cell->next;
  81                 qCell->contents = (UINT)cell;
  82                 cell->next = nilCell;
  83                 cell = qCell;
  84                 arg = arg->next;
  85                 }
  86         cell = copyCell(evaluateExpression(expr));
  87         deleteList(expr);
  88         cleanupResults(resultIdxSave);
  89         if(res == NULL)
  90                 results->contents = (UINT)cell;
  91         else
  92                 res->next = cell;
  93         res = cell;
  94         }
  95 deleteList(argsPtr);
  96 return(results);
  97 }
  98
  99
 100 CELL * explodeList(CELL * list, CELL * params)
 101 {
 102 ssize_t len = 1;
 103 ssize_t count = 1;
 104 CELL * cell = NULL;
 105 CELL * last = NULL;
 106 CELL * result = NULL;
 107 CELL * * lastChunk = NULL;
 108 int flag = FALSE;
 109
 110 if(params != nilCell)
 111         {
 112         params = getInteger(params, (UINT*)&len);
 113         flag = getFlag(params);
 114         }
 115
 116 result = getCell(CELL_EXPRESSION);
 117
 118 if(len <= 0) return(result);
 119
 120 while(list != nilCell)
 121         {
 122         if(result->contents == (UINT)nilCell)
 123                 {
 124                 cell = getCell(CELL_EXPRESSION);
 125                 lastChunk = (CELL * *)&result->contents;
 126                 result->contents = (UINT)cell;
 127                 cell->contents = (UINT)copyCell(list);
 128                 last = (CELL*)cell->contents;
 129                 }
 130         else
 131                 {
 132                 if(count < len)
 133                         {
 134                         last->next = copyCell(list);
 135                         last = last->next;
 136                         count++;
 137                         }
 138                 else
 139                         {
 140                         cell->next = getCell(CELL_EXPRESSION);
 141                         lastChunk = (CELL * *)&cell->next;
 142                         cell = cell->next;
 143                         cell->contents = (UINT)copyCell(list);
 144                         last = (CELL*)cell->contents;
 145                         count = 1;
 146                         }
 147
 148                 }
 149         list = list->next;
 150         }
 151
 152 if(flag && count < len)
 153         {
 154         if(lastChunk)
 155                 {
 156                 deleteList(*lastChunk);
 157                 *lastChunk = nilCell;
 158                 }
 159         }
 160
 161 return(result);
 162 }
 163
 164
 165 /* ---------------------- set primitives --------------------------------- */
 166
 167 CELL * setInterDiff(CELL * params, int mode);
 168
 169
 170 #define SET_INTER 0
 171 #define SET_DIFF 1
 172 #define SET_UNIQUE 2
 173
 174 CELL * p_intersect(CELL * params)
 175 {
 176 if(params->next == nilCell)
 177         return(setInterDiff(params, SET_UNIQUE));
 178 else
 179         return(setInterDiff(params, SET_INTER));
 180 }
 181
 182 CELL * p_difference(CELL * params)
 183 {
 184 return(setInterDiff(params, SET_DIFF));
 185 }
 186
 187
 188 CELL * p_unique(CELL * params)
 189 {
 190 return(setInterDiff(params, SET_UNIQUE));
 191 }
 192
 193
 194 /* new very fast version in 8.6.2 */
 195
 196 CELL * setInterDiff(CELL * params, int mode)
 197 {
 198 CELL * listA;
 199 CELL * listB = NULL;
 200 CELL * * vectorA;
 201 CELL * * vectorB = NULL;
 202 CELL * * vectorResult;
 203 ssize_t lengthA, lengthB;
 204 ssize_t i = 0, j = 0, k = 0, top = 0;
 205 CELL * cell = NULL;
 206 CELL * result;
 207 int listMode = FALSE;
 208 int cmp, flag = FALSE;
 209
 210 params = getListHead(params, &listA);
 211 if(listA == nilCell)
 212         return(getCell(CELL_EXPRESSION));
 213
 214 if(mode != SET_UNIQUE)
 215         {
 216         params = getListHead(params, &listB);
 217         listMode = getFlag(params);
 218
 219     if(listA == listB)
 220         {
 221         flag = TRUE;
 222         listA = copyList(listB);
 223         }
 224
 225         if(listB == nilCell)
 226                 {
 227                 if(mode == SET_INTER)
 228                         return(getCell(CELL_EXPRESSION));
 229                 listB = NULL;
 230                 }
 231         }
 232
 233 vectorA = listToSortedVector(listA, &lengthA, NULL, TRUE);
 234
 235 vectorResult = callocMemory(lengthA * sizeof(CELL *));
 236
 237 if(listB)
 238     vectorB = listToSortedVector(listB, &lengthB, NULL, 0);
 239
 240 result = getCell(CELL_EXPRESSION);
 241
 242 while(i < lengthA)
 243     {
 244     if(listB) switch(mode)
 245         {
 246         case SET_INTER:
 247             cmp = compareCells(vectorA[i], vectorB[j]);
 248             if(cmp == 0) break;
 249             if(cmp < 0)
 250                 {
 251                 ++i;
 252                 continue;
 253                 }
 254             if(j < (lengthB - 1)) ++j;
 255             else ++i;
 256             continue;
 257
 258         case SET_DIFF:
 259             cmp = compareCells(vectorA[i], vectorB[j]);
 260             if(cmp == 0)
 261                 {
 262                 ++i;
 263                 continue;
 264                 }
 265             if(cmp < 0) break;
 266             if(j < (lengthB - 1)) ++j;
 267             else break;
 268
 269             continue;
 270
 271         case SET_UNIQUE:
 272         default:
 273             break;
 274         }
 275
 276     /* if not in result or if list mode is specified */
 277     if( (k == 0) || (compareCells(vectorA[i], vectorResult[top]) != 0) || (listMode == TRUE) )
 278         {
 279         top = k;
 280         vectorResult[k++] = vectorA[i];
 281         }
 282
 283     ++i;
 284     }
 285
 286
 287 if(k > 0)
 288     {
 289     binsort(vectorResult, k, (CELL*)0xFFFFFFFF);
 290     cell = copyCell(vectorResult[0]);
 291     result->contents = (UINT)cell;
 292
 293     /* relinking */
 294     for(i = 1; i < k; i++)
 295         {
 296         cell->next = copyCell(vectorResult[i]);
 297         cell = cell->next;
 298         }
 299     cell->next = nilCell;
 300     }
 301
 302 free(vectorResult);
 303
 304 cell = resortVectorToList(vectorA, lengthA);
 305
 306 if(vectorB) free(vectorB);
 307
 308 if(flag) deleteList(listA);
 309
 310 return(result);
 311 }
 312
 313 /* ----------------------------------------------------------------------- */
 314
 315 CELL * p_match(CELL * params)
 316 {
 317 CELL * cell;
 318 CELL * next;
 319 CELL * result;
 320
 321 cell = evaluateExpression(params);
 322 if(!isList(cell->type)) return(nilCell);
 323 params = params->next;
 324 next = evaluateExpression(params);
 325 if(!isList(next->type)) return(nilCell);
 326
 327 result = patternMatchL((CELL *)cell->contents, (CELL *)next->contents, getFlag(params->next));
 328 if(result) return(result);
 329 return(getCell(CELL_EXPRESSION));
 330 }
 331
 332
 333 CELL * linkMatches(CELL * * matchList, CELL * matchPtr, CELL * elmnt)
 334 {
 335 if(*matchList == NULL)
 336     {
 337     *matchList = getCell(CELL_EXPRESSION);
 338     (*matchList)->contents = (UINT)elmnt;
 339     matchPtr = (CELL *)(*matchList)->contents;
 340     }
 341 else
 342     {
 343     matchPtr->next = elmnt;
 344     }
 345
 346 while(matchPtr->next != nilCell)
 347         matchPtr = matchPtr->next;
 348
 349 return(matchPtr);
 350 }
 351
 352
 353 CELL * patternMatchL(CELL * pattern, CELL * list, int flag)
 354 {
 355 CELL * match;
 356 CELL * matchList = NULL;
 357 CELL * matches = NULL;
 358 CELL * starList = NULL;
 359 CELL * stars = NULL;
 360
 361 MATCH_LIST:
 362 switch(pattern->type)
 363         {
 364         case CELL_NIL:
 365         /* end of pattern and list */
 366         if(list->type == CELL_NIL)
 367                 {
 368                 if(starList) deleteList(starList);
 369                 return(matchList);
 370                 }
 371
 372         goto NO_MATCH_RETURN;
 373
 374         case CELL_QUOTE:
 375         case CELL_EXPRESSION:
 376         case CELL_MACRO:
 377         case CELL_LAMBDA:
 378                 /* compare subexpressions */
 379                 if(list->type == pattern->type)
 380                         {
 381                         if((match = patternMatchL((CELL*)pattern->contents, (CELL*)list->contents, flag)) != nilCell)
 382                                 {
 383                                 if(match != NULL)
 384                                         {
 385                                         if(flag)
 386                                                 matches = linkMatches(&matchList, matches, match);
 387                                         else
 388                                                 {
 389                                                 matches = linkMatches(&matchList, matches, (CELL*)match->contents);
 390                                                 match->contents = (UINT)nilCell;
 391                                                 deleteList(match);
 392                                                 }
 393                                         }
 394                                 pattern = pattern->next;
 395                                 list = list->next;
 396                                 goto MATCH_LIST;
 397                                 }
 398                         }
 399
 400                 goto NO_MATCH_RETURN;
 401
 402         case CELL_SYMBOL:
 403                 if(pattern->contents == (UINT)questionSymbol)   /* '?' */
 404                         {
 405                         if(list == nilCell) goto NO_MATCH_RETURN;
 406                         if(!flag) matches = linkMatches(&matchList, matches, copyCell(list));
 407                         break;
 408                         }
 409
 410                 if(pattern->contents == (UINT)starSymbol ||
 411                    pattern->contents == (UINT)plusSymbol)       /* '*'  and '+' */
 412                         {
 413                         if(starList == NULL)
 414                                 {
 415                                 starList = getCell(CELL_EXPRESSION);
 416                                 }
 417
 418                         if(stars == NULL && pattern->contents == (UINT)plusSymbol)
 419                                 goto WILD_CARD_GREP;
 420
 421                         if(pattern->next == nilCell)
 422                                 {
 423                                 if(stars == NULL)
 424                                         starList->contents = (UINT)copyList(list);
 425                                 else
 426                                         stars->next = copyList(list);
 427
 428                                 linkMatches(&matchList, matches, starList);
 429                                 return(matchList);
 430                                 }
 431
 432                         if((match = patternMatchL(pattern->next, list, flag)) != nilCell)
 433                                 {
 434                                 matches = linkMatches(&matchList, matches, starList);
 435                                 if(match != NULL)
 436                                         {
 437                                         matches->next = (CELL*)match->contents;
 438                                         match->contents = (UINT)nilCell;
 439                                         deleteList(match);
 440                                         }
 441                                 return(matchList);
 442                                 }
 443
 444                         if(list->next == nilCell)
 445                         goto NO_MATCH_RETURN;
 446
 447 WILD_CARD_GREP:
 448                         if(pattern->contents == (UINT)plusSymbol)
 449                                 if(list == nilCell) goto NO_MATCH_RETURN;
 450
 451                         if(stars == NULL)
 452                                 {
 453                                 starList->contents = (UINT)copyCell(list);
 454                                 stars = (CELL*)starList->contents;
 455                                 }
 456                         else
 457                                 {
 458                                 stars->next = copyCell(list);
 459                                 stars = stars->next;
 460                                 }
 461
 462                         list = list->next;
 463                         goto MATCH_LIST;
 464                         }
 465         default:
 466                 if(compareCells(pattern, list) != 0)
 467                 goto NO_MATCH_RETURN;
 468
 469                 break;
 470         }
 471
 472 if(flag) matches = linkMatches(&matchList, matches, copyCell(list));
 473
 474
 475 pattern = pattern->next;
 476 list = list->next;
 477 goto MATCH_LIST;
 478
 479 NO_MATCH_RETURN:
 480 if(starList != NULL) deleteList(starList);
 481 if(matchList != NULL) deleteList(matchList);
 482 return(nilCell);
 483 }
 484
 485
 486 CELL * p_assoc(CELL * params)
 487 {
 488 CELL * key;
 489 CELL * eKey;
 490 CELL * list;
 491
 492 if(params->type == CELL_EXPRESSION && params->next == nilCell)
 493         {
 494         key = getList(params, &list, FALSE);
 495         list = (CELL *)list->contents;
 496
 497         while(key != nilCell)
 498                 {
 499                 eKey = evaluateExpression(key);
 500                 while(list != nilCell)
 501                         {
 502                         if(isList(list->type))
 503                                 if(compareCells(eKey, (CELL *)list->contents) == 0) break;
 504                         list = list->next;
 505                         }
 506
 507                 if((key = key->next) == nilCell) break;
 508                 list = ((CELL *)list->contents)->next;
 509                 }
 510         }
 511 else
 512         {
 513         key = evaluateExpression(params);
 514         getListHead(params->next, &list);
 515         while(list != nilCell)
 516                 {
 517                 if(isList(list->type))
 518                         if(compareCells(key, (CELL *)list->contents) == 0) break;
 519                 list = list->next;
 520                 }
 521         }
 522
 523 if(list == nilCell) return(nilCell);
 524 return(copyCell(list));
 525 }
 526
 527
 528 CELL * p_lookup(CELL * params)
 529 {
 530 CELL * key;
 531 CELL * list;
 532 ssize_t index;
 533
 534 key = evaluateExpression(params);
 535 params = getListHead(params->next, &list);
 536
 537 while(list != nilCell)
 538         {
 539         if(isList(list->type))
 540                 if(compareCells(key, (CELL *)list->contents) == 0) break;
 541         list = list->next;
 542         }
 543
 544 if(list == nilCell) return(nilCell);
 545
 546 list = (CELL*)list->contents;
 547
 548 if(params != nilCell)
 549         getInteger(params, (UINT *)&index);
 550 else index = -1;
 551
 552 if(index < 0) index = convertNegativeOffset(index, list);
 553
 554 while(index--)
 555         {
 556         if(list->next == nilCell) break;
 557         list = list->next;
 558         }
 559
 560 return(copyCell(list));
 561 }
 562
 563 /* bind and association list, works like:
 564    (define (bind L) (dolist (i L) (apply set i)))
 565    L => ((x 1) (y 2) (z 3))
 566 */
 567
 568 CELL * p_bind(CELL * params)
 569 {
 570 SYMBOL * lref = NULL;
 571 CELL * list;
 572 CELL * cell;
 573 int evalFlag;
 574
 575 params = getListHead(params, &list);
 576 evalFlag = getFlag(params);
 577
 578 while(list != nilCell)
 579         {
 580         if(list->type != CELL_EXPRESSION)
 581                 return(errorProcExt(ERR_LIST_EXPECTED, list));
 582
 583         cell = (CELL *)list->contents;
 584         lref = getSymbolCheckProtected(cell);
 585         deleteList((CELL *)lref->contents);
 586         if(evalFlag)
 587                 lref->contents = (UINT)copyCell(evaluateExpression(cell->next));
 588         else
 589                 lref->contents = (UINT)copyCell(cell->next);
 590         list = list->next;
 591         }
 592
 593 if(lref == NULL)
 594         return(nilCell);
 595
 596 return(copyCell((CELL *)lref->contents));
 597 }
 598
 599 #ifdef WIN_32
 600 CELL * p_count(CELL * params)
 601 {
 602 CELL * items;
 603 CELL * list;
 604 CELL * result;
 605 CELL * * vectorItems;
 606 CELL * * vectorList;
 607 ssize_t lengthItems, lengthList;
 608 ssize_t i = 0, j = 0, idx;
 609 int cmp;
 610 int flag = FALSE;
 611 CELL * cell;
 612 ssize_t * counts;
 613
 614 params = getListHead(params, &items);
 615 getListHead(params, &list);
 616
 617 result = getCell(CELL_EXPRESSION);
 618
 619 if(items == nilCell)
 620         return(result);
 621
 622 if(items == list)
 623         {
 624         flag = TRUE;
 625         items = copyList(list);
 626         }
 627
 628 vectorItems = listToSortedVector(items, &lengthItems, NULL, TRUE);
 629 vectorList = listToSortedVector(list, &lengthList, NULL, TRUE);
 630
 631 counts = (ssize_t *)callocMemory(lengthItems * sizeof(ssize_t));
 632
 633 if(vectorList)
 634 while(i < lengthList)
 635         {
 636         cmp = compareCells(vectorList[i], vectorItems[j]);
 637         if(cmp == 0)
 638                 {
 639                 idx = (ssize_t)vectorItems[j]->next;
 640                 counts[idx] += 1;
 641                 ++i;
 642                 continue;
 643                 }
 644         if(cmp < 0)
 645                 {
 646                 ++i;
 647                 continue;
 648                 }
 649         if(j < (lengthItems - 1)) j++;
 650         else i++;
 651         }
 652
 653
 654 cell = stuffInteger(counts[0]);
 655 result->contents = (UINT)cell;
 656 for(i = 1; i < lengthItems; i++)
 657         {
 658         cell->next = stuffInteger(counts[i]);
 659         cell = cell->next;
 660         }
 661 freeMemory(counts);
 662
 663 cell = resortVectorToList(vectorItems, lengthItems);
 664 if(vectorList) cell = resortVectorToList(vectorList, lengthList);
 665
 666 if(flag) deleteList(items);
 667
 668 return(result);
 669 }
 670
 671 #else /* Mac OS X and other UNIX */
 672
 673 typedef struct
 674         {
 675         UINT type;
 676         UINT next;
 677         UINT aux;
 678         UINT contents;
 679         } COUNTCELL;
 680
 681 CELL * p_count(CELL * params)
 682 {
 683 CELL * items;
 684 CELL * list;
 685 CELL * result;
 686 CELL * * counts;
 687 ssize_t lengthItems;
 688 ssize_t i = 0;
 689 int flag = FALSE;
 690 CELL * cell;
 691 COUNTCELL * count;
 692 void * root = NULL;
 693 void * key;
 694
 695 params = getListHead(params, &items);
 696 getListHead(params, &list);
 697
 698 result = getCell(CELL_EXPRESSION);
 699
 700 if(items == nilCell)
 701         return(result);
 702
 703 if(items == list)
 704         {
 705         flag = TRUE;
 706         items = copyList(list);
 707         }
 708
 709 lengthItems = listlen(items);
 710 counts = (CELL * *)callocMemory(lengthItems * sizeof(CELL *));
 711
 712 cell = items;
 713 for(i = 0; i < lengthItems; i++)
 714         {
 715         counts[i] = copyCell(cell);
 716         counts[i]->next = NULL;
 717         key = tsearch(counts[i], &root, (int (*)(const void *, const void *))compareCells);
 718         if(key == NULL)
 719                 errorProc(ERR_NOT_ENOUGH_MEMORY);
 720         cell = cell->next;
 721         }
 722
 723 cell = list;
 724 while(cell != nilCell)
 725         {
 726         key = tfind(cell, &root, (int (*)(const void *, const void *))compareCells);
 727         if(key != NULL)
 728                 {
 729                 count = (COUNTCELL *)*(CELL * *)key;
 730                 count->next++;
 731                 }
 732         cell = cell->next;
 733         }
 734
 735 cell = stuffInteger((UINT)counts[0]->next);
 736 result->contents = (UINT)cell;
 737 for(i = 1; i < lengthItems; i++)
 738         {
 739         cell->next = stuffInteger((UINT)counts[i]->next);
 740         cell = cell->next;
 741         }
 742
 743 for(i = 0; i < lengthItems; i++)
 744         {
 745         counts[i]->next = nilCell;
 746         deleteList(counts[i]);
 747         }
 748
 749 freeMemory(counts);
 750 if(flag) deleteList(items);
 751
 752 return(result);
 753 }
 754
 755 #endif
 756
 757
 758 CELL * p_replaceAssoc(CELL * params)
 759 {
 760 CELL * key;
 761 CELL * repList;
 762 CELL * list;
 763 CELL * cell;
 764 CELL * previous = NULL;
 765
 766 key = evaluateExpression(params);
 767 params = params->next;
 768
 769 cell = evalCheckProtected(params, NULL);
 770
 771 if(!isList(cell->type))
 772         return(errorProcExt(ERR_LIST_EXPECTED, cell));
 773
 774 cell->aux = (UINT)nilCell; /* undo last element optimization */
 775
 776 if(isList(cell->type))
 777         {
 778         list = (CELL *)cell->contents;
 779
 780         while(list != nilCell)
 781                 {
 782                 if(isList(list->type))
 783                         if(compareCells(key, (CELL *)list->contents) == 0)
 784                                 {
 785                                 deleteList((CELL*)sysSymbol[0]->contents);
 786                                 sysSymbol[0]->contents = (UINT)copyCell(list);
 787                                 /* deleteList((CELL *)list->contents); */
 788                                 if(params->next != nilCell)
 789                                         {
 790                                         getListHead(params->next, &repList);
 791                                         deleteList((CELL *)list->contents);
 792                                         list->contents = (UINT)copyList(repList);
 793                                         }
 794                                 else /* if no replacement given, remove association found */
 795                                         {
 796                                         deleteList((CELL *)list->contents);
 797                                         list->contents = (UINT)nilCell;
 798                                         if(previous == NULL)
 799                                                 cell->contents = (UINT)list->next;
 800                                         else
 801                                                 previous->next = list->next;
 802                                         list->next = nilCell;
 803                                         deleteList(list);
 804                                         }
 805                                 return(copyCell(cell));
 806                                 }
 807                 previous = list;
 808                 list = list->next;
 809                 }
 810         }
 811
 812 return(nilCell);
 813 }
 814
 815
 816 #define SET_ASSOC 0
 817 #define ASSOC_SET 1
 818 #define POP_ASSOC 2
 819
 820 CELL * setAssoc(CELL * params, int mode)
 821 {
 822 CELL * key;
 823 CELL * eKey;
 824 CELL * repList;
 825 CELL * list;
 826 CELL * original = NULL;
 827 CELL * previous = NULL;
 828
 829 if(params->type != CELL_EXPRESSION)
 830         return(errorProcExt(ERR_SYNTAX_WRONG, params));
 831
 832 key = getList(params, &list, TRUE);
 833 list->aux = (UINT)nilCell; /* undo last element optimization */
 834 original = list;
 835 list = (CELL *)list->contents;
 836
 837 while(key != nilCell)
 838         {
 839         eKey = evaluateExpression(key);
 840         while(list != nilCell)
 841                 {
 842                 if(isList(list->type))
 843                         if(compareCells(eKey, (CELL *)list->contents) == 0) break;
 844                 previous = list;
 845                 list = list->next;
 846                 }
 847
 848         if((key = key->next) == nilCell) break;
 849         previous = (CELL *)list->contents;
 850         list = ((CELL *)list->contents)->next;
 851         }
 852
 853 if(list == nilCell) return(nilCell); /* key not found */
 854
 855 if(mode == POP_ASSOC)
 856         {
 857         if(previous == NULL)
 858                 original->contents = (UINT)list->next;
 859         else
 860                 previous->next = list->next;
 861         list->next = nilCell;
 862         return(list);
 863         }
 864
 865 deleteList((CELL*)sysSymbol[0]->contents);
 866 sysSymbol[0]->contents = (UINT)copyCell(list);
 867
 868 if(params->next != nilCell)
 869         {
 870         getListHead(params->next, &repList);
 871         deleteList((CELL *)list->contents);
 872         list->contents = (UINT)copyList(repList);
 873         }
 874
 875 if(mode == SET_ASSOC)
 876         return(copyCell(original));
 877
 878 return(copyCell((CELL *)sysSymbol[0]->contents));
 879 }
 880
 881
 882 CELL * p_setAssoc(CELL * params)
 883 {
 884 return(setAssoc(params, SET_ASSOC));
 885 }
 886
 887
 888 CELL * p_assocSet(CELL * params)
 889 {
 890 return(setAssoc(params, ASSOC_SET));
 891 }
 892
 893 CELL * p_popAssoc(CELL * params)
 894 {
 895 return(setAssoc(params, POP_ASSOC));
 896 }
 897
 898
 899 void binsort(CELL * * x, ssize_t n, CELL * pCell)
 900 {
 901 ssize_t i,j,k,l,m,kf,lf;
 902 CELL * expr;
 903 CELL * cell;
 904 int resultIndexSave;
 905 jmp_buf errorJumpSave;
 906 int errNo;
 907 CELL * * y;
 908
 909 y = allocMemory(n * sizeof(CELL *));
 910
 911 m = 1;
 912 while(m < n)
 913         {
 914         for(i = 0; i < n; i += 2*m)
 915                 {
 916                 k = i; l = i + m;
 917                 if(l >= n)
 918                         {
 919                         kf = lf = n;
 920                         l = lf + 1;
 921                         }
 922                 else
 923                         {
 924                         kf = k + m - 1;
 925                         lf = l + m - 1;
 926                         }
 927
 928                 if(lf >= n) lf = n - 1;
 929
 930                 for(j = i; j <= lf; j++)
 931                         {
 932                         if(k > kf)
 933                                 {
 934                                 y[j] = x[l++];
 935                                 continue;
 936                                 }
 937                         if(l > lf)
 938                                 {
 939                                 y[j] = x[k++];
 940                                 continue;
 941                                 }
 942
 943                         if(pCell == NULL)
 944                                 {
 945                                 if(compareCells((CELL*)x[k], (CELL*)x[l]) <= 0)
 946                                         y[j] = x[k++];
 947                                 else
 948                                         y[j] = x[l++];
 949                                 continue;
 950                                 }
 951                         if(pCell == (CELL*)0xFFFFFFFF)
 952                                 {
 953                             if(((CELL*)x[k])->next <= ((CELL*)x[l])->next)
 954                                         y[j] = x[k++];
 955                                 else
 956                                         y[j] = x[l++];
 957                                 continue;
 958                                 }
 959
 960                         resultIndexSave = resultStackIdx;
 961                         expr = getCell(CELL_EXPRESSION);
 962                         expr->contents = (UINT)copyCell(pCell);
 963                         cell = (CELL *)expr->contents;
 964                         cell->next = getCell(CELL_QUOTE);
 965                         ((CELL *)cell->next)->contents = (UINT)copyCell((CELL*)x[k]);
 966                         cell = cell->next;
 967                         cell->next = getCell(CELL_QUOTE);
 968                         ((CELL *)cell->next)->contents = (UINT)copyCell((CELL*)x[l]);
 969
 970                         /* do result stack cleanup, and free memory under
 971                            error conditions */
 972                         memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
 973                         if((errNo = setjmp(errorJump)) != 0)
 974                                 {
 975                                 memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
 976                                 deleteList(expr);
 977                                 cleanupResults(resultIndexSave);
 978                                 free(x); /* allocates by parent routine */
 979                                 free(y);
 980                                 longjmp(errorJump, errNo);
 981                                 }
 982
 983                         cell = evaluateExpression(expr);
 984
 985                         memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
 986                         if(!isNil(cell) && !isEmpty(cell))
 987                                 y[j] = x[k++];
 988                         else
 989                                 y[j] = x[l++];
 990
 991                         deleteList(expr);
 992                         cleanupResults(resultIndexSave);
 993                         }
 994                 }
 995
 996         for(i = 0; i < n; i++) x[i] = y[i];
 997         m = m * 2;
 998         }
 999
1000 free(y);
1001 }
1002
1003 CELL * * listToSortedVector(CELL * list, ssize_t * length, CELL * func, int indexFlag);
1004
1005 CELL * p_sort(CELL * params)
1006 {
1007 CELL * list;
1008 CELL * * vector;
1009 ssize_t length, i;
1010
1011 list = params;
1012
1013 params = evalCheckProtected(params, NULL);
1014
1015 if(isList(params->type))
1016         {
1017         if(params->contents == (UINT)nilCell)
1018                 return(getCell(CELL_EXPRESSION));
1019
1020         params->aux = (UINT)nilCell; /* undo last element optimization */
1021
1022         vector = listToSortedVector((CELL *)params->contents, &length, list->next, 0);
1023
1024         /* relink cells */
1025         list = vector[0];
1026         --length;
1027         i = 1;
1028         while(length--)
1029                 {
1030                 list->next = vector[i];
1031                 list = list->next;
1032                 i++;
1033                 }
1034         list->next = nilCell;
1035
1036         params->contents = (UINT)vector[0];
1037         freeMemory(vector);
1038         }
1039 else if(isArray(params->type))
1040         {
1041         vector = (CELL **)params->contents;
1042         length = (params->aux - 1) / sizeof(UINT);
1043         if(list->next == nilCell)
1044                 binsort(vector, length, NULL);
1045         else
1046                 binsort(vector, length, list->next);
1047         }
1048 else
1049         return(errorProcExt(ERR_LIST_OR_ARRAY_EXPECTED, list));
1050
1051 return(copyCell(params));
1052 }
1053
1054
1055 CELL * * listToSortedVector(CELL * list, ssize_t * length, CELL * func, int indexFlag)
1056 {
1057 CELL * * vector;
1058 CELL * prev;
1059 ssize_t i;
1060
1061 if((*length = listlen(list)) == 0) return(NULL);
1062
1063 /* build vector */
1064 vector = allocMemory(*length * sizeof(CELL *));
1065 for(i = 0; i < *length; i++)
1066         {
1067         vector[i] = prev = list;
1068         list = list->next;
1069         if(indexFlag) prev->next = (void *)i;
1070         }
1071
1072 if(func != nilCell && func != NULL)
1073     {
1074         func = evaluateExpression(func);
1075     if(func->type == CELL_SYMBOL)
1076         func = (CELL*)((SYMBOL *)func->contents)->contents;
1077     binsort(vector, *length, func);
1078     }
1079 else
1080     binsort(vector, *length, NULL);
1081
1082 return(vector);
1083 }
1084
1085
1086 CELL * resortVectorToList(CELL * * vector, ssize_t length)
1087 {
1088 CELL * list;
1089 ssize_t i;
1090
1091 binsort(vector, length, (CELL*)0xFFFFFFFF);
1092 list  = vector[0];
1093 for(i = 1; i < length; i++)
1094         {
1095         list->next = vector[i];
1096         list = list->next;
1097         }
1098 list->next = nilCell;
1099 list = vector[0];
1100 free(vector);
1101
1102 return(list);
1103 }
1104
1105 /* called with params containing the indices
1106    or list of indices */
1107
1108 CELL * implicitIndexList (CELL * list, CELL * params)
1109 {
1110 CELL * cell;
1111 ssize_t index;
1112 int evalFlag;
1113
1114 cell = evaluateExpression(params);
1115 if(isNumber(cell->type))
1116         {
1117         getIntegerExt(cell, (UINT *)&index, FALSE);
1118         params = params->next;
1119         evalFlag = TRUE;
1120         }
1121 else if(isList(cell->type))
1122         {
1123         params = (CELL*)cell->contents;
1124         params = getIntegerExt(params, (UINT *)&index, FALSE);
1125         evalFlag = FALSE;
1126         }
1127 else return(errorProcExt(ERR_LIST_OR_NUMBER_EXPECTED, params));
1128
1129 while(isList(list->type))
1130         {
1131         /* last element optimization */
1132         if(index == -1 && list->aux != (UINT)nilCell)
1133                 list = (CELL *)list->aux;
1134         else
1135                 {
1136                 list = (CELL *)list->contents;
1137                 if(index < 0)
1138                         index = convertNegativeOffset(index, list);
1139
1140                 while(index--)  list = list->next;
1141
1142                 if(list == nilCell)
1143                         errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
1144                 }
1145
1146         if(params == nilCell || !isList(list->type))  break;
1147         params = getIntegerExt(params, (UINT *)&index, evalFlag);
1148         }
1149
1150 return(list);
1151 }
1152
1153
1154 CELL * p_sequence(CELL * params)
1155 {
1156 double fromFlt, toFlt, interval, step, cntFlt;
1157 INT64 fromInt64, toInt64, stepCnt, i;
1158 CELL * sequence;
1159 CELL * cell;
1160 int intFlag;
1161
1162 if((intFlag = (((CELL*)params->next)->next == nilCell)))
1163         {
1164         params = getInteger64(params, &fromInt64);
1165         getInteger64(params, &toInt64);
1166         stepCnt = (fromInt64 > toInt64) ? fromInt64 - toInt64 : toInt64 - fromInt64;
1167         cell = stuffInteger64(fromInt64);
1168         }
1169 else
1170         {
1171         params = getFloat(params, &fromFlt);
1172         params = getFloat(params, &toFlt);
1173         getFloat(params, &step);
1174
1175         if(isnan(fromFlt) || isnan(toFlt) || isnan(step))
1176                 return(errorProc(ERR_INVALID_PARAMETER_NAN));
1177
1178         step = (step < 0) ? -step : step;
1179         step = (fromFlt > toFlt) ? -step : step;
1180         cntFlt = (fromFlt < toFlt) ? (toFlt - fromFlt)/step : (fromFlt - toFlt)/step;
1181         stepCnt = (cntFlt > 0.0) ? floor(cntFlt + 0.0000000001) : floor(-cntFlt + 0.0000000001);
1182         cell = stuffFloat(&fromFlt);
1183         }
1184
1185 sequence = getCell(CELL_EXPRESSION);
1186 sequence->contents = (UINT)cell;
1187
1188 for(i = 1; i <= stepCnt; i++)
1189         {
1190         if(intFlag)
1191                 {
1192                 if(fromInt64 > toInt64)
1193                         cell->next = stuffInteger(fromInt64 - i);
1194                 else
1195                         cell->next = stuffInteger(fromInt64 + i);
1196                 }
1197         else
1198                 {
1199                 interval = fromFlt + i * step;
1200                 cell->next = stuffFloat(&interval);
1201                 }
1202         cell = cell->next;
1203         }
1204
1205 return(sequence);
1206 }
1207
1208
1209 #define FILTER_FILTER 0
1210 #define FILTER_INDEX 1
1211 #define FILTER_CLEAN 2
1212 #define FILTER_FOR_ALL 3
1213 #define FILTER_EXISTS 4
1214
1215 CELL * filterIndex(CELL * params, int mode);
1216
1217 CELL * p_filter(CELL * params)
1218 {
1219 return filterIndex(params, FILTER_FILTER);
1220 }
1221
1222 CELL * p_index(CELL * params)
1223 {
1224 return filterIndex(params, FILTER_INDEX);
1225 }
1226
1227 CELL * p_clean(CELL * params)
1228 {
1229 return filterIndex(params, FILTER_CLEAN);
1230 }
1231
1232 CELL * p_exists(CELL * params)
1233 {
1234 return filterIndex(params, FILTER_EXISTS);
1235 }
1236
1237 CELL * p_forAll(CELL * params)
1238 {
1239 return filterIndex(params, FILTER_FOR_ALL);
1240 }
1241
1242 CELL * filterIndex(CELL * params, int mode)
1243 {
1244 CELL * expr;
1245 CELL * pCell;
1246 CELL * args;
1247 CELL * resultList = NULL;
1248 CELL * result;
1249 CELL * cell;
1250 ssize_t count;
1251 int resultIndexSave;
1252 int errNo, trueFlag;
1253
1254 args = evaluateExpression(params->next);
1255 pCell = evaluateExpression(params);
1256
1257 if(!isList(args->type))
1258         return(errorProcExt(ERR_LIST_EXPECTED, params->next));
1259 args = (CELL *)args->contents;
1260
1261 result = NULL;
1262 count = 0;
1263 resultIndexSave = resultStackIdx;
1264 while(args != nilCell)
1265         {
1266         expr = getCell(CELL_EXPRESSION);
1267         expr->contents = (UINT)copyCell(pCell);
1268         cell = (CELL *)expr->contents;
1269         cell->next = getCell(CELL_QUOTE);
1270         cell = cell->next;
1271         cell->contents = (UINT)copyCell(args);
1272         pushResult(expr);
1273
1274         if(!(cell = evaluateExpressionSafe(expr, &errNo)))
1275                 {
1276                 if(resultList) deleteList(resultList);
1277                 longjmp(errorJump, errNo);
1278                 }
1279
1280     trueFlag = !isNil(cell);
1281
1282         cleanupResults(resultIndexSave);
1283
1284         if(mode == FILTER_EXISTS && trueFlag)
1285                 return(copyCell(args));
1286
1287         else if (mode == FILTER_FOR_ALL)
1288                 {
1289                 if(trueFlag) goto CONTINUE_FOR_ALL;
1290                 else return(nilCell);
1291                 }
1292
1293         if((trueFlag && mode != FILTER_CLEAN) || (!trueFlag && mode == FILTER_CLEAN))
1294                 {
1295                 if(result == NULL)
1296                         {
1297                         resultList = getCell(CELL_EXPRESSION);
1298                         resultList->contents = (mode == FILTER_INDEX) ?
1299                                                 (UINT)stuffInteger((UINT)count): (UINT)copyCell(args) ;
1300                         result = (CELL*)resultList->contents;
1301                         }
1302                 else
1303                         {
1304                         result->next = (mode == FILTER_INDEX) ?
1305                                                 stuffInteger(count): copyCell(args);
1306                         result = result->next;
1307                         }
1308                 }
1309
1310         CONTINUE_FOR_ALL:
1311         args = args->next;
1312         count++;
1313         }
1314
1315 if(mode == FILTER_EXISTS)
1316         return(nilCell);
1317
1318 if(mode == FILTER_FOR_ALL)
1319         return(trueCell);
1320
1321 if(resultList == NULL)
1322         return(getCell(CELL_EXPRESSION));
1323
1324 return(resultList);
1325 }
1326
1327
1328 #define MAX_REF_STACK 256
1329 typedef struct {
1330         size_t * base;
1331         size_t idx;
1332         } REFSTACK;
1333
1334 #define pushRef(A) (refStack->base[refStack->idx++] = (UINT)(A))
1335 #define popRef() (--refStack->idx)
1336
1337 CELL * makeIndexVector(REFSTACK * refStack)
1338 {
1339 CELL * vector;
1340 CELL * next;
1341 int i;
1342
1343 vector = getCell(CELL_EXPRESSION);
1344 next = stuffInteger(refStack->base[0]);
1345 vector->contents = (UINT)next;
1346
1347 for(i = 1; i < refStack->idx; i++)
1348         {
1349         next->next = stuffInteger(refStack->base[i]);
1350         next = next->next;
1351         }
1352
1353 return(vector);
1354 }
1355
1356 #define REF_SINGLE 0
1357 #define REF_ALL 1
1358
1359 void ref(CELL * keyCell, CELL * list, CELL * funcCell, CELL * result,
1360                                                 CELL * * next, REFSTACK * refStack, int mode)
1361 {
1362 size_t idx = 0;
1363 int resultIdxSave = resultStackIdx;
1364
1365 while(list != nilCell)
1366         {
1367         if(compareFunc(keyCell, list, funcCell) == 0)
1368                 {
1369                 if(funcCell)
1370                         {
1371                         deleteList((CELL*)sysSymbol[0]->contents);
1372                         sysSymbol[0]->contents = (UINT)copyCell(list);
1373                         }
1374                 if(refStack->idx < MAX_REF_STACK) pushRef(idx);
1375                 else errorProc(ERR_NESTING_TOO_DEEP);
1376                 if(*next == NULL)
1377                         {
1378                         *next = makeIndexVector(refStack);
1379                         result->contents = (UINT)*next;
1380                         }
1381                 else
1382                         {
1383                         (*next)->next = makeIndexVector(refStack);
1384                         *next = (*next)->next;
1385                         }
1386                 popRef();
1387                 if(mode == REF_SINGLE) return;
1388                 }
1389         if(isList(list->type))
1390                 {
1391                 if(refStack->idx < MAX_REF_STACK) pushRef(idx);
1392                 else errorProc(ERR_NESTING_TOO_DEEP);
1393                 ref(keyCell, (CELL*)list->contents, funcCell, result, next, refStack, mode);
1394                 popRef();
1395                 }
1396
1397         idx++;
1398         cleanupResults(resultIdxSave);
1399         list = list->next;
1400         }
1401 }
1402
1403
1404 CELL * reference(CELL * params, int mode)
1405 {
1406 CELL * cell;
1407 CELL * keyCell;
1408 CELL * list;
1409 CELL * funcCell = NULL;
1410 CELL * next = NULL;
1411 REFSTACK refStack;
1412
1413 refStack.base = alloca((MAX_REF_STACK + 2) * sizeof(size_t));
1414 refStack.idx = 0;
1415
1416 if(params->type == CELL_EXPRESSION)
1417         {
1418         cell = getList(params, &list, FALSE);
1419         keyCell = evaluateExpression(cell);
1420         }
1421 else
1422         {
1423         keyCell = evaluateExpression(params);
1424         params = params->next;
1425         list = evaluateExpression(params);
1426         }
1427
1428 if(params->next != nilCell)
1429         funcCell = evaluateExpression(params->next);
1430
1431 if(!isList(list->type))
1432         return(errorProcExt(ERR_LIST_EXPECTED, list));
1433
1434 cell = getCell(CELL_EXPRESSION);
1435
1436 ref(keyCell, (CELL *)list->contents, funcCell, cell, &next, &refStack, mode);
1437
1438 if(mode == REF_SINGLE)
1439         {
1440         next = (CELL *)cell->contents;
1441         if(next == nilCell) return(cell);
1442         cell->contents = (UINT)nilCell;
1443         deleteList(cell);
1444         return(next);
1445         }
1446
1447 return(cell);
1448 }
1449
1450 CELL * p_ref(CELL * params)
1451 {
1452 return(reference(params, REF_SINGLE));
1453 }
1454
1455 CELL * p_refAll(CELL * params)
1456 {
1457 return(reference(params, REF_ALL));
1458 }
1459
1460
1461 #define SETREF_ELMNT 0
1462 #define SETREF_LIST 1
1463 #define SETREF_ALL 2
1464
1465 CELL * modRef(CELL * key, CELL * list, CELL * func, CELL * new, int mode, int * count)
1466 {
1467 CELL * result;
1468 int resultIdxSave = resultStackIdx;
1469
1470 while(list != nilCell)
1471         {
1472         if(compareFunc(key, list, func) == 0)
1473                 {
1474                 *count += 1;
1475                 if(mode == SETREF_ELMNT)
1476                         {
1477                         return(updateCell(list, new));
1478                         }
1479                 else
1480                         {
1481                         deleteList(updateCell(list, new));
1482                         if(mode == SETREF_LIST) return(list);
1483                         }
1484
1485                 list = list->next;
1486                 continue;
1487                 }
1488         else if(isList(list->type))
1489                 {
1490                 result = modRef(key, (CELL *)list->contents, func, new, mode, count);
1491                 if(result != nilCell) return(result);
1492                 }
1493
1494         cleanupResults(resultIdxSave);
1495         list = list->next;
1496         }
1497
1498 return(nilCell);
1499 }
1500
1501
1502 CELL * setRef(CELL * params, int mode)
1503 {
1504 CELL * key;
1505 CELL * list;
1506 CELL * new = NULL;
1507 CELL * funcCell = NULL;
1508 CELL * result;
1509 int count = 0;
1510
1511 new = params->next;
1512 if(params->type != CELL_EXPRESSION)
1513         return(errorProcExt(ERR_SYNTAX_WRONG, params));
1514
1515 params = getList(params, &list, TRUE);
1516 key = evaluateExpression(params);
1517
1518 if(new->next != nilCell)
1519         funcCell = evaluateExpression(new->next);
1520
1521 result = modRef(key, (CELL *)list->contents, funcCell, new, mode, &count);
1522
1523 if(count == 0)
1524         return(nilCell);
1525
1526 if(mode == SETREF_ELMNT)
1527         return(result);
1528
1529 return(copyCell(list));
1530 }
1531
1532
1533
1534 CELL * p_setRef(CELL * params)
1535 {
1536 return(setRef(params, SETREF_LIST));
1537 }
1538
1539 CELL * p_setRefAll(CELL * params)
1540 {
1541 return(setRef(params, SETREF_ALL));
1542 }
1543
1544 CELL * p_refSet(CELL * params)
1545 {
1546 return(setRef(params, SETREF_ELMNT));
1547 }
1548
1549
1550 /* update a cell in-place and put a copy of previous content
1551    in $0 to be used in replacement expressions.
1552    this function is used in set-nth/nth-set
1553 */
1554 CELL * updateCell(CELL * cell, CELL * val)
1555 {
1556 CELL * prev;
1557 CELL * new;
1558
1559 if(cell == nilCell) return(nilCell);
1560
1561 deleteList((CELL*)sysSymbol[0]->contents);
1562 sysSymbol[0]->contents = (UINT)copyCell(cell);
1563
1564 if(val != nilCell)
1565         {
1566         new = copyCell(evaluateExpression(val));
1567
1568         /* save previous content */
1569         prev = getCell(cell->type);
1570         prev->aux = cell->aux;
1571         prev->contents = cell->contents;
1572
1573         cell->type = new->type;
1574         cell->aux = new->aux;
1575         cell->contents = new->contents;
1576
1577         /* free the cell  */
1578         new->type = CELL_FREE;
1579         new->aux = 0;
1580         new->contents = 0;
1581         new->next = firstFreeCell;
1582         firstFreeCell = new;
1583         --cellCount;
1584         }
1585 else
1586         return(copyCell(cell));
1587
1588 return(prev);
1589 }
1590
1591 void flat(CELL * list, CELL * result, CELL * * next)
1592 {
1593 while(list != nilCell)
1594         {
1595         if(isList(list->type))
1596                 flat((CELL*)list->contents, result, next);
1597         else
1598                 {
1599                 if(*next == NULL)
1600                         {
1601                         *next = copyCell(list);
1602                         result->contents = (UINT)*next;
1603                         }
1604                 else
1605                         {
1606                         (*next)->next = copyCell(list);
1607                         *next = (*next)->next;
1608                         }
1609                 }
1610
1611         list = list->next;
1612         }
1613 }
1614
1615
1616 CELL * p_flat(CELL * params)
1617 {
1618 CELL * list;
1619 CELL * result;
1620 CELL * next;
1621
1622 getListHead(params, &list);
1623
1624 result = getCell(CELL_EXPRESSION);
1625
1626 next = NULL;
1627
1628 flat(list, result, &next);
1629
1630 return(result);
1631 }
1632
1633
1634
1635
1636 /* --------------------------------- array routines ------------------------- */
1637
1638
1639 CELL * initArray(CELL * array, CELL * list, CELL * * next);
1640
1641 CELL * p_array(CELL * params)
1642 {
1643 ssize_t index[17];
1644 int p = 0;
1645 CELL * array = NULL;
1646 CELL * list = nilCell;
1647 CELL * next = NULL;
1648
1649 while(params != nilCell && p < 17)
1650         {
1651         list = evaluateExpression(params);
1652         if(isNumber(list->type))
1653                 {
1654                 getIntegerExt(list, (UINT*)&index[p], FALSE);
1655                 if(index[p] < 1)
1656                         return(errorProcExt(ERR_WRONG_DIMENSIONS, list));
1657                 else p++;
1658                 }
1659         else if(isList(list->type)) break;
1660         else return(errorProcExt(ERR_NUMBER_EXPECTED, list));
1661         params = params->next;
1662         }
1663
1664 if(p == 0)
1665         return(errorProc(ERR_MISSING_ARGUMENT));
1666
1667 index[p] = 0;
1668 if(!isList(list->type)) list = nilCell;
1669
1670 array = makeArray(index, 0);
1671
1672 if(list != nilCell)
1673         array = initArray(array, list, &next);
1674
1675 return(array);
1676 }
1677
1678
1679 CELL * makeArray(ssize_t * index, int p)
1680 {
1681 CELL * array;
1682 CELL * list;
1683 CELL * * addr;
1684 ssize_t size;
1685
1686 array = getCell(CELL_ARRAY);
1687 size = index[p];
1688 array->contents = (UINT)callocMemory(size * sizeof(UINT) + 1);
1689 array->aux = size * sizeof(UINT) + 1;
1690 addr = (CELL * *)array->contents;
1691
1692 p++;
1693 if(index[p] > 0)
1694         {
1695         list = makeArray(index, p);
1696         while(size--) *(addr++) = copyCell(list);
1697         deleteList(list);
1698         return(array);
1699         }
1700 else
1701         while(size--) *(addr++) = nilCell;
1702
1703 return(array);
1704 }
1705
1706
1707 CELL * initArray(CELL * array, CELL * list, CELL * * next)
1708 {
1709 CELL * * addr;
1710 int size;
1711
1712 size = (array->aux - 1) / sizeof(UINT);
1713 addr = (CELL * *)array->contents;
1714
1715 while(size--)
1716         {
1717         if((*addr)->type == CELL_ARRAY)
1718                 {
1719                 *(addr) = initArray(*addr, list, next);
1720                 addr++;
1721                 continue;
1722                 }
1723
1724         if(*next == NULL || *next == nilCell)
1725                 {
1726                 deleteList(*addr);
1727                 *(addr++) = copyCell((CELL *)list->contents);
1728                 *next = (CELL*)list->contents;
1729                 *next = (*next)->next;
1730                 }
1731         else
1732                 {
1733                 deleteList(*addr);
1734                 *(addr++) = copyCell(*next);
1735                 *next = (*next)->next;
1736                 }
1737         }
1738
1739
1740 return(array);
1741 }
1742
1743
1744
1745 CELL * p_arrayList(CELL * params)
1746 {
1747 CELL * array;
1748
1749 array = evaluateExpression(params);
1750
1751 if(array->type != CELL_ARRAY)
1752         return(errorProcExt(ERR_ARRAY_EXPECTED, params));
1753
1754 return(arrayList(array));
1755 }
1756
1757
1758
1759 CELL * arrayList(CELL * array)
1760 {
1761 CELL * list = NULL;
1762 CELL * * addr;
1763 CELL * new;
1764 CELL * cell;
1765 ssize_t size;
1766
1767 addr = (CELL * *)array->contents;
1768 size = (array->aux - 1) / sizeof(UINT);
1769
1770 while(size--)
1771         {
1772         cell = *(addr++);
1773         if(cell->type == CELL_ARRAY)
1774                 new = arrayList(cell);
1775         else
1776                 new = copyCell(cell);
1777         if(list == NULL)
1778                 {
1779                 array = list = getCell(CELL_EXPRESSION);
1780                 list->contents = (UINT)new;
1781                 list = new;
1782                 }
1783         else
1784                 {
1785                 list->next = new;
1786                 list = new;
1787                 }
1788         }
1789
1790 return(array);
1791 }
1792
1793 CELL * arrayTranspose(CELL * array)
1794 {
1795 ssize_t n, m, i, j;
1796 CELL * cell;
1797 CELL * * addr;
1798 CELL * * newAddr;
1799 CELL * * row;
1800 CELL * * newRow;
1801 CELL * newArray;
1802
1803 addr = (CELL * *)array->contents;
1804 n = (array->aux - 1) / sizeof(CELL *);
1805
1806 cell = *addr;
1807 if(cell->type != CELL_ARRAY)
1808         return(errorProcExt(ERR_WRONG_DIMENSIONS, array));
1809 m = (cell->aux - 1) / sizeof(CELL *);
1810
1811 newArray = getCell(CELL_ARRAY);
1812 newArray->aux = m  * sizeof(CELL *) + 1;
1813 newAddr = (CELL * *)callocMemory(newArray->aux);
1814 newArray->contents = (UINT)newAddr;
1815
1816 for(j = 0; j < m; j++)
1817         {
1818         /* create new row vector */
1819         cell = getCell(CELL_ARRAY);
1820         cell->aux = n * sizeof(CELL *) + 1;
1821         newRow = (CELL * *)callocMemory(cell->aux);
1822         cell->contents = (UINT)newRow;
1823         *(newAddr + j) = cell;
1824         for( i = 0; i < n; i++)
1825                 {
1826                 cell = *(addr + i);
1827                 if(cell->type != CELL_ARRAY)
1828                         *(newRow + i) = copyCell(cell);
1829                 else
1830                         {
1831                         row = (CELL * *)cell->contents;
1832                         if( (cell->aux - 1) / sizeof(CELL *) < (j + 1))
1833                                 *(newRow + i) = nilCell;
1834                         else
1835                                 *(newRow + i) = copyCell(*(row + j));
1836                         }
1837                 }
1838         }
1839
1840 return(newArray);
1841 }
1842
1843
1844 CELL * subarray(CELL * array, ssize_t offset, ssize_t length)
1845 {
1846 CELL * newArray;
1847 ssize_t size, i;
1848 CELL * * newAddr;
1849 CELL * * addr;
1850
1851 size = (array->aux - 1) / sizeof(CELL *);
1852 if(offset < 0) offset = offset + size;
1853 if(offset >= size || offset < 0)
1854                 return(errorProcExt2(ERR_ARRAY_INDEX_OUTOF_BOUNDS, stuffInteger(offset)));
1855
1856 if(length < 0)
1857         {
1858         length = size - offset + length;
1859         if(length < 0) length = 0;
1860         }
1861
1862 if(length == MAX_LONG && length > (size - offset))
1863         length = size - offset;
1864
1865 if(length == 0 || length > (size - offset))
1866         return(errorProcExt2(ERR_ARRAY_INDEX_OUTOF_BOUNDS, stuffInteger(length)));
1867
1868 addr = (CELL * *)array->contents;
1869 newArray = getCell(CELL_ARRAY);
1870 newArray->aux = length * sizeof(CELL *) + 1;
1871 newAddr = (CELL * *)callocMemory(newArray->aux);
1872 newArray->contents = (UINT)newAddr;
1873
1874 for(i = 0; i < length; i++)
1875         *(newAddr + i) = copyCell(*(addr + offset + i));
1876
1877 return(newArray);
1878 }
1879
1880
1881 /* copies an array */
1882 UINT * copyArray(CELL * array)
1883 {
1884 CELL * * newAddr;
1885 CELL * * orgAddr;
1886 CELL * * addr;
1887 ssize_t size;
1888
1889 addr = newAddr = (CELL * *)callocMemory(array->aux);
1890
1891 size = (array->aux - 1) / sizeof(UINT);
1892 orgAddr = (CELL * *)array->contents;
1893
1894 while(size--)
1895         *(newAddr++) = copyCell(*(orgAddr++));
1896
1897 return((UINT*)addr);
1898 }
1899
1900
1901 CELL * appendArray(CELL * array, CELL * params)
1902 {
1903 CELL * cell;
1904 CELL * * addr;
1905 ssize_t size, sizeCell;
1906 ssize_t i;
1907 CELL * * newAddr;
1908 int  deleteFlag = 0;
1909
1910 if(params == nilCell)
1911         return(copyCell(array));
1912
1913 START_APPEND_ARRAYS:
1914 size = (array->aux - 1) / sizeof(CELL *);
1915 addr = (CELL * *)array->contents;
1916 cell = evaluateExpression(params);
1917 if(cell->type != CELL_ARRAY)
1918         return(errorProcExt(ERR_ARRAY_EXPECTED, params));
1919 sizeCell = (cell->aux - 1) / sizeof(CELL *);
1920
1921 newAddr = allocMemory(array->aux + cell->aux -1);
1922
1923 for(i = 0; i < size; i++)
1924         *(newAddr + i) = copyCell(*(addr + i));
1925
1926 addr = (CELL * *)cell->contents;
1927
1928 for(i = 0; i < sizeCell; i++)
1929         *(newAddr + size + i) = copyCell(*(addr + i));
1930
1931 cell = getCell(CELL_ARRAY);
1932 cell->aux = (size + sizeCell) * sizeof(CELL *) + 1;
1933 cell->contents = (UINT)newAddr;
1934
1935 if( (params = params->next) != nilCell)
1936         {
1937         if(deleteFlag)
1938                 deleteList(array);
1939         deleteFlag = 1;
1940         array = cell;
1941         goto START_APPEND_ARRAYS;
1942         }
1943
1944 if(deleteFlag)
1945         deleteList(array);
1946
1947 return(cell);
1948 }
1949
1950
1951 void deleteArray(CELL * array)
1952 {
1953 CELL * * addr;
1954 CELL * * mem;
1955 ssize_t size;
1956
1957 mem = addr = (CELL * *)array->contents;
1958 size = (array->aux - 1) / sizeof(UINT);
1959 while(size--)
1960         deleteList(*(addr++));
1961
1962 freeMemory((char *)mem);
1963 }
1964
1965
1966 void markArray(CELL * array)
1967 {
1968 CELL * * addr;
1969 ssize_t size;
1970
1971 addr = (CELL * *)array->contents;
1972 size = (array->aux - 1) / sizeof(UINT);
1973
1974 while(size--) markList(*(addr++));
1975 }
1976
1977
1978
1979 void printArray(CELL * array, UINT device)
1980 {
1981 CELL * list;
1982
1983 list = arrayList(array);
1984
1985 printExpression(list, device);
1986
1987 deleteList(list);
1988 }
1989
1990
1991 void printArrayDimensions(CELL * array, UINT device)
1992 {
1993 CELL * * addr;
1994
1995 while(array->type == CELL_ARRAY)
1996         {
1997         varPrintf(device, "%d ", (array->aux - 1)/sizeof(CELL *));
1998         addr = (CELL **)array->contents;
1999         array = *addr;
2000         }
2001 }
2002
2003
2004 CELL * implicitIndexArray(CELL * cell, CELL * params)
2005 {
2006 CELL * * addr;
2007 CELL * list;
2008 ssize_t size, index;
2009 int evalFlag;
2010
2011 list = evaluateExpression(params);
2012 if(isNumber(list->type))
2013         {
2014         getIntegerExt(list, (UINT *)&index, FALSE);
2015         params = params->next;
2016         evalFlag = TRUE;
2017         }
2018 else if(isList(list->type))
2019         {
2020         params = (CELL*)list->contents;
2021         params = getIntegerExt(params, (UINT *)&index, FALSE);
2022         evalFlag = FALSE;
2023         }
2024 else return(errorProcExt(ERR_LIST_OR_NUMBER_EXPECTED, params));
2025
2026 while(cell->type == CELL_ARRAY)
2027         {
2028         addr = (CELL * *)cell->contents;
2029         size = (cell->aux - 1) / sizeof(UINT);
2030         if(index < 0) index = index + size;
2031         if(index >= size || index < 0)
2032                 return(errorProcExt2(ERR_ARRAY_INDEX_OUTOF_BOUNDS, stuffInteger(index)));
2033         cell = *(addr + index);
2034         if(params == nilCell || cell->type != CELL_ARRAY) break;
2035         params = getIntegerExt(params, (UINT *)&index, evalFlag);
2036         }
2037
2038 return(cell);
2039 }
2040
2041
2042 int compareArrays(CELL * left, CELL * right)
2043 {
2044 CELL * * leftAddr;
2045 CELL * * rightAddr;
2046 ssize_t leftS, rightS;
2047 ssize_t result;
2048
2049 leftAddr = (CELL * *)left->contents;
2050 rightAddr = (CELL * *)right->contents;
2051 leftS = (left->aux - 1) / sizeof(UINT);
2052 rightS = (right->aux - 1) / sizeof(UINT);
2053
2054 if(leftS < rightS) return(-1);
2055 if(leftS > rightS) return(1);
2056
2057 result = 0;
2058 while(leftS && result == 0)
2059         {
2060         result = compareCells(*(leftAddr++), *(rightAddr++));
2061         leftS--;
2062         }
2063
2064 return(result);
2065 }
2066
2067
2068 int compareFunc(CELL * left, CELL * right, CELL * func)
2069 {
2070 CELL * cell;
2071 CELL * expr;
2072
2073 if(func == NULL)
2074         return(compareCells(left, right));
2075
2076 expr = getCell(CELL_EXPRESSION);
2077 pushResult(expr);
2078 expr->contents = (UINT)copyCell(func);
2079 cell = (CELL *)expr->contents;
2080 cell->next = getCell(CELL_QUOTE);
2081 ((CELL *)cell->next)->contents = (UINT)copyCell((CELL*)left);
2082 cell = cell->next;
2083 cell->next = getCell(CELL_QUOTE);
2084 ((CELL *)cell->next)->contents = (UINT)copyCell((CELL*)right);
2085
2086 cell = evaluateExpression(expr);
2087
2088 return(isNil(cell));
2089 }
2090
2091 /* eof */
2092
2093