nl-liststr.c

   1 /* nl-liststr.c --- newLISP primitives handling lists and strings
   2
   3
   4     Copyright (C) 2008 Lutz Mueller
   5
   6     This program is free software: you can redistribute it and/or modify
   7     it under the terms of the GNU General Public License as published by
   8     the Free Software Foundation, either version 3 of the License, or
   9     (at your option) any later version.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14     GNU General Public License for more details.
  15
  16     You should have received a copy of the GNU General Public License
  17     along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 */
  20
  21 #include "newlisp.h"
  22 #include "pcre.h"
  23 #include "protos.h"
  24
  25 extern CELL * lastCellCopied;
  26 extern SYMBOL * sysSymbol[];
  27
  28 /* used only on string indices */
  29 size_t adjustNegativeIndex(ssize_t index, size_t length)
  30 {
  31 if(index < 0) index = length + index;
  32 else if((index+1) > length) errorProc(ERR_STRING_INDEX_OUTOF_BOUNDS);
  33
  34 if(index < 0) errorProc(ERR_STRING_INDEX_OUTOF_BOUNDS);
  35
  36 return(index);
  37 }
  38
  39 size_t adjustCount(ssize_t count, ssize_t length)
  40 {
  41 if(length <= 1 || count == 0 || length == count)
  42         return(0);
  43
  44 if(count > 0)
  45     count = count % length;
  46 else
  47     {
  48     count = -count % length;
  49     count = length - count;
  50     }
  51 return(count);
  52 }
  53
  54 #ifdef LINUX
  55 extern char * strcasestr(char * haystack, char * needle);
  56 #endif
  57 CELL * p_member(CELL * params)
  58 {
  59 CELL * key;
  60 CELL * list;
  61 CELL * member;
  62 long options  = -1;
  63 char * ptr;
  64 ssize_t pos;
  65
  66 key = evaluateExpression(params);
  67
  68 params = params->next;
  69 list = evaluateExpression(params);
  70
  71 if(params->next != nilCell)
  72         getInteger(params->next, (UINT *)&options);
  73
  74 if(isList(list->type))
  75         list = (CELL *)list->contents;
  76 else if (list->type == CELL_STRING)
  77         {
  78         if(key->type != CELL_STRING)
  79                 return(errorProcExt(ERR_STRING_EXPECTED, params));
  80         if(options == -1)
  81                 {
  82                 ptr = strstr((char *)list->contents, (char *) key->contents);
  83                 if(ptr) return(stuffString(ptr));
  84                 }
  85         else
  86                 {
  87                 pos = searchBufferRegex((char*)list->contents, 0, (char *)key->contents, list->aux - 1, options, 0);
  88                 if(pos != -1) return(stuffString((char *)list->contents + pos));
  89                 }
  90         return(nilCell);
  91         }
  92 else
  93         return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params->next));
  94
  95 while(list != nilCell)
  96         {
  97         if(compareCells(key, list) == 0) break;
  98         list = list->next;
  99         }
 100
 101 if(list == nilCell) return(nilCell);
 102 member = getCell(CELL_EXPRESSION);
 103 member->contents = (UINT)copyList(list);
 104 return(member);
 105 }
 106
 107 CELL * p_length(CELL * params)
 108 {
 109 size_t length;
 110 SYMBOL * symbol;
 111
 112 params = evaluateExpression(params);
 113 length = 0;
 114 switch(params->type)
 115         {
 116         case CELL_LONG:
 117                 length = sizeof(UINT); break;
 118 #ifndef NEWLISP64
 119         case CELL_INT64:
 120                 length = sizeof(INT64); break;
 121 #endif
 122         case CELL_FLOAT:
 123                 length = sizeof(double); break;
 124         case CELL_STRING:
 125                 length = params->aux - 1; break;
 126         case CELL_CONTEXT:
 127         case CELL_SYMBOL:
 128                 symbol = (SYMBOL *)params->contents;
 129                 length = strlen(symbol->name);
 130                 break;
 131         case CELL_DYN_SYMBOL:
 132                 length = strlen((char *)params->contents);
 133                 break;
 134         case CELL_EXPRESSION:
 135         case CELL_LAMBDA:
 136         case CELL_MACRO:
 137                 length = listlen((CELL *)params->contents);
 138                 break;
 139         case CELL_ARRAY:
 140                 length = (params->aux - 1) / sizeof(UINT);
 141         default:
 142                 break;
 143         }
 144 return(stuffInteger(length));
 145 }
 146
 147
 148 CELL * p_append(CELL * params)
 149 {
 150 CELL * list = NULL;
 151 CELL * firstCell = NULL;
 152 CELL * copy = NULL;
 153 CELL * cell;
 154
 155 while(params != nilCell)
 156     {
 157     cell = evaluateExpression(params);
 158     if(!isList(cell->type))
 159         {
 160         if(copy == NULL)
 161                         {
 162                         if(cell->type == CELL_STRING)
 163                 return(appendString(cell, params->next, NULL, 0, FALSE, TRUE));
 164                         else if(cell->type == CELL_ARRAY)
 165                 return(appendArray(cell, params->next));
 166                         return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
 167                         }
 168
 169         return(errorProcExt(ERR_LIST_EXPECTED, params));
 170         }
 171
 172         if(list == NULL)
 173         list = getCell(cell->type);
 174
 175     copy = copyList((CELL *)cell->contents);
 176
 177     params = params->next;
 178     if(copy == nilCell) continue;
 179
 180     if(firstCell == NULL) list->contents = (UINT)copy;
 181     else firstCell->next = copy;
 182
 183     firstCell = lastCellCopied;
 184     }
 185
 186 if(list == NULL)
 187         return(getCell(CELL_EXPRESSION));
 188
 189 return(list);
 190 }
 191
 192
 193 CELL * appendString(CELL * cell, CELL * list, char * joint, size_t jointLen, int trailJoint, int evalFlag)
 194 {
 195 CELL * result;
 196 STREAM stream;
 197 char * sPtr;
 198 size_t len;
 199
 200 openStrStream(&stream, MAX_LINE, 0);
 201 writeStreamStr(&stream, (char *)cell->contents, cell->aux - 1);
 202 while(list != nilCell)
 203         {
 204         if(joint == NULL)
 205                 {
 206                 list = getStringSize(list, &sPtr, &len, evalFlag);
 207                 writeStreamStr(&stream, sPtr, len);
 208                 }
 209         else
 210                 {
 211                 list = getStringSize(list, &sPtr, &len, FALSE);
 212                 if(jointLen) writeStreamStr(&stream, joint, jointLen);
 213                 writeStreamStr(&stream, sPtr, len);
 214                 }
 215         }
 216
 217 if(trailJoint)
 218         writeStreamStr(&stream, joint, jointLen);
 219
 220 result = getCell(CELL_STRING);
 221 result->contents = (UINT)allocMemory(stream.position + 1);
 222 *((char *)result->contents + stream.position) = 0;
 223 result->aux = stream.position + 1;
 224 memcpy((void *)result->contents, stream.buffer, stream.position);
 225
 226 closeStrStream(&stream);
 227
 228 return(result);
 229 }
 230
 231
 232 CELL * p_chop(CELL * params)
 233 {
 234 size_t number = 1;
 235 size_t length = 0;
 236 CELL * next;
 237 #ifdef SUPPORT_UTF8
 238 char * ptr;
 239 #endif
 240
 241 next = params->next;
 242 params = evaluateExpression(params);
 243
 244 if(next != nilCell)
 245         getInteger(next, (UINT *)&number);
 246
 247 if(params->type == CELL_STRING)
 248         {
 249 #ifndef SUPPORT_UTF8
 250         length = params->aux - 1;
 251         if(number > length) number = length;
 252         length = length - number;
 253         return stuffStringN((char *)params->contents, length);
 254 #else
 255         length = utf8_wlen((char *)params->contents);
 256         if(number > length) number = length;
 257         length = length - number;
 258         ptr = (char *)params->contents;
 259         while(length--)
 260                 ptr += utf8_1st_len(ptr);
 261         return stuffStringN((char *)params->contents, ptr - (char *)params->contents);
 262 #endif
 263         }
 264
 265 if(!isList(params->type))
 266     return(errorProc(ERR_LIST_OR_STRING_EXPECTED));
 267
 268 length = listlen((CELL *)params->contents);
 269 if(number > length) number = length;
 270
 271 return(sublist((CELL *)params->contents, 0, length - number));
 272 }
 273
 274 CELL * setNthStr(CELL * cellStr, CELL * new, ssize_t index, int typeFlag);
 275 CELL * setNth(CELL * params, int typeFlag);
 276
 277 CELL * p_nth(CELL * params) {return setNth(params, 0);}
 278 CELL * p_nthSet(CELL * params) {return setNth(params, 1);}
 279 CELL * p_setNth(CELL * params) {return setNth(params, 2);}
 280
 281 CELL * setNth(CELL * params, int typeFlag)
 282 {
 283 ssize_t index;
 284 CELL * list;
 285 CELL * next;
 286 CELL * cell = NULL;
 287
 288 /* new syntax, distinguished by type of first arg and number of args */
 289 next = params->next;
 290 if( (params->type == CELL_EXPRESSION) &&
 291         ( (!typeFlag && next == nilCell) || (typeFlag && next->next == nilCell) ))
 292         {
 293         params = getList(params, &list, typeFlag);
 294
 295 NTH_EVAL_IMPLICIT:
 296         if(isList(list->type))
 297                 {
 298                 if(!typeFlag)
 299                         return(copyCell(implicitIndexList(list, params)));
 300                 else if(typeFlag == 1)
 301                         return(updateCell(implicitIndexList(list, params), next));
 302                 else
 303                         {
 304                         deleteList(updateCell(implicitIndexList(list, params), next));
 305                         return(copyCell(list));
 306                         }
 307                 }
 308
 309         else if(list->type == CELL_ARRAY)
 310                 {
 311                 if(!typeFlag)
 312                         return(copyCell(implicitIndexArray(list, params)));
 313                 else if(typeFlag == 1)
 314                         return(updateCell(implicitIndexArray(list, params), next));
 315                 else
 316                         {
 317                         deleteList(updateCell(implicitIndexArray(list, params), next));
 318                         return(copyCell(list));
 319                         }
 320                 }
 321
 322         else if(list->type == CELL_STRING)
 323                 {
 324                 getInteger(params, (UINT *)&index);
 325                 return(setNthStr(list, next, index, typeFlag));
 326                 }
 327
 328         return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, list));
 329         }
 330
 331 list = evaluateExpression(params);
 332 if(!isNumber(list->type))
 333         return(errorProcExt(ERR_NUMBER_EXPECTED, params));
 334
 335 while(isNumber(list->type))
 336         {
 337         if(cell == NULL)
 338                 {
 339                 cell = getCell(CELL_EXPRESSION);
 340                 cell->contents = (UINT)copyCell(list);
 341                 next = (CELL *)cell->contents;
 342                 }
 343         else
 344                 {
 345                 next->next = copyCell(list);
 346                 next = next->next;
 347                 }
 348
 349         params = params->next;
 350         if(typeFlag)
 351                 list = evalCheckProtected(params, NULL);
 352         else
 353                 list = evaluateExpression(params);
 354         }
 355
 356 next = params->next;
 357
 358 if(list->type == CELL_STRING)
 359         {
 360         getInteger((CELL *)cell->contents, (UINT *)&index);
 361         deleteList(cell);
 362         return(setNthStr(list, next, index, typeFlag));
 363         }
 364
 365 params = getCell(CELL_QUOTE);
 366 params->contents = (UINT)cell;
 367
 368 pushResult(params);
 369
 370 goto NTH_EVAL_IMPLICIT;
 371 }
 372
 373
 374 #define INSERT_BEFORE 0
 375 #define INSERT_AFTER 1
 376 #define INSERT_END 2
 377 CELL * p_push(CELL * params)
 378 {
 379 CELL * newCell;
 380 CELL * list;
 381 CELL * cell = NULL;
 382 SYMBOL * sPtr;
 383 int insert = 0, evalFlag = 0;
 384 ssize_t index;
 385
 386 newCell = evaluateExpression(params);
 387 params = params->next;
 388
 389 if(isSymbol(params->type))
 390         {
 391         if(params->type == CELL_SYMBOL)
 392                 sPtr = (SYMBOL *)params->contents;
 393         else
 394                 sPtr = getDynamicSymbol(params);
 395
 396         if(isProtected(sPtr->flags))
 397                 return(errorProcExt(ERR_SYMBOL_PROTECTED, params));
 398
 399         if(!isList(((CELL*)sPtr->contents)->type))
 400                 {
 401                 if(isNil((CELL *)sPtr->contents))
 402                         {
 403                         deleteList((CELL*)sPtr->contents);
 404                         list = getCell(CELL_EXPRESSION);
 405                         sPtr->contents = (UINT)list;            }
 406                         }
 407                 list = (CELL*)sPtr->contents;
 408                 }
 409         else
 410                 list = evalCheckProtected(params, NULL);
 411
 412 if(!isList(list->type))
 413         {
 414         if(list->type == CELL_STRING)
 415                 return(pushOnString(newCell, list, params->next));
 416         else
 417                 return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params));
 418         }
 419
 420 if(params->next == nilCell)
 421         {
 422         params = params->next;
 423         index = 0;
 424         }
 425 else
 426         {
 427         cell = ((CELL*)params->next)->next;
 428         params = evaluateExpression(params->next);
 429         if(isList(params->type))
 430                 {
 431                 evalFlag = FALSE;
 432                 params = getIntegerExt((CELL*)params->contents, (UINT*)&index, FALSE);
 433                 }
 434         else
 435                 {
 436                 evalFlag = TRUE;
 437                 getIntegerExt(params, (UINT*)&index, FALSE);
 438                 params = cell;
 439                 }
 440         }
 441
 442 if(index == -1)
 443         {
 444         if(params == nilCell)
 445                 {
 446                 newCell = copyCell(newCell);
 447                 cell = (CELL*)list->aux;
 448                 list->aux = (UINT)newCell;
 449                 if(cell != nilCell && cell != trueCell)
 450                         {
 451                         cell->next = newCell;
 452                         return(copyCell(newCell));
 453                         }
 454
 455                 if(list->contents == (UINT)nilCell)
 456                         {
 457                         list->contents = (UINT)newCell;
 458                         return(copyCell(newCell));
 459                         }
 460
 461                 list = (CELL *)list->contents;
 462                 while(list->next != nilCell)
 463                         list = list->next;
 464                 list->next = newCell;
 465                 return(copyCell(newCell));
 466                 }
 467
 468         /* index = MAX_LONG; */
 469         }
 470
 471 list->aux = (UINT)nilCell; /* undo last element optimization */
 472
 473 while(isList(list->type))
 474         {
 475         cell = list;
 476         list = (CELL *)list->contents;
 477
 478         if(index < 0)
 479                 {
 480                 index = listlen(list) + index;
 481                 if(index == -1) index = 0;
 482                 if(index == 0) insert = INSERT_BEFORE;
 483                 else if(index > 0) insert = INSERT_AFTER;
 484                 else errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
 485                 }
 486         else insert = INSERT_BEFORE;
 487
 488         while(index--)
 489                 {
 490                 if(list == nilCell)
 491                         {
 492                         if(index >= 0) errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
 493                         insert = INSERT_END;
 494                         break;
 495                         }
 496                 cell = list;
 497                 list = list->next;
 498                 }
 499
 500         if(params == nilCell || !isList(list->type))  break;
 501         params = getIntegerExt(params, (UINT*)&index, evalFlag);
 502         }
 503
 504 newCell = copyCell(newCell);
 505 if(insert == INSERT_BEFORE || list == nilCell)
 506         {
 507         if(list == (CELL*)cell->contents)
 508                 {
 509                 cell->contents = (UINT)newCell;
 510                 newCell->next = list;
 511                 }
 512         else
 513                 {
 514                 cell->next = newCell;
 515                 newCell->next = list;
 516                 }
 517         }
 518
 519 else if(insert == INSERT_AFTER || insert == INSERT_END)
 520     {
 521     cell = list->next;
 522     list->next = newCell;
 523     newCell->next = cell;
 524     }
 525
 526 return(copyCell(newCell));
 527 }
 528
 529
 530 CELL * p_pop(CELL * params)
 531 {
 532 CELL * list;
 533 CELL * cell = NULL;
 534 ssize_t index;
 535 int evalFlag = FALSE;
 536
 537 list = evalCheckProtected(params, NULL);
 538
 539 if(!isList(list->type))
 540         {
 541         if(list->type == CELL_STRING)
 542                 return(popString(list, params->next));
 543         else
 544                 return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params));
 545         }
 546
 547 /* leave last element optimization if popping first for queues */
 548 if(params->next == nilCell)
 549         {
 550         cell = (CELL *)list->contents;
 551         list->contents = (UINT)cell->next;
 552         if(cell->next == nilCell) /* check if only one element in list */
 553                 list->aux = (UINT)nilCell; /* undo last element optimization */
 554         cell->next = nilCell;
 555         return(cell);
 556         }
 557 else
 558         {
 559         list->aux = (UINT)nilCell; /* undo last element optimization */
 560         cell = ((CELL*)params->next)->next;
 561         params = evaluateExpression(params->next);
 562         if(isList(params->type))
 563                 {
 564                 evalFlag = FALSE;
 565                 params = getIntegerExt((CELL*)params->contents, (UINT*)&index, FALSE);
 566                 }
 567         else
 568                 {
 569                 evalFlag = TRUE;
 570                 getIntegerExt(params, (UINT*)&index, FALSE);
 571                 params = cell;
 572                 }
 573         }
 574
 575 while(isList(list->type))
 576     {
 577     cell = list;
 578     list = (CELL *)list->contents;
 579
 580         if(index < 0) index = convertNegativeOffset(index, list);
 581
 582         while(index--)
 583         {
 584                 cell = list;
 585         list = list->next;
 586         }
 587         if(list == nilCell)
 588                 errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
 589
 590     if(params == nilCell || !isList(list->type))  break;
 591     params = getIntegerExt(params, (UINT*)&index, evalFlag);
 592     }
 593
 594 if(list == (CELL*)cell->contents)
 595     cell->contents = (UINT)list->next;
 596 else
 597     cell->next = list->next;
 598
 599 list->next = nilCell;
 600 return(list);
 601 }
 602
 603
 604 CELL * setNthStr(CELL * cellStr, CELL * new, ssize_t index, int typeFlag)
 605 {
 606 char * newStr;
 607 char * oldStr;
 608 size_t newLen, oldLen, len;
 609 char * str;
 610
 611 oldStr = (char*)cellStr->contents;
 612 oldLen = cellStr->aux - 1;
 613
 614 if(oldLen == 0) return(copyCell(cellStr));
 615
 616 #ifndef SUPPORT_UTF8
 617
 618 index = adjustNegativeIndex(index, oldLen);
 619
 620 if(!typeFlag)
 621         return(stuffStringN(oldStr + index, 1));
 622
 623 deleteList((CELL*)sysSymbol[0]->contents);
 624 sysSymbol[0]->contents = (UINT)stuffStringN(oldStr + index, 1);
 625 len = 1;
 626
 627 #else
 628
 629 index = adjustNegativeIndex(index, utf8_wlen((char *)cellStr->contents));
 630 str = oldStr;
 631
 632 while(index--)
 633         {
 634         len = utf8_1st_len(str);
 635         str += len;
 636         }
 637 len = utf8_1st_len(str);
 638
 639 if(!typeFlag)
 640         return(stuffStringN(str, len));
 641
 642 deleteList((CELL*)sysSymbol[0]->contents);
 643 sysSymbol[0]->contents = (UINT)stuffStringN(str, len);
 644 index = str - oldStr;
 645
 646 #endif
 647
 648 getStringSize(new, &newStr, &newLen, TRUE);
 649 /* get back oldStr in case it changed during eval of replacement */
 650 oldStr = (char *)cellStr->contents;
 651 oldLen = cellStr->aux - 1;
 652 if(oldLen == 0) return(copyCell(cellStr));
 653 index = adjustNegativeIndex(index, oldLen);
 654
 655 str = allocMemory(oldLen + newLen - len + 1);
 656 *(str + oldLen + newLen - len) = 0;
 657
 658 memcpy(str, oldStr, index);
 659 memcpy(str + index, newStr, newLen);
 660 memcpy(str + index + newLen, oldStr + index + len, oldLen - index - len);
 661
 662 cellStr->contents = (UINT)str;
 663 cellStr->aux = oldLen + newLen - len + 1;
 664
 665 if(typeFlag != 2)
 666         {
 667         new = stuffStringN(oldStr + index, len);
 668         freeMemory(oldStr);
 669         return(new);
 670         }
 671
 672 freeMemory(oldStr);
 673 return(copyCell(cellStr));
 674 }
 675
 676
 677 CELL * popString(CELL * str, CELL * params)
 678 {
 679 char * ptr;
 680 char * newPtr;
 681 ssize_t index = 0;
 682 ssize_t len = 1;
 683 CELL * result;
 684
 685 if(str->aux < 2)
 686         return(stuffString(""));
 687
 688 if(params != nilCell)
 689         {
 690         params = getInteger(params, (UINT*)&index);
 691         if(params != nilCell)
 692                 {
 693                 getInteger(params, (UINT*)&len);
 694                 if(len < 1) len = 0;
 695                 }
 696         }
 697
 698 ptr = (char *)str->contents;
 699
 700 #ifndef SUPPORT_UTF8
 701 index = adjustNegativeIndex(index, str->aux - 1);
 702 #else
 703 index = adjustNegativeIndex(index, utf8_wlen(ptr));
 704 #endif
 705
 706 if((index + len) > (str->aux - 2))
 707         len = str->aux - 1 - index;
 708
 709 newPtr = callocMemory(str->aux - len);
 710
 711 memcpy(newPtr, ptr, index);
 712 memcpy(newPtr + index, ptr + index + len, str->aux - len - index);
 713 str->aux = str->aux - len;
 714 str->contents = (UINT)newPtr;
 715 result = stuffStringN(ptr + index, len);
 716 free(ptr);
 717 return(result);
 718 }
 719
 720
 721 CELL * pushOnString(CELL * newStr, CELL * str, CELL * idx)
 722 {
 723 ssize_t index = 0;
 724 char * ptr;
 725 char * newPtr;
 726 int minusFlag;
 727 int len;
 728 #ifdef SUPPORT_UTF8
 729 char * sptr;
 730 int wChar;
 731 #endif
 732
 733 if(idx != nilCell) getInteger(idx, (UINT*)&index);
 734 ptr = (char *)str->contents;
 735
 736 if(newStr->type != CELL_STRING)
 737         return(errorProcExt(ERR_STRING_EXPECTED, newStr));
 738
 739 if(index == -1)
 740         {
 741         appendCellString(str, (char *)newStr->contents, newStr->aux - 1);
 742         return(copyCell(newStr));
 743         }
 744
 745 minusFlag = (index < 0);
 746
 747 #ifndef SUPPORT_UTF8
 748 len = str->aux - 1;
 749 #else
 750 len = utf8_wlen(ptr);
 751 #endif
 752
 753 /* convert index into characters to skip before the new one is inserted */
 754 if(index < 0) index = len + index + 1;
 755 else if(index > len) index = len;
 756 if(index < 0) index = 0;
 757
 758 newPtr = callocMemory(str->aux + newStr->aux - 1);
 759 #ifndef SUPPORT_UTF8
 760 memcpy(newPtr, ptr, index);
 761 memcpy(newPtr + index, (char*)newStr->contents, newStr->aux - 1);
 762 memcpy(newPtr + index + newStr->aux - 1, ptr + index, str->aux - index);
 763 #else
 764 sptr = ptr;
 765 while(index--) /* skip characters to split point) */
 766         sptr = utf8_wchar(sptr, &wChar);
 767 memcpy(newPtr, ptr, sptr - ptr);
 768 memcpy(newPtr + (sptr - ptr), (char*)newStr->contents, newStr->aux - 1);
 769 memcpy(newPtr + (sptr - ptr) + newStr->aux - 1, sptr, str->aux - (sptr - ptr)  );
 770 #endif
 771
 772 str->contents = (UINT)newPtr;
 773 str->aux = str->aux + newStr->aux - 1;
 774 *(newPtr + str->aux - 1) = 0;
 775 free(ptr);
 776
 777 return(copyCell(newStr));
 778 }
 779
 780
 781 CELL * p_select(CELL * params)
 782 {
 783 size_t n = 0, idx  = 0;
 784 ssize_t index;
 785 CELL * list, * cell;
 786 CELL * result = NULL;
 787 CELL * head;
 788 int evalFlag = TRUE;
 789 char * str, * newStr;
 790 #ifdef SUPPORT_UTF8
 791 int * wstr;
 792 int * wnewStr;
 793 size_t len;
 794 #endif
 795
 796 head = evaluateExpression(params);
 797 params = params->next;
 798 cell = evaluateExpression(params);
 799 if(isList(cell->type))
 800         {
 801         evalFlag = FALSE;
 802         cell = params = (CELL *)cell->contents;
 803         }
 804
 805 if(head->type == CELL_STRING)
 806         {
 807         if((n = listlen(params)) == 0) return(stuffString(""));
 808
 809         str = (char *)head->contents;
 810 #ifndef SUPPORT_UTF8
 811         newStr = (char *)allocMemory(n + 1);
 812         idx = 0;
 813         while(params->type != CELL_NIL)
 814                 {
 815                 if(idx == 0)
 816                         {
 817                         getIntegerExt(cell, (UINT *)&index, FALSE);
 818                         params = params->next;
 819                         }
 820                 else
 821                         params = getIntegerExt(params, (UINT *)&index, evalFlag);
 822                 index = adjustNegativeIndex(index, head->aux -1);
 823                 *(newStr + idx++) = *(str + index);
 824                 }
 825         *(newStr + n) = 0;
 826 #else
 827         wstr = allocMemory(head->aux * sizeof(int));
 828         len = utf8_wstr(wstr, str, head->aux - 1);
 829         wnewStr = allocMemory((n + 1) * sizeof(int));
 830         idx = 0;
 831         while(params->type != CELL_NIL)
 832                 {
 833                 if(idx == 0)
 834                         {
 835                         getIntegerExt(cell, (UINT *)&index, FALSE);
 836                         params = params->next;
 837                         }
 838                 else
 839                         params = getIntegerExt(params, (UINT *)&index, evalFlag);
 840                 index = adjustNegativeIndex(index, len);
 841                 *(wnewStr + idx++) = *(wstr + index);
 842                 }
 843         *(wnewStr + n) = 0;
 844         newStr = allocMemory(UTF8_MAX_BYTES * n + 1);
 845         n = wstr_utf8(newStr, wnewStr, UTF8_MAX_BYTES * n);
 846         newStr = reallocMemory(newStr, n + 1);
 847 #endif
 848         result = getCell(CELL_STRING);
 849         result->aux = n + 1;
 850         result->contents = (UINT)newStr;
 851         return(result);
 852         }
 853
 854 if(!isList(head->type))
 855         return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, head));
 856 head = (CELL *)head->contents;
 857 list = head;
 858 n = 0;
 859 while(params->type != CELL_NIL)
 860         {
 861         if(n++ == 0)
 862                 {
 863                 getIntegerExt(cell, (UINT *)&index, FALSE);
 864                 params = params->next;
 865                 }
 866         else
 867                 params = getIntegerExt(params, (UINT *)&index, evalFlag);
 868         if(index < 0) index = convertNegativeOffset(index, head);
 869         if(index < idx) list = head, idx = 0;
 870         while(idx < index  && list->next != nilCell) list = list->next, idx++;
 871         if(result == NULL)
 872                 {
 873                 result = getCell(CELL_EXPRESSION);
 874                 cell = copyCell(list);
 875                 result->contents = (UINT)cell;
 876                 }
 877         else
 878                 {
 879                 cell->next = copyCell(list);
 880                 cell = cell->next;
 881                 }
 882         }
 883
 884 return((result == NULL) ? getCell(CELL_EXPRESSION) : result);
 885 }
 886
 887
 888 CELL * p_slice(CELL * params)
 889 {
 890 CELL * cell;
 891 ssize_t offset;
 892 ssize_t length;
 893
 894 cell = evaluateExpression(params);
 895 params = getInteger(params->next, (UINT *)&offset);
 896 if(params != nilCell)
 897         getInteger(params, (UINT *)&length);
 898 else
 899         length = MAX_LONG;
 900
 901 if(isList(cell->type))
 902         return(sublist((CELL *)cell->contents, offset, length));
 903 else if(cell->type == CELL_STRING)
 904         return(substring((char *)cell->contents, cell->aux - 1, offset, length));
 905 else if(cell->type == CELL_ARRAY)
 906         return(subarray(cell, offset, length));
 907
 908 return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params));
 909 }
 910
 911
 912 CELL * sublist(CELL * list, ssize_t offset, ssize_t length)
 913 {
 914 CELL * subList;
 915 CELL * cell;
 916
 917 if(offset < 0)
 918         offset = convertNegativeOffset(offset, list);
 919
 920 if(length < 0)
 921         {
 922         length = listlen(list) - offset + length;
 923         if(length < 0) length = 0;
 924         }
 925
 926 subList = getCell(CELL_EXPRESSION);
 927 if(length == 0) return(subList);
 928
 929 while(offset-- && list != nilCell)
 930         list = list->next;
 931
 932 if(list == nilCell) return(subList);
 933
 934 cell = copyCell(list);
 935 subList->contents = (UINT)cell;
 936 --length;
 937 while(length--)
 938         {
 939         list = list->next;
 940         if(list == nilCell) break;
 941         cell->next = copyCell(list);
 942         cell = cell->next;
 943         }
 944
 945 return(subList);
 946 }
 947
 948
 949 CELL * p_reverse(CELL * params)
 950 {
 951 CELL * cell;
 952 CELL * previous;
 953 CELL * next;
 954 char * str;
 955 size_t len, tmp;
 956 char * left;
 957 char * right;
 958
 959 cell = params;
 960 params = evalCheckProtected(params, NULL);
 961
 962
 963 if(isList(params->type))
 964         {
 965         params->aux = (UINT)nilCell; /* undo last element optimization */
 966
 967         previous = cell = (CELL*)params->contents;
 968         next = cell->next;
 969         cell->next = nilCell;
 970         while(cell!= nilCell)
 971                 {
 972                 previous = cell;
 973                 cell = next;
 974                 next = cell->next;
 975                 if(cell != nilCell) cell->next = previous;
 976                 }
 977         params->contents = (UINT)previous;
 978         }
 979
 980 else if(params->type == CELL_STRING)
 981         {
 982         str = (char *)params->contents;
 983         len = params->aux - 1;
 984         left = str;
 985         right = left + len - 1;
 986         while(left < right)
 987                 {
 988                 tmp = *left;
 989                 *left = *right;
 990                 *right = tmp;
 991                 left++;
 992                 right--;
 993                 }
 994         }
 995 else return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, cell));
 996
 997 return(copyCell(params));
 998 }
 999
1000
1001 CELL * p_join(CELL * params)
1002 {
1003 char * joint = NULL;
1004 CELL * list;
1005 size_t jointLen = 0;
1006 int trailJoint = 0;
1007
1008 params = getListHead(params, &list);
1009 if(list == nilCell)
1010         return(stuffString(""));
1011
1012 if(list->type != CELL_STRING)
1013         return(errorProcExt(ERR_STRING_EXPECTED, list));
1014
1015 if(params != nilCell)
1016         {
1017         params = getStringSize(params, &joint, &jointLen, TRUE);
1018         trailJoint = getFlag(params);
1019         }
1020
1021 return(appendString(list, list->next, joint, jointLen, trailJoint, FALSE));
1022 }
1023
1024
1025 CELL * p_find(CELL * params)
1026 {
1027 char * key;
1028 char * second;
1029 ssize_t found;
1030 CELL * next;
1031 CELL * keyCell;
1032 CELL * funcCell;
1033 size_t size;
1034 long options;
1035
1036 keyCell = evaluateExpression(params);
1037 params = params->next;
1038 next = evaluateExpression(params);
1039
1040 if(keyCell->type == CELL_STRING && next->type == CELL_STRING)
1041         {
1042         key = (char *)keyCell->contents;
1043         second = (char *)next->contents;
1044         size = next->aux - 1;
1045
1046         if(params->next != nilCell)
1047             {
1048             params = getInteger(params->next, (UINT*)&options);
1049             found = searchBufferRegex(second, 0, key, (int)size, options, NULL);
1050             if(found == -1) return(nilCell);
1051             }
1052         else
1053             {
1054             found = searchBuffer(second, size, key, keyCell->aux - 1, TRUE);
1055             if(found == -1) return(nilCell);
1056             }
1057         }
1058 else
1059         {
1060     /* list mode with optional functor */
1061
1062         if(!isList(next->type)) return(nilCell);
1063         next = (CELL *)next->contents;
1064         found = 0;
1065
1066         if(params->next != nilCell)
1067                 funcCell = evaluateExpression(params->next);
1068         else funcCell = NULL;
1069
1070         /* do regex when first arg is string and option# is present */
1071         if(funcCell && isNumber(funcCell->type) && keyCell->type == CELL_STRING)
1072         {
1073         getIntegerExt(funcCell, (UINT*)&options, FALSE);
1074         key = (char *)keyCell->contents;
1075         while(next != nilCell)
1076                 {
1077                 if(next->type == CELL_STRING)
1078                 {
1079                 second = (char *)next->contents;
1080                 if(searchBufferRegex(second, 0, key, next->aux - 1 , options, NULL) != -1)
1081                         break;
1082                 }
1083                 found++;
1084                 next = next->next;
1085                 }
1086         if(next == nilCell) return(nilCell);
1087                 else return(stuffInteger(found));
1088         }
1089
1090     while(next != nilCell)
1091                 {
1092                 if(compareFunc(keyCell, next, funcCell) == 0)
1093                         {
1094                         if(funcCell)
1095                                 {
1096                                 deleteList((CELL*)sysSymbol[0]->contents);
1097                                 sysSymbol[0]->contents = (UINT)copyCell(next);
1098                                 }
1099                         break;
1100                         }
1101                 found++;
1102                 next = next->next;
1103                 }
1104         if(next == nilCell) return(nilCell);
1105         }
1106
1107 return(stuffInteger(found));
1108 }
1109
1110 /* ------- find-all ---- finds all strings matching a pattern in a list ----- */
1111
1112 CELL * findAllString(char * pattern, char * str, size_t size, CELL * params)
1113 {
1114 long options = 0;
1115 ssize_t findPos = -1;
1116 int len;
1117 int offset = 0;
1118 CELL * result = nilCell;
1119 CELL * cell = NULL;
1120 CELL * exprCell;
1121 CELL * exprRes;
1122 int errNo;
1123
1124 exprCell = params;
1125 params = params->next;
1126 if(params != nilCell)
1127         getInteger(params, (UINT *)&options);
1128
1129 while( (findPos = searchBufferRegex(str, offset, pattern, (int)size, options, &len)) != -1)
1130         {
1131         if(exprCell != nilCell)
1132                 {
1133                 if((exprRes = evaluateExpressionSafe(exprCell, &errNo)) == NULL)
1134                 {
1135                         pushResult(result); /* push for later deletion */
1136                 longjmp(errorJump, errNo);
1137                 }
1138                 exprRes = copyCell(exprRes);
1139                 }
1140         else
1141                 exprRes = stuffStringN(str + findPos, len);
1142
1143         if(findPos == offset && len == 0) break;
1144
1145         if(result == nilCell)
1146                 {
1147                 result = getCell(CELL_EXPRESSION);
1148                 cell = exprRes;
1149                 result->contents = (UINT)cell;
1150                 }
1151         else
1152                 {
1153                 cell->next = exprRes;
1154                 cell = cell->next;
1155                 }
1156
1157         offset = (findPos + len);
1158         }
1159
1160 if(result == nilCell)
1161         return(getCell(CELL_EXPRESSION));
1162
1163 return(result);
1164 }
1165
1166
1167 CELL * findAllList(CELL * pattern, CELL * list, CELL * exprCell)
1168 {
1169 CELL * result = nilCell;
1170 CELL * cell = NULL;
1171 CELL * exprRes;
1172 CELL * match;
1173 CELL * funcCell;
1174 int errNo;
1175 int resultIdxSave;
1176
1177 funcCell = evaluateExpression(exprCell->next);
1178 resultIdxSave = resultStackIdx;
1179
1180 if(funcCell == nilCell && !isList(pattern->type))
1181         return(errorProcExt(ERR_LIST_EXPECTED, pattern));
1182
1183 while(list != nilCell)
1184         {
1185         if(funcCell == nilCell)
1186                 {
1187                 /* match only takes lists*/
1188                 if(!isList(list->type))
1189                         goto CONTINUE_NEXT;
1190
1191                 match = patternMatchL((CELL *)pattern->contents, (CELL *)list->contents, TRUE);
1192
1193                 if(match == NULL || match == nilCell)
1194                         goto CONTINUE_NEXT;
1195
1196                 deleteList(match);
1197                 }
1198         else
1199                 {
1200                 cleanupResults(resultIdxSave);
1201                 if(compareFunc(pattern, list, funcCell) != 0)
1202                         goto CONTINUE_NEXT;
1203                 }
1204
1205         deleteList((CELL*)sysSymbol[0]->contents);
1206         sysSymbol[0]->contents = (UINT)copyCell(list);
1207
1208         if(exprCell != nilCell)
1209                 {
1210                 if((exprRes = evaluateExpressionSafe(exprCell, &errNo)) == NULL)
1211                 {
1212                         pushResult(result); /* push for later deletion */
1213                         longjmp(errorJump, errNo);
1214                         }
1215                 }
1216         else
1217                 exprRes = list;
1218
1219         exprRes = copyCell(exprRes);
1220
1221
1222         if(result == nilCell)
1223                 {
1224                 result = getCell(CELL_EXPRESSION);
1225                 cell = exprRes;
1226                 result->contents = (UINT)cell;
1227                 }
1228         else
1229                 {
1230                 cell->next = exprRes;
1231                 cell = cell->next;
1232                 }
1233
1234         CONTINUE_NEXT:
1235         list = list->next;
1236         }
1237
1238 if(result == nilCell)
1239         return(getCell(CELL_EXPRESSION));
1240
1241 return(result);
1242 }
1243
1244
1245 CELL * p_findAll(CELL * params)
1246 {
1247 CELL * key;
1248 CELL * space;
1249
1250 key = evaluateExpression(params);
1251 params = params->next;
1252 space = evaluateExpression(params);
1253
1254 if(key->type == CELL_STRING && space->type == CELL_STRING)
1255         return(findAllString((char *)key->contents,
1256                         (char *)space->contents,  (size_t) space->aux - 1, params->next));
1257
1258 if(!isList(space->type))
1259         return(errorProcExt(ERR_LIST_EXPECTED, space));
1260
1261 return(findAllList(key, (CELL *)space->contents, params->next));
1262 }
1263
1264
1265 void swap(UINT * left, UINT * right)
1266 {
1267 UINT tmp;
1268
1269 tmp = *left;
1270 *left = *right;
1271 *right = tmp;
1272 }
1273
1274 SYMBOL * getSymbolCheckProtected(CELL * params)
1275 {
1276 SYMBOL * sPtr = NULL;
1277
1278 if(params->type == CELL_DYN_SYMBOL)
1279         sPtr = getDynamicSymbol(params);
1280 else if(params->type == CELL_SYMBOL)
1281         sPtr = (SYMBOL *)params->contents;
1282 else fatalError(ERR_SYMBOL_EXPECTED, params, FALSE);
1283
1284 if(isProtected(sPtr->flags))
1285         fatalError(ERR_SYMBOL_PROTECTED, params, FALSE);
1286
1287 return sPtr;
1288 }
1289
1290 CELL * p_swap(CELL * params)
1291 {
1292 size_t first, second, num;
1293 char * str;
1294 CELL * envelope;
1295 CELL * list;
1296 CELL * firstCell;
1297 CELL * secondCell;
1298 SYMBOL * lsym;
1299 SYMBOL * rsym;
1300
1301 if(((CELL *)params->next)->next == nilCell)
1302         {
1303         lsym = getSymbolCheckProtected(params);
1304         rsym = getSymbolCheckProtected(params->next);
1305         swap(&lsym->contents, &rsym->contents);
1306         return(copyCell((CELL*)rsym->contents));
1307         }
1308
1309 params = getInteger(params, (UINT*)&first);
1310 params = getInteger(params, (UINT*)&second);
1311
1312 envelope = evalCheckProtected(params, NULL);
1313
1314 if(envelope->type == CELL_STRING)
1315         {
1316         first = adjustNegativeIndex(first, envelope->aux - 1);
1317         second = adjustNegativeIndex(second, envelope->aux - 1);
1318         str = (char *)envelope->contents;
1319         num = str[first];
1320         str[first] = str[second];
1321         str[second] = num;
1322         return(copyCell(envelope));
1323         }
1324
1325 if(!isList(envelope->type))
1326         return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params));
1327
1328 envelope->aux = (UINT)nilCell; /* undo last element optimization */
1329
1330 list = (CELL *)envelope->contents;
1331
1332 if(first < 0) first = convertNegativeOffset(first, list);
1333 if(second < 0) second = convertNegativeOffset(second, list);
1334
1335 if(first > second) swap((UINT*)&first, (UINT*)&second);
1336 second = second - first;
1337
1338 firstCell = list;
1339 while(first--)
1340         {
1341         if(firstCell->next == nilCell) break;
1342         firstCell = firstCell->next;
1343         }
1344 secondCell = firstCell;
1345
1346 while(second--)
1347         {
1348         if(secondCell->next == nilCell) break;
1349         secondCell = secondCell->next;
1350         }
1351
1352 swap(&firstCell->type, &secondCell->type);
1353 swap(&firstCell->contents, &secondCell->contents);
1354 swap(&firstCell->aux, &secondCell->aux);
1355
1356 return(copyCell(envelope));
1357 }
1358
1359
1360 CELL * p_dup(CELL * params)
1361 {
1362 CELL * list;
1363 CELL * expr;
1364 char * str;
1365 ssize_t n, len;
1366
1367 expr = evaluateExpression(params);
1368 params = params->next;
1369 if(params != nilCell)
1370         getInteger(params, (UINT *)&n);
1371 else n = 2;
1372
1373 if(n < 0) n = 0;
1374
1375 if(expr->type == CELL_STRING && !getFlag(params->next) )
1376         {
1377         len = expr->aux - 1;
1378         list = getCell(CELL_STRING);
1379         str = allocMemory(len * n + 1);
1380         list->contents = (UINT)str;
1381         list->aux = (len * n + 1);
1382         *(str + len * n) = 0;
1383         while(n--)
1384                 {
1385                 memcpy(str, (char *)expr->contents, len);
1386                 str += len;
1387                 }
1388         return(list);
1389         }
1390
1391 list = getCell(CELL_EXPRESSION);
1392 if(n-- > 0)
1393         {
1394         list->contents = (UINT)copyCell(expr);
1395
1396         params = (CELL *)list->contents;
1397         while(n--)
1398                 {
1399                 params->next = copyCell(expr);
1400                 params = params->next;
1401                 }
1402         }
1403
1404 return(list);
1405 }
1406
1407
1408 #define STARTS_WITH 0
1409 #define ENDS_WITH 1
1410
1411 CELL * startsEndsWith(CELL * params, int type)
1412 {
1413 char * string;
1414 char * key;
1415 char * keydollar;
1416 long options = -1;
1417 size_t slen, pos;
1418 int klen;
1419 CELL * cell, * list;
1420
1421 cell = params->next;
1422 list = evaluateExpression(params);
1423 if(list->type == CELL_STRING)
1424     {
1425     string = (char *)list->contents;
1426     getString(cell, &key);
1427     }
1428 else
1429     {
1430     if(!isList(list->type))
1431         errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params);
1432     cell = evaluateExpression(cell);
1433     list = (CELL *)list->contents;
1434
1435     if(type == ENDS_WITH)
1436         while(list->next != nilCell) list = list->next;
1437
1438     if(compareCells(list, cell) == 0) return(trueCell);
1439     else return(nilCell);
1440     }
1441
1442 if(cell->next != nilCell)
1443         {
1444         if(evaluateExpression(cell->next)->type == CELL_NIL)
1445                 options = 1;
1446         else
1447                 getIntegerExt(cell->next, (UINT*)&options, FALSE);
1448         }
1449
1450 klen = strlen(key);
1451 slen = strlen(string);
1452
1453 if(type == STARTS_WITH)
1454         {
1455         if(options == -1)
1456                 {
1457                 if(strncmp(string, key, (size_t)klen) == 0)
1458                         return(trueCell);
1459                 }
1460         else
1461                 {
1462         if(searchBufferRegex(string, 0, key, slen, options, 0) == 0)
1463                         return(trueCell);
1464                 }
1465         return(nilCell);
1466         }
1467
1468
1469 if((options == -1) && (klen > slen)) return(nilCell);
1470
1471 if(options == -1)
1472         {
1473         if(strncmp(string + slen - klen, key, klen) == 0)
1474                 return(trueCell);
1475         }
1476 else
1477         {
1478         /* append $ to the pattern for anchoring at the end */
1479         keydollar = malloc(klen + 4);
1480         *keydollar = '(';
1481         memcpy(keydollar + 1, key, klen);
1482         memcpy(keydollar + 1 + klen, ")$", 2);
1483         *(keydollar + klen + 3) = 0;
1484         klen = klen + 3;
1485     if((pos = searchBufferRegex(string, 0, keydollar, slen, options, &klen)) != -1)
1486                 {
1487                 free(keydollar);
1488                 if(pos + klen == slen)
1489                         return(trueCell);
1490                 }
1491         free(keydollar);
1492         }
1493
1494 return(nilCell);
1495 }
1496
1497 CELL * p_startsWith(CELL * params) { return startsEndsWith(params, STARTS_WITH); }
1498 CELL * p_endsWith(CELL * params) { return startsEndsWith(params, ENDS_WITH); }
1499
1500 CELL * p_replace(CELL * params)
1501 {
1502 CELL * keyCell;
1503 CELL * repCell;
1504 CELL * funcCell = NULL;
1505 CELL * list;
1506 CELL * cell;
1507 CELL * newList;
1508 char * keyStr;
1509 char * buff;
1510 char * newBuff;
1511 UINT cnt;
1512 size_t newLen;
1513 long options;
1514 int resultIdxSave;
1515
1516 keyCell = evaluateExpression(params);
1517 params = params->next;
1518
1519 newList = cell = evalCheckProtected(params, NULL);
1520
1521
1522 cnt = 0;
1523 resultIdxSave = resultStackIdx;
1524 if(isList(cell->type))
1525         {
1526         cell->aux = (UINT)nilCell; /* undo last element optimization */
1527
1528         list = (CELL *)cell->contents;
1529
1530         if(params->next != nilCell)
1531                 {
1532                 params = params->next;
1533                 repCell = params;
1534                 if(params->next != nilCell)
1535                         funcCell = evaluateExpression(params->next);
1536                 }
1537         else
1538                 repCell = NULL;
1539 COMPARE_START:
1540         if(compareFunc(keyCell, list, funcCell) == 0)
1541                 {
1542                 if(repCell != NULL)
1543                         {
1544                         deleteList((CELL*)sysSymbol[0]->contents);
1545                         sysSymbol[0]->contents = (UINT)copyCell(list);
1546                         cell->contents = (UINT)copyCell(evaluateExpression(repCell));
1547                         cell = (CELL*)cell->contents;
1548                         cell->next = list->next;
1549                         }
1550                 else /* remove mode */
1551                         cell->contents = (UINT)list->next;
1552
1553                 list->next = nilCell;
1554                 deleteList(list);
1555                 cnt++;
1556
1557                 if(repCell != NULL)
1558                         list = cell;
1559                 else /* remove mode */
1560                         {
1561                         list = (CELL*)cell->contents;
1562                         goto COMPARE_START;
1563                         }
1564                 }
1565
1566         while(list->next != nilCell)
1567                 {
1568                 if(compareFunc(keyCell, list->next, funcCell) == 0)
1569                         {
1570                         cell = list->next;      /* cell = old elmnt */
1571                         if(repCell != NULL)
1572                                 {
1573                                 deleteList((CELL*)sysSymbol[0]->contents);
1574                                 sysSymbol[0]->contents = (UINT)copyCell(cell);
1575                                 list->next = copyCell(evaluateExpression(repCell));
1576                                 list = list->next;
1577                                 }
1578                         list->next = cell->next;
1579                         cell->next = nilCell;
1580                         deleteList(cell);
1581                         cnt++;
1582                         }
1583                 else
1584                         list = list->next;
1585                 cleanupResults(resultIdxSave);
1586                 }
1587
1588         deleteList((CELL*)sysSymbol[0]->contents);
1589         sysSymbol[0]->contents = (UINT)stuffInteger(cnt);
1590         return(copyCell(newList));
1591         }
1592
1593 if(cell->type == CELL_STRING)
1594         {
1595         if(keyCell->type != CELL_STRING)
1596                 return(errorProc(ERR_STRING_EXPECTED));
1597         keyStr = (char *)keyCell->contents;
1598         buff = (char *)cell->contents;
1599         repCell = params->next;
1600
1601         if(repCell == nilCell)
1602                 return(errorProc(ERR_MISSING_ARGUMENT));
1603
1604         options = -1;
1605         if(repCell->next != nilCell)
1606             getInteger(repCell->next, (UINT*)&options);
1607
1608         newBuff = replaceString(keyStr, keyCell->aux - 1,
1609                                buff, (size_t)cell->aux -1, repCell, &cnt, options, &newLen);
1610         if(newBuff != NULL)
1611             {
1612             freeMemory(buff);
1613             cell->contents = (UINT)newBuff;
1614             cell->aux = newLen + 1;
1615             }
1616
1617         deleteList((CELL*)sysSymbol[0]->contents);
1618         sysSymbol[0]->contents = (UINT)stuffInteger(cnt);
1619         return(copyCell(cell));
1620         }
1621
1622 return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params));
1623 }
1624
1625
1626
1627 CELL * p_rotate(CELL * params)
1628 {
1629 CELL * cell;
1630 CELL * previous;
1631 CELL * last = NULL;
1632 size_t length, index;
1633 size_t count;
1634
1635 cell = params;
1636
1637 if(cell->next != nilCell) getInteger(cell->next, (UINT *)&count);
1638 else count = 1;
1639
1640 params = evalCheckProtected(params, NULL);
1641
1642 if(params->type == CELL_STRING)
1643         {
1644         cell = copyCell(params);
1645         length = params->aux - 1;
1646         if((count = adjustCount(count, length)) == 0) return(cell);
1647         memcpy((char*)cell->contents, (char *)(params->contents + length - count), count);
1648         memcpy((char*)(cell->contents + count), (char *)params->contents, length - count);
1649         memcpy((char*)params->contents, (char*)cell->contents, length);
1650         return(cell);
1651         }
1652
1653 if(!isList(params->type))
1654         return(errorProcExt(ERR_LIST_EXPECTED, cell));
1655
1656 params->aux = (UINT)nilCell; /* undo last element optimization */
1657
1658 cell = (CELL *)params->contents;
1659 length = 0;
1660 while(cell != nilCell)
1661         {
1662         ++length;
1663         last = cell;
1664         cell = cell->next;
1665         }
1666
1667 if((count = adjustCount(count, length))== 0)
1668         return(copyCell(params));
1669 index = length - count;
1670
1671 previous = cell = (CELL *)params->contents;
1672 while(index--)
1673         {
1674         previous = cell;
1675         cell = cell->next;
1676         }
1677
1678 previous->next = nilCell;
1679 last->next = (CELL *)params->contents;
1680 params->contents = (UINT)cell;
1681
1682 return(copyCell(params));
1683 }
1684
1685 /* eof */