1 /****************************************************************/
2 /* file array.c
3 
4 ARIBAS interpreter for Arithmetic
5 Copyright (C) 1996-2007 O.Forster
6 
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11 
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 GNU General Public License for more details.
16 
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 
21 Address of the author
22 
23     Otto Forster
24     Math. Institut der LMU
25     Theresienstr. 39
26     D-80333 Muenchen, Germany
27 
28 Email   forster@mathematik.uni-muenchen.de
29 */
30 /****************************************************************/
31 
32 /*
33 ** array.c
34 ** array, string, byte_string, record and stack procedures
35 **
36 ** date of last change
37 ** 1995-03-05:  Findex changed
38 ** 1995-03-20:  ARGV sSYSTEMVAR
39 ** 1995-04-03:  records, pointer
40 ** 1995-04-07:  alloc
41 ** 1996-10-03:  max_arraysize
42 ** 1997-01-29:  Fbstring
43 ** 1997-02-11:  ARIBUFSIZE -> aribufSize in Fstrsplit
44 ** 1997-03-25:  Fstrsplit now PRIVATE
45 ** 1997-03-29:  changed function bytestraddr
46 ** 1997-04-13:  reorg (newintsym)
47 ** 1997-08-01:  removed create_array
48 ** 2000-01-02:  fixed bug in byteswap()
49 ** 2001-06-17:  corrected type in error message
50 ** 2002-03-08:  changed direction of sort with user defined sort fcn
51 ** 2002-03-28:  functions string_scan, stack2string, stack_arraypush, realloc
52 ** 2002-04-14:  function binsearch
53 ** 2002-08-05:  small change in GmemBB
54 ** 2003-02-11:  mkcopy in Fbstring and Ftextstring
55 ** 2003-06-06:  mkcopy in Srecfield, Farrele and Fstkpush
56 ** 2007-07-24:  bug fix in Fstkpush
57 */
58 
59 #include "common.h"
60 
61 #define QUICKSORT
62 
63 PUBLIC truc arraysym, stringsym, charsym, stacksym;
64 PUBLIC truc vectorsym, pairsym;
65 PUBLIC truc mkarrsym, mkstrsym, mkbstrsym;
66 PUBLIC truc nullstring, nullbstring;
67 PUBLIC truc bstringsym, bstr_sym, str_sym;
68 PUBLIC truc ofsym;
69 PUBLIC truc arr_sym, subarrsym;
70 PUBLIC truc recordsym, mkrecsym, rec_sym, pointrsym, derefsym;
71 
72 /**** Prototypen exportierter Funktionen ****/
73 PUBLIC void iniarray    _((void));
74 PUBLIC void iniargv     _((int argc, char *argv[]));
75 PUBLIC int stringsplit  _((char *str, char *trenn, word2 *offsets));
76 PUBLIC int indrange     _((truc *ptr, long len, long *pn0, long *pn1));
77 PUBLIC truc arrassign   _((truc *arr, truc obj));
78 PUBLIC truc subarrassign  _((truc *arr, truc obj));
79 PUBLIC void sortarr     _((truc *arr, unsigned len, ifuntt cmpfun));
80 PUBLIC int bytestraddr  _((truc *ptr, truc **ppbstr, byte **ppch,
81                         unsigned *plen));
82 PUBLIC truc fullrecassign  _((truc *rptr, truc obj));
83 PUBLIC truc recfassign  _((truc *rptr, truc field, truc obj));
84 PUBLIC truc Pdispose    _((truc *ptr));
85 
86 /******* Modulglobale Variablen **********/
87 PRIVATE truc argvsym;
88 
89 PRIVATE truc lengthsym, maxarrsym;
90 PRIVATE truc concatsym, splitsym, toupsym, tolowsym, indexsym, sscansym;
91 PRIVATE truc pushsym, popsym, topsym, resetsym, emptysym;
92 PRIVATE truc stk2arrsym, stk2strsym, arrpushsym;
93 PRIVATE truc chrsym, ordsym;
94 PRIVATE truc sortsym, bsearchsym;
95 PRIVATE truc mbtestsym, mbsetsym, mbclrsym, mshiftsym;
96 PRIVATE truc mandsym, morsym, mxorsym, mnotsym, mbitswsym, mbyteswsym;
97 PRIVATE truc mknewsym, allocsym, reallocsym;
98 
99 
100 /******* Prototypen modul-interner Funktionen ******/
101 PRIVATE truc Flength    _((void));
102 PRIVATE truc Fchr       _((void));
103 PRIVATE truc Ford       _((void));
104 PRIVATE truc Fvector    _((int argn));
105 PRIVATE truc Fpair      _((void));
106 PRIVATE truc Fmkarray   _((int argn));
107 PRIVATE truc Falloc     _((int argn));
108 PRIVATE truc Srealloc   _((void));
109 PRIVATE truc Fmkstring  _((void));
110 PRIVATE truc mkstring   _((truc *ptr, int flg, int ch));
111 PRIVATE truc Fmkbstring _((void));
112 PRIVATE truc Fconcat    _((int argn));
113 PRIVATE truc Findex     _((void));
114 PRIVATE long substrindex  _((byte *str, size_t len, byte *sub, size_t len1));
115 PRIVATE truc Fstrsplit  _((int argn));
116 PRIVATE truc Fstrscan   _((int argn));
117 PRIVATE truc Ftolower   _((void));
118 PRIVATE truc Ftoupper   _((void));
119 PRIVATE truc Gchangecase  _((truc symb));
120 PRIVATE truc Farrele    _((void));
121 PRIVATE truc Fsubarr    _((void));
122 PRIVATE int arrindex    _((truc *ptr, long *pindex));
123 PRIVATE char *stringele  _((truc *ptr, long index));
124 PRIVATE truc *vectele   _((truc *ptr, long index));
125 PRIVATE int arrcompat   _((int flg1, int flg2));
126 PRIVATE long stacklength  _((truc *ptr));
127 PRIVATE truc Fstkpush   _((void));
128 PRIVATE truc Fstkarrpush  _((int argn));
129 PRIVATE truc Fstkpop    _((void));
130 PRIVATE truc Fstktop    _((void));
131 PRIVATE truc Gstkretr   _((truc symb));
132 PRIVATE truc Fstkreset  _((void));
133 PRIVATE truc Fstkempty  _((void));
134 PRIVATE truc Fstk2array  _((void));
135 PRIVATE truc Fstk2string _((void));
136 PRIVATE truc Fmaxarray   _((void));
137 PRIVATE int compfun _((truc *ptr1, truc *ptr2));
138 PRIVATE int ucompfun    _((truc *ptr1, truc *ptr2));
139 PRIVATE truc Ssort  _((void));
140 PRIVATE truc Hsort1 _((truc *argptr));
141 PRIVATE truc Hsort2 _((truc *argptr, truc fun));
142 PRIVATE truc Fbsearch   _((int argn));
143 PRIVATE truc Hbsearch1  _((truc *ele, truc *vptr, int flg));
144 PRIVATE int vectaddr    _((truc *ptr, truc **ppvec, truc **parr,
145                     unsigned *plen));
146 PRIVATE truc Ftextstring  _((void));
147 PRIVATE truc Fbstring   _((int argn));
148 PRIVATE truc Smembtest  _((void));
149 PRIVATE truc Smembset   _((void));
150 PRIVATE truc Smembclear _((void));
151 PRIVATE truc Smemshift  _((void));
152 PRIVATE truc Smemand    _((void));
153 PRIVATE truc Smemor _((void));
154 PRIVATE truc Smemxor    _((void));
155 PRIVATE truc Smemnot    _((void));
156 PRIVATE truc Smembitsw  _((void));
157 PRIVATE truc Smembytesw _((void));
158 PRIVATE truc GmemBi _((truc symb));
159 PRIVATE truc GmemBB _((truc symb));
160 PRIVATE void byteshift  _((byte *ptr, unsigned len, long sh));
161 PRIVATE void byteswap   _((byte *ptr, unsigned len, unsigned grp));
162 
163 PRIVATE int Paddr   _((truc *ptr, trucptr *pvptr));
164 PRIVATE truc Fmkrec0    _((void));
165 PRIVATE truc Srecfield  _((void));
166 PRIVATE truc Sderef _((void));
167 PRIVATE truc Snew   _((void));
168 PRIVATE truc *Ltrucf    _((int flg, truc *pptr));
169 PRIVATE truc *recfield  _((truc *rptr, truc field));
170 PRIVATE truc pnew10 _((truc *point, int mode));
171 
172 PRIVATE byte BitSwap[256] = {
173 0x00, 0x80, 0x40, 0xC0, 0x20, 0xA0, 0x60, 0xE0,
174 0x10, 0x90, 0x50, 0xD0, 0x30, 0xB0, 0x70, 0xF0,
175 0x08, 0x88, 0x48, 0xC8, 0x28, 0xA8, 0x68, 0xE8,
176 0x18, 0x98, 0x58, 0xD8, 0x38, 0xB8, 0x78, 0xF8,
177 0x04, 0x84, 0x44, 0xC4, 0x24, 0xA4, 0x64, 0xE4,
178 0x14, 0x94, 0x54, 0xD4, 0x34, 0xB4, 0x74, 0xF4,
179 0x0C, 0x8C, 0x4C, 0xCC, 0x2C, 0xAC, 0x6C, 0xEC,
180 0x1C, 0x9C, 0x5C, 0xDC, 0x3C, 0xBC, 0x7C, 0xFC,
181 0x02, 0x82, 0x42, 0xC2, 0x22, 0xA2, 0x62, 0xE2,
182 0x12, 0x92, 0x52, 0xD2, 0x32, 0xB2, 0x72, 0xF2,
183 0x0A, 0x8A, 0x4A, 0xCA, 0x2A, 0xAA, 0x6A, 0xEA,
184 0x1A, 0x9A, 0x5A, 0xDA, 0x3A, 0xBA, 0x7A, 0xFA,
185 0x06, 0x86, 0x46, 0xC6, 0x26, 0xA6, 0x66, 0xE6,
186 0x16, 0x96, 0x56, 0xD6, 0x36, 0xB6, 0x76, 0xF6,
187 0x0E, 0x8E, 0x4E, 0xCE, 0x2E, 0xAE, 0x6E, 0xEE,
188 0x1E, 0x9E, 0x5E, 0xDE, 0x3E, 0xBE, 0x7E, 0xFE,
189 0x01, 0x81, 0x41, 0xC1, 0x21, 0xA1, 0x61, 0xE1,
190 0x11, 0x91, 0x51, 0xD1, 0x31, 0xB1, 0x71, 0xF1,
191 0x09, 0x89, 0x49, 0xC9, 0x29, 0xA9, 0x69, 0xE9,
192 0x19, 0x99, 0x59, 0xD9, 0x39, 0xB9, 0x79, 0xF9,
193 0x05, 0x85, 0x45, 0xC5, 0x25, 0xA5, 0x65, 0xE5,
194 0x15, 0x95, 0x55, 0xD5, 0x35, 0xB5, 0x75, 0xF5,
195 0x0D, 0x8D, 0x4D, 0xCD, 0x2D, 0xAD, 0x6D, 0xED,
196 0x1D, 0x9D, 0x5D, 0xDD, 0x3D, 0xBD, 0x7D, 0xFD,
197 0x03, 0x83, 0x43, 0xC3, 0x23, 0xA3, 0x63, 0xE3,
198 0x13, 0x93, 0x53, 0xD3, 0x33, 0xB3, 0x73, 0xF3,
199 0x0B, 0x8B, 0x4B, 0xCB, 0x2B, 0xAB, 0x6B, 0xEB,
200 0x1B, 0x9B, 0x5B, 0xDB, 0x3B, 0xBB, 0x7B, 0xFB,
201 0x07, 0x87, 0x47, 0xC7, 0x27, 0xA7, 0x67, 0xE7,
202 0x17, 0x97, 0x57, 0xD7, 0x37, 0xB7, 0x77, 0xF7,
203 0x0F, 0x8F, 0x4F, 0xCF, 0x2F, 0xAF, 0x6F, 0xEF,
204 0x1F, 0x9F, 0x5F, 0xDF, 0x3F, 0xBF, 0x7F, 0xFF
205 };
206 
207 /*--------------------------------------------------------------------*/
iniarray()208 PUBLIC void iniarray()
209 {
210     truc temp;
211 
212     arr_sym   = newintsym("array[ ]", sFBINARY, (wtruc)Farrele);
213     subarrsym = newintsym("array[..]",sFBINARY, (wtruc)Fsubarr);
214 
215     lengthsym = newsymsig("length", sFBINARY, (wtruc)Flength, s_1);
216     chrsym    = newsymsig("chr",    sFBINARY, (wtruc)Fchr, s_1);
217     ordsym    = newsymsig("ord",    sFBINARY, (wtruc)Ford, s_1);
218     sortsym   = newsymsig("sort",   sSBINARY, (wtruc)Ssort, s_12);
219     bsearchsym= newsymsig("binsearch", sFBINARY, (wtruc)Fbsearch, s_23);
220     concatsym = newsymsig("concat", sFBINARY, (wtruc)Fconcat, s_1u);
221     splitsym  = newsymsig("string_split",sFBINARY,(wtruc)Fstrsplit,s_12);
222     sscansym  = newsymsig("string_scan", sFBINARY,(wtruc)Fstrscan, s_23);
223     toupsym   = newsymsig("toupper",sFBINARY, (wtruc)Ftoupper,s_1);
224     tolowsym  = newsymsig("tolower",sFBINARY, (wtruc)Ftolower,s_1);
225     indexsym  = newsymsig("substr_index",sFBINARY,(wtruc)Findex,s_2);
226     arraysym  = newsym("array", sTYPESPEC, nullsym);
227     ofsym     = newsym("of",    sPARSAUX,  nullsym);
228 
229     recordsym = newsym("record",      sTYPESPEC, nullsym);
230     mkrecsym  = newintsym("record",   sFBINARY, (wtruc)Fmkrec0);
231     rec_sym   = newintsym("rec.field",sSBINARY,(wtruc)Srecfield);
232     pointrsym = newsym("pointer",     sTYPESPEC, nil);
233     derefsym  = newintsym("^",    sSBINARY,(wtruc)Sderef);
234 
235     nullstring= mknullstr();
236     stringsym = newsym("string",   sTYPESPEC, nullstring);
237     str_sym   = new0symsig("string",sFBINARY,(wtruc)Ftextstring, s_1);
238     mkstrsym  = newintsym("string[]",sFBINARY, (wtruc)Fmkstring);
239 
240     nullbstring= mknullbstr();
241     bstringsym= newsym("byte_string",   sTYPESPEC, nullbstring);
242     bstr_sym  = new0symsig("byte_string",sFBINARY,(wtruc)Fbstring, s_12);
243     mkbstrsym = newintsym("$",  sFBINARY, (wtruc)Fmkbstring);
244 
245     temp      = newintsym("",   sSBINARY, (wtruc)mkstack);
246     stacksym  = newsym("stack", sTYPESPEC, mk0fun(temp));
247 
248     charsym   = newsym("char",  sTYPESPEC, mkchar(' '));
249 
250     vectorsym = newintsym("vector", sFBINARY, (wtruc)Fvector);
251     pairsym   = newintsym("pair",   sFBINARY, (wtruc)Fpair);
252     mkarrsym  = newintsym("mkarray",sFBINARY,(wtruc)Fmkarray);
253     mknewsym  = newsymsig("new",    sSBINARY,(wtruc)Snew,s_1);
254     allocsym  = newsymsig("alloc",  sFBINARY,(wtruc)Falloc,s_23);
255     reallocsym= newsymsig("realloc",sSBINARY,(wtruc)Srealloc,s_23);
256 
257     pushsym   = newsymsig("stack_push", sFBINARY,(wtruc)Fstkpush,s_2);
258     arrpushsym = newsymsig("stack_arraypush", sFBINARY,(wtruc)Fstkarrpush,s_23);
259     popsym    = newsymsig("stack_pop",  sFBINARY,(wtruc)Fstkpop, s_1);
260     topsym    = newsymsig("stack_top",  sFBINARY,(wtruc)Fstktop, s_1);
261     resetsym  = newsymsig("stack_reset",sFBINARY,(wtruc)Fstkreset, s_1);
262     emptysym  = newsymsig("stack_empty",sFBINARY,(wtruc)Fstkempty, s_1);
263     stk2arrsym= newsymsig("stack2array",sFBINARY,(wtruc)Fstk2array, s_1);
264     stk2strsym= newsymsig("stack2string",sFBINARY,(wtruc)Fstk2string, s_1);
265     maxarrsym = newsymsig("max_arraysize",sFBINARY,(wtruc)Fmaxarray, s_0);
266     mbtestsym = newsymsig("mem_btest",  sSBINARY,(wtruc)Smembtest, s_2);
267     mbsetsym  = newsymsig("mem_bset",   sSBINARY,(wtruc)Smembset, s_2);
268     mbclrsym  = newsymsig("mem_bclear", sSBINARY,(wtruc)Smembclear, s_2);
269     mshiftsym = newsymsig("mem_shift",  sSBINARY,(wtruc)Smemshift, s_2);
270     mandsym   = newsymsig("mem_and",    sSBINARY,(wtruc)Smemand, s_2);
271     morsym    = newsymsig("mem_or",     sSBINARY,(wtruc)Smemor, s_2);
272     mxorsym   = newsymsig("mem_xor",    sSBINARY,(wtruc)Smemxor, s_2);
273     mnotsym   = newsymsig("mem_not",    sSBINARY,(wtruc)Smemnot, s_1);
274     mbitswsym = newsymsig("mem_bitswap",sSBINARY,(wtruc)Smembitsw, s_1);
275     mbyteswsym= newsymsig("mem_byteswap",sSBINARY,(wtruc)Smembytesw,s_2);
276 
277     argvsym   = newsym("ARGV", sSYSTEMVAR, nullsym);
278 }
279 /*--------------------------------------------------------------------*/
iniargv(argc,argv)280 PUBLIC void iniargv(argc,argv)
281 int argc;
282 char *argv[];
283 {
284     truc obj;
285     int i;
286 
287     if(argc > ARGCMAX)
288         argc = ARGCMAX;
289     for(i=0; i<argc; i++) {
290         obj = mkstr(argv[i]);
291         ARGpush(obj);
292     }
293     SYMbind(argvsym) = Fvector(argc);
294     ARGnpop(argc);
295 }
296 /*--------------------------------------------------------------------*/
Flength()297 PRIVATE truc Flength()
298 {
299     long nn;
300     unsigned len;
301 
302     switch(*FLAGPTR(argStkPtr)) {
303     case fVECTOR:
304     case fSTRING:
305     case fBYTESTRING:
306     case fRECORD:
307         len = *VECLENPTR(argStkPtr);
308         return(mkfixnum(len));
309     case fSTACK:
310         nn = stacklength(argStkPtr);
311         return(mkinum(nn));
312     case fSTREAM:
313         nn = filelen(argStkPtr);
314         if(nn < 0)
315             return(brkerr());
316         return(mkinum(nn));
317     default:
318         return(constone);
319     }
320 }
321 /*--------------------------------------------------------------------*/
Fchr()322 PRIVATE truc Fchr()
323 {
324     int flg;
325     int ch;
326 
327     flg = *FLAGPTR(argStkPtr);
328     if(flg != fCHARACTER && flg != fFIXNUM) {
329         error(chrsym,err_chr,*argStkPtr);
330         return(brkerr());
331     }
332     ch = *WORD2PTR(argStkPtr);
333     if(*SIGNPTR(argStkPtr))
334         ch = -ch;
335     return(mkchar(ch));
336 }
337 /*--------------------------------------------------------------------*/
Ford()338 PRIVATE truc Ford()
339 {
340     int flg;
341 
342     flg = *FLAGPTR(argStkPtr);
343     if(flg == fFIXNUM || flg == fBIGNUM)
344         return(*argStkPtr);
345     else if(flg != fCHARACTER) {
346         error(ordsym,err_char,*argStkPtr);
347         return(brkerr());
348     }
349     return(mkfixnum(*WORD2PTR(argStkPtr)));
350 }
351 /*--------------------------------------------------------------------*/
Fvector(argn)352 PRIVATE truc Fvector(argn)
353 int argn;
354 {
355     truc *argptr, *ptr;
356     truc obj;
357 
358     obj = mkvect0(argn);
359     argptr = argStkPtr - argn + 1;
360     ptr = VECTOR(obj);
361     while(--argn >= 0)
362         *ptr++ = *argptr++;
363     return(obj);
364 }
365 /*--------------------------------------------------------------------*/
Fpair()366 PRIVATE truc Fpair()
367 {
368     return(mkntuple(fTUPLE,argStkPtr-1,2));
369 }
370 /*--------------------------------------------------------------------*/
Falloc(argn)371 PRIVATE truc Falloc(argn)
372 int argn;   /* argn = 2 or 3 */
373 {
374     truc *argptr;
375     int flg, flg1;
376     int ch;
377 
378     argptr = argStkPtr - argn + 1;
379     if(*argptr == arraysym)
380         return(Fmkarray(argn-1));
381     else if(*argptr == stringsym) {
382         flg = fSTRING;
383         ch = ' ';
384     }
385     else if(*argptr == bstringsym) {
386         flg = fBYTESTRING;
387         ch = 0;
388     }
389     else {
390         error(allocsym,err_syarr,*argptr);
391         return(brkerr());
392     }
393     if(argn == 3) {
394         flg1 = *FLAGPTR(argStkPtr);
395         if(flg1 == fCHARACTER || flg1 == fFIXNUM) {
396             ch = *WORD2PTR(argStkPtr);
397             if(*SIGNPTR(argStkPtr))
398                 ch = -ch;
399         }
400     }
401     return(mkstring(argptr+1,flg,ch));
402 }
403 /*--------------------------------------------------------------------*/
Fmkarray(argn)404 PRIVATE truc Fmkarray(argn)
405 int argn;   /* argn = 1 or 2 */
406 {
407     truc *argptr, *ptr;
408     truc vector, ele;
409     unsigned i, len;
410     int flg;
411 
412     argptr = argStkPtr - argn + 1;
413     flg = *FLAGPTR(argptr);
414     if(flg != fFIXNUM || *SIGNPTR(argptr)) {
415         error(allocsym,err_pfix,*argptr); /* vorlaeufig */
416         return(brkerr());
417     }
418     len = *WORD2PTR(argptr);
419     vector = mkvect0(len);
420     if(argn == 1) {
421         return(vector);
422     }
423     WORKpush(vector);
424     if(!len)
425         len = 1;
426     if(*FLAGPTR(argStkPtr) >= fBOOL) {
427         ele = *argStkPtr;
428         ptr = VECTORPTR(workStkPtr);
429         while(len--)
430             *ptr++ = ele;
431     }
432     else {
433         for(i=0; i<len; i++) {
434             ele = mkarrcopy(argStkPtr);
435             ptr = VECTORPTR(workStkPtr);
436             ptr[i] = ele;
437         }
438     }
439     return(WORKretr());
440 }
441 /*--------------------------------------------------------------------*/
Fmkstring()442 PRIVATE truc Fmkstring()
443 {
444     return(mkstring(argStkPtr,fSTRING,' '));
445 }
446 /*--------------------------------------------------------------------*/
Fmkbstring()447 PRIVATE truc Fmkbstring()
448 {
449     return(mkstring(argStkPtr,fBYTESTRING,0));
450 }
451 /*--------------------------------------------------------------------*/
mkstring(ptr,flg,ch)452 PRIVATE truc mkstring(ptr,flg,ch)
453 truc *ptr;
454 int flg;    /* fSTRING or fBYTESTRING */
455 int ch;
456 {
457     truc string;
458     truc symb;
459     char *cptr;
460     unsigned len;
461 
462     if(*FLAGPTR(ptr) != fFIXNUM || *SIGNPTR(ptr)) {
463         symb = (flg == fSTRING ? mkstrsym : mkbstrsym);
464         error(symb,err_pfix,*ptr); /* vorlaeufig */
465         return(brkerr());
466     }
467     len = *WORD2PTR(ptr);
468     string = (flg == fSTRING ? mkstr0(len) : mkbstr0(len));
469     cptr = STRINGPTR(&string);
470     while(len) {
471         *cptr++ = ch;
472         len--;
473     }
474     *cptr = 0;
475     return(string);
476 }
477 /*--------------------------------------------------------------------*/
Srealloc()478 PRIVATE truc Srealloc()
479 {
480     truc *argptr, *ptr1, *ptr2;
481     truc res, ele;
482     truc string, vector;
483     char *cpt1, *cpt2;
484     unsigned len, len1;
485     int argn, k;
486     int flg, flg1;
487     int ch;
488 
489     argn = *ARGCOUNTPTR(evalStkPtr);
490     argptr = ARG1PTR(evalStkPtr);
491     flg = is_lval(argptr);
492     switch(flg) {
493     case aERROR:
494         error(reallocsym,err_lval,eval(argptr));
495         return brkerr();
496     case vSUBARRAY:
497         error(reallocsym,"subarray cannot be realloc'd",eval(argptr));
498         return brkerr();
499     case vCONST:
500         error(reallocsym,"constants cannot be realloc'd",*argptr);
501         return brkerr();
502     default:
503         break;
504     }
505     res = eval(argptr);
506     ARGpush(res);
507     res = eval(ARGNPTR(evalStkPtr,2));
508     ARGpush(res);
509     if(*FLAGPTR(argStkPtr) != fFIXNUM || *SIGNPTR(argStkPtr)) {
510         error(reallocsym,err_pfix,*argStkPtr);
511         ARGnpop(2);
512         return(brkerr());
513     }
514     len1 = *WORD2PTR(argStkPtr);
515     ARGpop();
516     flg = *FLAGPTR(argStkPtr);
517     if(flg == fVECTOR || flg == fSTRING || flg == fBYTESTRING) {
518         len = *VECLENPTR(argStkPtr);
519     }
520     else {
521         error(reallocsym,err_arr,*argStkPtr);
522         ARGpop();
523         return(brkerr());
524     }
525     if(len1 <= len) {
526         *VECLENPTR(argStkPtr) = len1;
527         res = ARGretr();
528         return Lvalassign(ARG1PTR(evalStkPtr),res);
529     }
530     /* now len1 > len, i.e. proper realloc */
531     if(argn == 3) {
532         res = eval(ARGNPTR(evalStkPtr,3));
533         ARGpush(res);
534     }
535     else if(flg == fVECTOR)
536         ARGpush(zero);
537     if(flg != fVECTOR) {    /* flg == fSTRING || flg == fBYTESTRING */
538         if(argn == 3) {
539             flg1 = *FLAGPTR(argStkPtr);
540             if(flg1 == fCHARACTER || flg1 == fFIXNUM) {
541                 ch = *WORD2PTR(argStkPtr);
542                 if(*SIGNPTR(argStkPtr))
543                     ch = -ch;
544             }
545             else {
546                 ch = 0;
547             }
548             ARGpop();
549         }
550         else {
551             ch = 0;
552         }
553         string = (flg == fSTRING ? mkstr0(len1) : mkbstr0(len1));
554         cpt1 = STRINGPTR(&string);
555         cpt2 = STRINGPTR(argStkPtr);
556         for(k=0; k<len; k++)
557             *cpt1++ = *cpt2++;
558         for(k=len; k<len1; k++)
559             *cpt1++ = ch;
560         *cpt1 = 0;
561         ARGpop();
562         res = Lvalassign(ARG1PTR(evalStkPtr),string);
563         return res;
564     }
565     /* else flg == fVECTOR */
566     vector = mkvect0(len1);
567     WORKpush(vector);
568     ptr1 = VECTORPTR(workStkPtr);
569     ptr2 = VECTORPTR(argStkPtr-1);
570     for(k=0; k<len; k++)
571         *ptr1++ = *ptr2++;
572     if(*FLAGPTR(argStkPtr) >= fBOOL) {
573         ele = *argStkPtr;
574         for(k=len; k<len1; k++)
575             *ptr1++ = ele;
576     }
577     else {
578         for(k=len; k<len1; k++) {
579             ele = mkarrcopy(argStkPtr);
580             ptr1 = VECTORPTR(workStkPtr);
581             ptr1[k] = ele;
582         }
583     }
584     ARGnpop(2);
585     res = Lvalassign(ARG1PTR(evalStkPtr),*workStkPtr);
586     WORKpop();
587     return res;
588 }
589 /*--------------------------------------------------------------------*/
Fconcat(argn)590 PRIVATE truc Fconcat(argn)
591 int argn;
592 {
593     truc *argptr, *ptr;
594     truc strobj;
595     char *str, *str1;
596     long len;
597     unsigned n;
598     int i, flg;
599 
600     argptr = argStkPtr - argn + 1;
601     len = 0;
602     for(i=0; i<argn; i++) {
603         ptr = argptr + i;
604         flg = *FLAGPTR(ptr);
605         if(flg == fSTRING)
606             len += *STRLENPTR(ptr);
607         else if(flg == fCHARACTER || flg == fFIXNUM)
608             len++;
609         else {
610             error(concatsym,err_str,*ptr);
611             return(brkerr());
612         }
613     }
614     if(len > 0xFFFF) {
615         error(concatsym,err_2long,voidsym);
616         return(brkerr());
617     }
618     else {
619         n = len;
620     }
621     strobj = mkstr0(n);
622     str = STRING(strobj);
623     for(i=0; i<argn; i++,argptr++) {
624         if(*FLAGPTR(argptr) == fSTRING) {
625             str1 = STRINGPTR(argptr);
626             n = *STRLENPTR(argptr);
627             while(n--)
628                 *str++ = *str1++;
629         }
630         else
631             *str++ = *WORD2PTR(argptr);
632     }
633     *str = 0;
634     return(strobj);
635 }
636 /*--------------------------------------------------------------------*/
Findex()637 PRIVATE truc Findex()
638 {
639     byte *str, *str1;
640     long res;
641     size_t len, len1;
642     int i, flg;
643 
644     for(i=-1; i<=0; i++) {
645         flg = *FLAGPTR(argStkPtr+i);
646         if(flg != fSTRING && flg != fBYTESTRING) {
647             error(indexsym,err_str,argStkPtr[i]);
648             res = -1;
649             goto ausgang;
650         }
651     }
652     len = *STRLENPTR(argStkPtr-1);
653     len1 = *STRLENPTR(argStkPtr);
654     str = BYTEPTR(argStkPtr-1);
655     str1 = BYTEPTR(argStkPtr);
656     res = substrindex(str,len,str1,len1);
657   ausgang:
658     return(mksfixnum((int)res));
659 }
660 /*--------------------------------------------------------------------*/
substrindex(str,len,sub,len1)661 PRIVATE long substrindex(str,len,sub,len1)
662 byte *str, *sub;
663 size_t len, len1;
664 {
665     byte *ptr, *ptr1;
666     size_t i,k,diff;
667     long res;
668     int ch;
669 
670     if(len1 == 0 || len1 > len)
671         return(-1);
672     diff = len - len1;
673     ch = *sub++;
674     for(i=0; i<=diff; i++) {
675         if(*str++ != ch)
676             continue;
677         ptr = str; ptr1 = sub;
678         res = i;
679         for(k=1; k<len1; k++) {
680             if(*ptr++ != *ptr1++) {
681                 res = -1;
682                 break;
683             }
684         }
685         if(res >= 0)
686             return(res);
687     }
688     return(-1);
689 }
690 /*--------------------------------------------------------------------*/
Fstrsplit(argn)691 PRIVATE truc Fstrsplit(argn)
692 int argn;
693 {
694     truc *vptr, *basptr;
695     truc *argptr;
696     truc obj;
697     word2 *offsets;
698     char *trenn;
699     char *str, *str0;
700     unsigned len;
701     int k, count, flg;
702 
703     if(argn == 2) {
704         flg = *FLAGPTR(argStkPtr);
705         if(flg != fSTRING) {
706             error(splitsym,err_str,*argStkPtr);
707             return(brkerr());
708         }
709         trenn = STRINGPTR(argStkPtr);
710     }
711     else {
712         trenn = NULL;
713     }
714     argptr = argStkPtr - argn + 1;
715     flg = *FLAGPTR(argptr);
716     if(flg != fSTRING) {
717         error(splitsym,err_str,*argptr);
718         return(brkerr());
719     }
720     str = STRINGPTR(argptr);
721     len = *STRLENPTR(argptr);
722     if(len > sizeof(word2) * (aribufSize/2-1)) {
723         error(splitsym,err_2long,mkfixnum(len));
724         return(brkerr());
725     }
726     str0 = (char *)AriBuf;
727     strncopy(str0,str,len);
728     offsets = AriBuf + aribufSize/2;
729     count = stringsplit(str0,trenn,offsets);
730 
731     basptr = workStkPtr + 1;
732     for(k=0; k<count; k++) {
733         obj = mkstr(str0 + offsets[k]);
734         WORKpush(obj);
735     }
736     *argptr = mkvect0(count);
737     vptr = VECTORPTR(argptr);
738     if(!count)
739         vptr[0] = nullstring;
740     else for(k=0; k<count; k++)
741         vptr[k] = basptr[k];
742     workStkPtr = basptr - 1;
743     return(*argptr);
744 }
745 /*--------------------------------------------------------------------*/
746 /*
747 ** Zerlegt den String str destruktiv (durch Einfuegen von
748 ** Nullbytes) in Teilstrings; dabei werden alle Characters aus trenn
749 ** als Trenn-Elemente aufgefasst. Fuer trenn == NULL werden SPACE,
750 ** TAB und '\n' als Trenner verwendet.
751 ** In offsets werden die Offsets der Teilstrings von str abgelegt;
752 ** Rueckgabewert ist die Anzahl der Teilstrings.
753 */
stringsplit(str,trenn,offsets)754 PUBLIC int stringsplit(str,trenn,offsets)
755 char *str, *trenn;
756 word2 *offsets;
757 {
758     static char trenn0[5] = {' ','\t','\n','\r',0};
759     word4 sep4[64];     /* space for 256 bytes */
760     word4 *pt4;
761     byte *sep;
762     int k, count, ch;
763 
764     k = 64; pt4 = sep4;
765     while(--k >= 0)
766         *pt4++ = 0;
767     sep = (byte *)sep4;
768     if(trenn == NULL)
769         trenn = trenn0;
770     while((ch = *(byte *)trenn++))
771         sep[ch] = 1;
772     k = count = 0;
773     while(1) {
774         while((ch = *(byte *)str++) && sep[ch])
775             k++;
776         if(!ch) break;
777         offsets[count++] = k++;
778         while((ch = *(byte *)str++) && !sep[ch])
779             k++;
780         if(!ch) break;
781         str[-1] = 0;
782         k++;
783     }
784     return(count);
785 }
786 /*--------------------------------------------------------------------*/
787 /*
788 ** string_scan(s,bag: string): integer;
789 **   returns the position in s of the first character that belongs to bag;
790 **   if there is no such character, -1 is returned
791 ** string_scan(s,bag: string; false): integer;
792 **   returns the position in s of the first character that does not
793 **   belong to bag; if all characters of s also belog to bag,
794 **   -1 is returned
795 */
Fstrscan(argn)796 PRIVATE truc Fstrscan(argn)
797 int argn;
798 {
799     truc *argptr;
800     byte *str, *bag, *sep;
801     int flg, tst, ch;
802     int k, len, len2, pos;
803     word4 sep4[64];     /* space for 256 bytes */
804     word4 *pt4;
805     word4 fill;
806 
807     if(argn == 3 && (*argStkPtr == zero || *argStkPtr == false)) {
808         fill = 0xFFFFFFFF; tst = 0;
809     }
810     else {
811         fill = 0; tst = 0xFF;
812     }
813     argptr = argStkPtr - argn + 1;
814     for(k=0; k<2; k++) {
815         flg = *FLAGPTR(argptr+k);
816         if(flg != fSTRING && flg != fBYTESTRING) {
817             error(sscansym,err_str,argptr[k]);
818             return(brkerr());
819         }
820     }
821     str = BYTEPTR(argptr);
822     len = *STRLENPTR(argptr);
823     bag = BYTEPTR(argptr+1);
824     len2 = *STRLENPTR(argptr+1);
825 
826     k = 64; pt4 = sep4;
827     while(--k >= 0)
828         *pt4++ = fill;
829 
830     sep = (byte *)sep4;
831     for(k=0; k<len2; k++) {
832         ch = bag[k];
833         sep[ch] = tst;
834     }
835     pos = -1;
836     for(k=0; k<len; k++) {
837         ch = *str++;
838         if(sep[ch]) {
839             pos = k;
840             break;
841         }
842     }
843     return(mksfixnum(pos));
844 }
845 /*--------------------------------------------------------------------*/
Ftolower()846 PRIVATE truc Ftolower()
847 {
848     return(Gchangecase(tolowsym));
849 }
850 /*--------------------------------------------------------------------*/
Ftoupper()851 PRIVATE truc Ftoupper()
852 {
853     return(Gchangecase(toupsym));
854 }
855 /*--------------------------------------------------------------------*/
Gchangecase(symb)856 PRIVATE truc Gchangecase(symb)
857 truc symb;
858 {
859     ifun chfun;
860     char *str;
861     unsigned k, len;
862     int flg, ch;
863 
864     flg = *FLAGPTR(argStkPtr);
865 
866     chfun = (symb == toupsym ? toupcase : tolowcase);
867     if(flg == fCHARACTER || flg == fFIXNUM) {
868         ch = *WORD2PTR(argStkPtr);
869         return(mkchar(chfun(ch)));
870     }
871     else if(flg == fSTRING) {
872         *argStkPtr = mkcopy(argStkPtr);
873         str = STRINGPTR(argStkPtr);
874         len = *STRLENPTR(argStkPtr);
875         for(k=0; k<len; k++)
876             *str++ = chfun(*str);
877         return(*argStkPtr);
878     }
879     else {
880         error(symb,err_str,*argStkPtr);
881         return(brkerr());
882     }
883 }
884 /*--------------------------------------------------------------------*/
Farrele()885 PRIVATE truc Farrele()
886 {
887     truc *ptr;
888     truc obj;
889     byte *cptr;
890     long index;
891     int flg;
892 
893     flg = arrindex(argStkPtr-1,&index);
894     switch(flg) {
895     case fVECTOR:
896         ptr = vectele(argStkPtr-1,index);
897         if(ptr)
898             return(*ptr);
899         else
900             return(brkerr());
901     case fSTRING:
902     case fBYTESTRING:
903         cptr = (byte *)stringele(argStkPtr-1,index);
904         if(cptr) {
905             if(flg == fSTRING)
906                 obj = mkchar(*cptr);
907             else
908                 obj = mkfixnum(*cptr);
909             return(obj);
910         }
911         else
912             return(brkerr());
913     default:
914         return(brkerr());
915     }
916 }
917 /*--------------------------------------------------------------------*/
918 /*
919 ** Auswertung von arr[start .. end]
920 ** In argStkPtr[-1] steht das Array, in argStkPtr[0] ein
921 ** 2-tupel mit start und end.
922 */
Fsubarr()923 PRIVATE truc Fsubarr()
924 {
925     truc *ptr, *ptr1;
926     truc obj;
927     char *cptr, *cptr1;
928     long len, len0, n0, n1;
929     int flg;
930 
931     flg = *FLAGPTR(argStkPtr-1);
932     if(flg < fVECTLIKE0 && flg > fVECTLIKE1) {
933         error(subarrsym,err_arr,argStkPtr[-1]);
934         return(brkerr());
935     }
936     len = *VECLENPTR(argStkPtr-1);
937 
938     if(indrange(argStkPtr,len,&n0,&n1) == aERROR) {
939         return(brkerr());
940     }
941     len0 = n1 - n0 + 1;
942     if(flg == fVECTOR) {
943         obj = mkvect0((unsigned)len0);
944         ptr1 = VECTORPTR(argStkPtr-1) + n0;
945         ptr = VECTOR(obj);
946         while(--len0 >= 0)
947             *ptr++ = *ptr1++;
948         return(obj);
949     }
950     if(flg == fSTRING)
951         obj = mkstr0((unsigned)len0);
952     else if(flg == fBYTESTRING)
953         obj = mkbstr0((unsigned)len0);
954     else            /* this case should not happen */
955         return(brkerr());
956 
957     /* case fSTRING or fBYTESTRING */
958     cptr1 = STRINGPTR(argStkPtr-1) + n0;
959     cptr = STRING(obj);
960     while(--len0 >= 0)
961         *cptr++ = *cptr1++;
962     *cptr = 0;
963     return(obj);
964 }
965 /*--------------------------------------------------------------------*/
indrange(ptr,len,pn0,pn1)966 PUBLIC int indrange(ptr,len,pn0,pn1)
967 truc *ptr;
968 long len;
969 long *pn0, *pn1;
970 {
971     long n0, n1;
972     int ret = 0;
973 
974     ptr = VECTORPTR(ptr);
975     if(*FLAGPTR(ptr) == fFIXNUM) {
976         n0 = *WORD2PTR(ptr);
977         if(*SIGNPTR(ptr))
978             n0 = 0;
979     }
980     else
981         ret = aERROR;
982     ptr++;
983     if(*FLAGPTR(ptr) == fFIXNUM) {
984         n1 = *WORD2PTR(ptr);
985         if(*SIGNPTR(ptr))
986             n1 = -1;
987     }
988     else if(*ptr == endsym) {
989         n1 = len-1;
990     }
991     else
992         ret = aERROR;
993     if(ret == aERROR) {
994         error(subarrsym,err_sarr,voidsym);
995         return(ret);
996     }
997     if(n1 > len-1)
998         n1 = len-1;
999     if(n0 > n1)
1000         n0 = n1+1;
1001     *pn0 = n0;
1002     *pn1 = n1;
1003     return(ret);
1004 }
1005 /*--------------------------------------------------------------------*/
arrindex(ptr,pindex)1006 PRIVATE int arrindex(ptr,pindex)
1007 truc *ptr;
1008 long *pindex;
1009 {
1010     long index;
1011     int flg, flg1;
1012     word2 *z;
1013     int sign, n;
1014 
1015     flg = *FLAGPTR(ptr);
1016     if(flg < fVECTLIKE0 && flg > fVECTLIKE1) {
1017         error(arr_sym,err_arr,*ptr);
1018         return(aERROR);
1019     }
1020     ptr++;
1021     flg1 = *FLAGPTR(ptr);
1022     if(flg1 == fFIXNUM) {
1023         index = *WORD2PTR(ptr);
1024         if(*SIGNPTR(ptr))
1025             index = -index;
1026         *pindex = index;
1027     }
1028     else if(flg1 == fBIGNUM) {
1029         n = bigref(ptr,&z,&sign);
1030         if (n <= 2) {
1031             index = big2long(z,n);
1032             if(sign) index = -index;
1033             *pindex = index;
1034         }
1035         else {
1036             error(arr_sym,err_p4int,*ptr);
1037             return(aERROR);
1038         }
1039     }
1040     else {
1041     /* vorlaeufig */
1042         error(arr_sym,err_pfix,*ptr);
1043         return(aERROR);
1044     }
1045     return(flg);
1046 }
1047 /*--------------------------------------------------------------------*/
stringele(ptr,index)1048 PRIVATE char *stringele(ptr,index)
1049 truc *ptr;
1050 long index;
1051 {
1052     struct strcell *str;
1053     char *cptr;
1054     unsigned len;
1055 
1056     str = (struct strcell *)TAddress(ptr);
1057     len = str->len;
1058     if(index < 0 || index >= len) {
1059         error(arr_sym,err_irange,mkinum(index));
1060         return(NULL);
1061     }
1062     cptr = &(str->ch0);
1063     return(cptr + index);
1064 }
1065 /*--------------------------------------------------------------------*/
vectele(ptr,index)1066 PRIVATE truc *vectele(ptr,index)
1067 truc *ptr;
1068 long index;
1069 {
1070     struct vector *vec;
1071     truc *ptr1;
1072     unsigned len;
1073 
1074     vec = (struct vector *)TAddress(ptr);
1075     len = vec->len;
1076     if(index < 0 || index >= len) {
1077         error(arr_sym,err_irange,mkinum(index));
1078         return(NULL);
1079     }
1080     ptr1 = &(vec->ele0);
1081     return(ptr1 + index);
1082 }
1083 /*--------------------------------------------------------------------*/
1084 /*
1085 ** arr[0] enthaelt Array, arr[1] den Index
1086 ** In die entsprechende Komponente des Arrays wird obj eingetragen
1087 */
arrassign(arr,obj)1088 PUBLIC truc arrassign(arr,obj)
1089 truc *arr;
1090 truc obj;
1091 {
1092     truc *ptr;
1093     char *cptr;
1094     variant v;
1095     long index;
1096     int flg;
1097     int ch;
1098 
1099     flg = arrindex(arr,&index);
1100     switch(flg) {
1101     case fVECTOR:
1102         ptr = vectele(arr,index);
1103         if(ptr)
1104             *ptr = obj;
1105         else
1106             return(brkerr());
1107         break;
1108     case fSTRING:
1109     case fBYTESTRING:
1110         cptr = stringele(arr,index);
1111         if(cptr) {
1112             v.xx = obj;
1113             flg = v.pp.b0;
1114             if(flg == fCHARACTER)
1115                 ch = v.pp.ww;
1116             else if(flg == fFIXNUM) {
1117                 ch = v.pp.ww;
1118                 if(v.pp.b1) /* signum */
1119                     ch = -ch;
1120                 arr[2] = mkchar(ch);
1121             }
1122             else {
1123                 error(arr_sym,err_char,obj);
1124                 return(brkerr());
1125             }
1126             *cptr = ch;
1127         }
1128         else
1129             return(brkerr());
1130         break;
1131     default:
1132         return(brkerr());
1133     }
1134     return(obj);
1135 }
1136 /*--------------------------------------------------------------------*/
arrcompat(flg1,flg2)1137 PRIVATE int arrcompat(flg1,flg2)
1138 int flg1, flg2;
1139 {
1140     if(flg1 < fVECTLIKE0 && flg1 > fVECTLIKE1)
1141         return(-1);
1142     else if(flg1 == flg2)
1143         return(0);
1144     else if(flg2 < fVECTLIKE0 && flg2 > fVECTLIKE1)
1145         return(-2);
1146     else if((flg1 == fVECTOR && flg2 != fVECTOR) ||
1147         (flg2 == fVECTOR && flg1 != fVECTOR))
1148         return(-3);
1149     else
1150         return(0);
1151 }
1152 /*--------------------------------------------------------------------*/
1153 /*
1154 ** arr[0] enthaelt Array, arr[1] ein Indexpaar (als fTUPLE der Laenge 2)
1155 */
subarrassign(arr,obj)1156 PUBLIC truc subarrassign(arr,obj)
1157 truc *arr;
1158 truc obj;
1159 {
1160     truc *ptr, *ptr1;
1161     char *cptr, *cptr1;
1162     long len, len0, len1, n0, n1;
1163     int flg, err;
1164 
1165     flg = *FLAGPTR(arr);
1166     err = arrcompat(flg,Tflag(obj));
1167     if(err < 0) {
1168         if(err >= -2) {
1169             if(err == -1)
1170                 obj = arr[0];
1171             error(subarrsym,err_arr,obj);
1172         }
1173         return(brkerr());
1174     }
1175     len = *VECLENPTR(arr);
1176 
1177     if(indrange(arr+1,len,&n0,&n1) == aERROR) {
1178         return(brkerr());
1179     }
1180     len0 = n1 - n0 + 1;
1181     len1 = VEClen(obj);
1182     if(len0 > len1)
1183         len0 = len1;
1184     switch(flg) {
1185     case fVECTOR:
1186         ptr1 = VECTORPTR(arr) + n0;
1187         ptr = VECTOR(obj);
1188         while(--len0 >= 0)
1189             *ptr1++ = *ptr++;
1190         break;
1191     case fSTRING:
1192     case fBYTESTRING:
1193         cptr1 = STRINGPTR(arr) + n0;
1194         cptr = STRING(obj);
1195         while(--len0 >= 0)
1196             *cptr1++ = *cptr++;
1197         break;
1198     default:
1199         return(brkerr());
1200     }
1201     return(obj);
1202 }
1203 /*--------------------------------------------------------------------*/
stacklength(ptr)1204 PRIVATE long stacklength(ptr)
1205 truc *ptr;
1206 {
1207     struct stack *sptr;
1208     long len;
1209 
1210     sptr = (struct stack *)TAddress(ptr);
1211     len = sptr->pageno;
1212     len <<= PAGELENBITS;       /* times PAGELEN */
1213     len += sptr->line;
1214     return(len);
1215 }
1216 /*--------------------------------------------------------------------*/
Fstkpush()1217 PRIVATE truc Fstkpush()
1218 {
1219     struct stack *sptr;
1220     struct stackpage *spage;
1221     truc currpage, sheet;
1222     truc obj;
1223     int line;
1224 
1225     if(*FLAGPTR(argStkPtr-1) != fSTACK) {
1226         error(pushsym,err_stkv,voidsym);
1227         return(brkerr());
1228     }
1229     if(*argStkPtr == breaksym)
1230         return(brkerr());
1231     obj = mkcopy(argStkPtr); /* 20070724 */
1232     WORKpush(obj);
1233     sptr = (struct stack *)TAddress(argStkPtr-1);
1234     line = sptr->line;
1235     if(line == 0) {     /* create new page */
1236         sheet = mkvect0(PAGELEN+1);
1237         sptr = (struct stack *)TAddress(argStkPtr-1);
1238         currpage = sptr->page;
1239         sptr->page = sheet;
1240         spage = (struct stackpage *)Taddress(sheet);
1241         spage->prevpage = currpage;
1242     }
1243     else
1244         spage = (struct stackpage *)Taddress(sptr->page);
1245     spage->data[line] = WORKretr(); /* 20070724 */
1246     line++;
1247     if(line >= PAGELEN) {
1248         line = 0;
1249         sptr->pageno++;
1250     }
1251     sptr->line = line;
1252     return *argStkPtr;
1253 }
1254 /*--------------------------------------------------------------------*/
1255 /*
1256 ** stack_arraypush(st: stack; vec: array [; direction: integer]): integer;
1257 */
Fstkarrpush(argn)1258 PRIVATE truc Fstkarrpush(argn)
1259 int argn;
1260 {
1261     struct stack *sptr;
1262     struct stackpage *spage;
1263     struct vector *vecstruct;
1264     truc *argptr, *vec;
1265     truc currpage, sheet;
1266     int line, incr;
1267     unsigned len, pos, k;
1268 
1269     argptr = argStkPtr-argn+1;
1270     if(*FLAGPTR(argptr) != fSTACK) {
1271         error(arrpushsym,err_stkv,voidsym);
1272         return(brkerr());
1273     }
1274     if(*FLAGPTR(argptr+1) != fVECTOR) {
1275         error(arrpushsym,err_vect,argptr[1]);
1276         return(brkerr());
1277     }
1278     if(argn == 3) {
1279         if(*FLAGPTR(argStkPtr) != fFIXNUM) {
1280             error(arrpushsym,"integer +1 or -1 expected",*argStkPtr);
1281             return(brkerr());
1282         }
1283         incr = (*SIGNPTR(argStkPtr) ? -1 : 1);
1284     }
1285     else
1286         incr = 1;
1287     vecstruct = VECSTRUCTPTR(argptr+1);
1288     vec = &(vecstruct->ele0);
1289     len = vecstruct->len;
1290     if(len == 0)
1291         return zero;
1292 
1293     pos = (incr > 0 ? 0 : len-1);
1294 
1295     sptr = (struct stack *)TAddress(argptr);
1296     spage = (struct stackpage *)Taddress(sptr->page);
1297     line = sptr->line;
1298     for(k=0; k<len; k++, pos += incr) {
1299         if(line == 0) {     /* create new page */
1300             sheet = mkvect0(PAGELEN+1);
1301             sptr = (struct stack *)TAddress(argptr);
1302             currpage = sptr->page;
1303             sptr->page = sheet;
1304             spage = (struct stackpage *)Taddress(sheet);
1305             spage->prevpage = currpage;
1306             vec = VECTORPTR(argptr+1); /* may have changed during gc */
1307         }
1308         spage->data[line] = vec[pos];
1309         line++;
1310         if(line >= PAGELEN) {
1311             line = 0;
1312             sptr->pageno++;
1313         }
1314     }
1315     sptr->line = line;
1316 
1317     return(mkfixnum(len));
1318 }
1319 /*--------------------------------------------------------------------*/
Fstkpop()1320 PRIVATE truc Fstkpop()
1321 {
1322     return(Gstkretr(popsym));
1323 }
1324 /*--------------------------------------------------------------------*/
Fstktop()1325 PRIVATE truc Fstktop()
1326 {
1327     return(Gstkretr(topsym));
1328 }
1329 /*--------------------------------------------------------------------*/
Gstkretr(symb)1330 PRIVATE truc Gstkretr(symb)
1331 truc symb;
1332 {
1333     struct stack *sptr;
1334     struct stackpage *spage;
1335     truc currpage, obj;
1336     int line;
1337 
1338     if(*FLAGPTR(argStkPtr) != fSTACK) {
1339         error(symb,err_stkv,voidsym);
1340         return(brkerr());
1341     }
1342     sptr = (struct stack *)TAddress(argStkPtr);
1343     line = sptr->line;
1344     currpage = sptr->page;
1345     if(currpage == nullsym) {
1346         error(symb,err_stke,voidsym);
1347         return(brkerr());
1348     }
1349     spage = (struct stackpage *)Taddress(currpage);
1350     line = (line > 0 ? line-1 : PAGELEN-1);
1351     obj = spage->data[line];
1352     if(symb == popsym) {
1353         sptr->line = line;
1354         if(line == 0)       /* delete current page */
1355             sptr->page = spage->prevpage;
1356         else if(line == PAGELEN-1)
1357             sptr->pageno--;
1358     }
1359     return(obj);
1360 }
1361 /*--------------------------------------------------------------------*/
Fstk2array()1362 PRIVATE truc Fstk2array()
1363 {
1364     struct stack *sptr;
1365     struct stackpage *spage;
1366     truc currpage;
1367     truc *vec;
1368     truc arr;
1369     long llen;
1370     unsigned len;
1371     int lineno, pageno;
1372 
1373     if(*FLAGPTR(argStkPtr) != fSTACK) {
1374         error(stk2arrsym,err_stkv,voidsym);
1375         return(brkerr());
1376     }
1377     sptr = (struct stack *)TAddress(argStkPtr);
1378     pageno = sptr->pageno;
1379     lineno = sptr->line;
1380     llen = pageno;
1381     llen <<= PAGELENBITS;      /* times PAGELEN */
1382     llen += lineno;
1383     if(llen > (long)getblocksize()) {
1384         error(stk2arrsym,err_stkbig,voidsym);
1385         return(brkerr());
1386     }
1387     len = llen;
1388     arr = mkvect0(len);
1389     vec = VECTORPTR(&arr);
1390     if(len == 0)
1391         goto ausgang;
1392 
1393     sptr = (struct stack *)TAddress(argStkPtr);
1394     /* may have changed after garbage collection */
1395     currpage = sptr->page;
1396     spage = (struct stackpage *)Taddress(currpage);
1397     lineno = (lineno > 0 ? lineno-1 : PAGELEN-1);
1398     while(len > 0) {
1399         len--;
1400         vec[len] = spage->data[lineno];
1401         lineno--;
1402         if(lineno < 0) {
1403             lineno += PAGELEN;
1404             if(--pageno < 0)
1405                 break;
1406             currpage = spage->prevpage;
1407             spage = (struct stackpage *)Taddress(currpage);
1408         }
1409     }
1410     sptr->line = 0;
1411     sptr->pageno = 0;
1412     sptr->page = nullsym;
1413   ausgang:
1414     return(arr);
1415 }
1416 /*--------------------------------------------------------------------*/
Fstk2string()1417 PRIVATE truc Fstk2string()
1418 {
1419     struct stack *sptr;
1420     struct stackpage *spage;
1421     truc currpage;
1422     truc *ptr;
1423     char *str, *str1, *str2;
1424     long llen;
1425     unsigned len, mlen, slen, pos, k;
1426     int lineno, pageno;
1427     int flg;
1428 
1429     if(*FLAGPTR(argStkPtr) != fSTACK) {
1430         error(stk2arrsym,err_stkv,voidsym);
1431         return(brkerr());
1432     }
1433     sptr = (struct stack *)TAddress(argStkPtr);
1434     pageno = sptr->pageno;
1435     lineno = sptr->line;
1436     llen = pageno;
1437     llen <<= PAGELENBITS;      /* times PAGELEN */
1438     llen += lineno;
1439     mlen = (getblocksize()-1) & 0xFFFC;
1440     if(llen > (long)mlen)
1441         goto errexit;
1442     len = llen;
1443     pos = aribufSize*sizeof(word2) & 0xFFFC;
1444     if(pos/4 > mlen)
1445         pos = 4*mlen;
1446     str = (char*)AriBuf;
1447     str[pos] = '\0';
1448     currpage = sptr->page;
1449     spage = (struct stackpage *)Taddress(currpage);
1450     lineno = (lineno > 0 ? lineno-1 : PAGELEN-1);
1451     while(len > 0) {
1452         len--;
1453         ptr = spage->data + lineno;
1454         flg = *FLAGPTR(ptr);
1455         if(flg == fCHARACTER) {
1456             if(pos > 0) {
1457                 pos--;
1458                 str[pos] = *WORD2PTR(ptr);
1459             }
1460             else
1461                 goto errexit;
1462         }
1463         else if(flg == fSTRING) {
1464             str2 = STRINGPTR(ptr);
1465             slen = *STRLENPTR(ptr);
1466             if(pos >= slen) {
1467                 pos -= slen;
1468                 for(str1=str+pos, k=0; k<slen; k++)
1469                     *str1++ = *str2++;
1470             }
1471             else
1472                 goto errexit;
1473         }
1474         lineno--;
1475         if(lineno < 0) {
1476             lineno += PAGELEN;
1477             if(--pageno < 0)
1478                 break;
1479             currpage = spage->prevpage;
1480             spage = (struct stackpage *)Taddress(currpage);
1481         }
1482     }
1483     sptr->line = 0;
1484     sptr->pageno = 0;
1485     sptr->page = nullsym;
1486     return(mkstr(str+pos));
1487   errexit:
1488     error(stk2strsym,err_stkbig,voidsym);
1489     return(brkerr());
1490 }
1491 /*--------------------------------------------------------------------*/
Fstkreset()1492 PRIVATE truc Fstkreset()
1493 {
1494     struct stack *sptr;
1495 
1496     if(*FLAGPTR(argStkPtr) != fSTACK) {
1497         error(resetsym,err_stkv,voidsym);
1498         return(brkerr());
1499     }
1500     sptr = (struct stack *)TAddress(argStkPtr);
1501     sptr->line = 0;
1502     sptr->pageno = 0;
1503     sptr->page = nullsym;
1504 
1505     return(zero);
1506 }
1507 /*--------------------------------------------------------------------*/
Fstkempty()1508 PRIVATE truc Fstkempty()
1509 {
1510     struct stack *sptr;
1511 
1512     if(*FLAGPTR(argStkPtr) != fSTACK) {
1513         error(emptysym,err_stkv,voidsym);
1514         return(brkerr());
1515     }
1516     sptr = (struct stack *)TAddress(argStkPtr);
1517     return(sptr->page == nullsym ? true : false);
1518 }
1519 /*--------------------------------------------------------------------*/
Fmaxarray()1520 PRIVATE truc Fmaxarray()
1521 {
1522     unsigned len = getblocksize();
1523 
1524     return(mkfixnum((len-1) & 0xFFFC));
1525 }
1526 /*--------------------------------------------------------------------*/
1527 #ifdef QUICKSORT
1528 typedef int (*ifunvv)(const void *, const void *);
sortarr(arr,len,cmpfn)1529 PUBLIC void sortarr(arr,len,cmpfn)
1530 truc *arr;
1531 unsigned len;
1532 ifuntt cmpfn;
1533 {
1534     qsort(arr,(size_t)len,sizeof(truc),(ifunvv)cmpfn);
1535 }
1536 #else
1537 /*---------------------------------------------------------*/
1538 /*
1539 ** destructively shellsorts array arr[0],...,arr[len-1]
1540 ** with ordering given by
1541 **      int cmpfn(truc *ptr1, truc *ptr2);
1542 ** arr should be safe w.r.t garbage collection in case cmpfn
1543 ** allocates new memory
1544 */
sortarr(arr,len,cmpfn)1545 PUBLIC void sortarr(arr,len,cmpfn)
1546 truc *arr;
1547 unsigned len;
1548 ifuntt cmpfn;
1549 {
1550 #define DDLEN   14
1551     static unsigned dd[DDLEN] =
1552     {1,3,7,17,37,83,191,421,929,2053,4517,9941,21871,0xFFFF};
1553 
1554     unsigned i, k, d;
1555     int n = 0;
1556 
1557     ARGpush(zero);
1558     while(n < DDLEN && dd[n] < len)
1559         n++;
1560     while(--n >= 0) {
1561         d = dd[n];
1562         i = len - d;
1563         while(i) {
1564             *argStkPtr = arr[--i];
1565             k = i + d;
1566             while(k<len && cmpfn(argStkPtr,arr+k) > 0) {
1567                 arr[k-d] = arr[k];
1568                 k += d;
1569             }
1570             arr[k-d] = *argStkPtr;
1571         }
1572     }
1573     ARGpop();
1574 }
1575 #endif  /* QUICKSORT */
1576 /*---------------------------------------------------------*/
1577 PRIVATE int tttype;
compfun(ptr1,ptr2)1578 PRIVATE int compfun(ptr1,ptr2)
1579 truc *ptr1, *ptr2;
1580 {
1581     char *str1, *str2;
1582 
1583     if(tttype >= fFIXNUM)
1584         return(cmpnums(ptr1,ptr2,tttype));
1585     else if(tttype == fSTRING) {
1586         str1 = STRINGPTR(ptr1);
1587         str2 = STRINGPTR(ptr2);
1588         return(strcmp(str1,str2));
1589     }
1590     else
1591         return(0);   /* this case should not happen */
1592 }
1593 /*---------------------------------------------------------*/
1594 PRIVATE truc *usercmpfun;
ucompfun(ptr1,ptr2)1595 PRIVATE int ucompfun(ptr1,ptr2)
1596 truc *ptr1, *ptr2;
1597 {
1598     truc argv[2];
1599     truc res;
1600     int flg;
1601 
1602     argv[0] = *ptr1;
1603     argv[1] = *ptr2;
1604     res = ufunapply(usercmpfun,argv,2);
1605     if(res == zero)
1606         return(0);
1607     else if((flg = *FLAGPTR(&res)) == fFIXNUM)
1608         return(*SIGNPTR(&res) ? -1 : 1);
1609     else if(flg == fBIGNUM)
1610         return(*SIGNUMPTR(&res) ? -1 : 1);
1611     else {
1612         error(sortsym,err_case,mkfixnum(flg));
1613         return(aERROR);
1614     }
1615 }
1616 /*---------------------------------------------------------*/
Ssort()1617 PRIVATE truc Ssort()
1618 {
1619     struct fundef *fundefptr;
1620     struct symbol *sptr;
1621     truc *argptr;
1622     truc *ptr;
1623     truc obj, fun;
1624     int argn;
1625 
1626     argn = *ARGCOUNTPTR(evalStkPtr);
1627     if(argn == 1) {
1628         argptr = ARG1PTR(evalStkPtr);
1629         return(Hsort1(argptr));
1630     }
1631     else {  /* argn == 2, second argument is compare function */
1632         ptr = ARGNPTR(evalStkPtr,2);
1633         obj = eval(ptr);
1634         if(Tflag(obj) != fSYMBOL)
1635             goto errexit;
1636         sptr = symptr(obj);
1637         if(*FLAGPTR(sptr) != sFUNCTION)
1638             goto errexit;
1639         fun = sptr->bind.t;
1640         fundefptr = (struct fundef *)Taddress(fun);
1641         if(fundefptr->argc != 2)
1642             goto errexit;
1643 
1644         argptr = ARG1PTR(evalStkPtr);
1645         WORKpush(*argptr);
1646         obj = Hsort2(workStkPtr,fun);
1647         WORKpop();
1648         return(obj);
1649   errexit:
1650         error(sortsym,"bad compare function",obj);
1651         return(brkerr());
1652     }
1653 }
1654 /*---------------------------------------------------------*/
Hsort1(argptr)1655 PRIVATE truc Hsort1(argptr)
1656 truc *argptr;
1657 {
1658     truc *arr;
1659     truc *vptr;
1660     unsigned k, len;
1661     int flg0, flg;
1662 
1663     flg0 = vectaddr(argptr,&vptr,&arr,&len);
1664     if(flg0 == aERROR) {
1665         error(sortsym,err_vect,*argptr);
1666         return(brkerr());
1667     }
1668     if(!len)
1669         return(eval(argptr));
1670     flg = *FLAGPTR(arr);
1671     if(flg >= fFIXNUM)
1672         flg = chknums(sortsym,arr,len);
1673     else if(flg == fSTRING) {
1674         for(k=1; k<len; k++) {
1675             if(*FLAGPTR(arr+k) != fSTRING) {
1676                 flg = aERROR;
1677                 break;
1678             }
1679         }
1680     }
1681     else
1682         flg = aERROR;
1683     if(flg == aERROR) {
1684         return(brkerr());
1685     }
1686     tttype = flg;       /* global variable */
1687     sortarr(arr,len,(ifuntt)compfun);
1688     return(eval(argptr));
1689 }
1690 /*---------------------------------------------------------*/
Hsort2(argptr,fun)1691 PRIVATE truc Hsort2(argptr,fun)
1692 truc *argptr;
1693 truc fun;
1694 {
1695     truc *arr, *workarr, *ptr;
1696     truc *vptr;
1697     unsigned k, len;
1698     int flg;
1699 
1700     flg = vectaddr(argptr,&vptr,&arr,&len);
1701     if(flg == aERROR) {
1702         error(sortsym,err_vect,*argptr);
1703         return(brkerr());
1704     }
1705     if(!len) {
1706         goto ausgang;
1707     }
1708     workarr = workStkPtr + 1;
1709     if(WORKspace(len) == NULL) {
1710         error(sortsym,err_memev,voidsym);
1711         goto ausgang;
1712     }
1713     ptr = workarr;
1714     for(k=0; k<len; k++)
1715         *ptr++ = *arr++;
1716     WORKpush(fun);
1717     usercmpfun = workStkPtr;
1718     sortarr(workarr,(int)len,(ifuntt)ucompfun);
1719     WORKpop();
1720     vectaddr(argptr,&vptr,&arr,&len);
1721     for(k=0; k<len; k++)
1722         *arr++ = *workarr++;
1723     WORKnpop(len);
1724   ausgang:
1725     return(eval(argptr));
1726 }
1727 /*---------------------------------------------------------*/
1728 /*
1729 ** binsearch(ele,vec,[compfun]): integer;
1730 **   Searches for ele in the array vec;
1731 **   returns position; if not found, -1 is returned.
1732 **   The array must be sorted.
1733 **   The optional argument compfun is a comparing function
1734 **   as in sort
1735 */
Fbsearch(argn)1736 PRIVATE truc Fbsearch(argn)
1737 int argn;
1738 {
1739     struct symbol *sptr;
1740     truc *argptr, *vptr, *ele;
1741     int flg, vergl;
1742     unsigned n1, n2, m;
1743 
1744     argptr = argStkPtr - argn + 1;
1745     vptr = argptr + 1;
1746     flg = *FLAGPTR(vptr);
1747     if(flg != fVECTOR) {
1748         error(bsearchsym,err_vect,*vptr);
1749         return(brkerr());
1750     }
1751 
1752     if(argn == 2) {     /* default compare function for numbers or strings */
1753         flg = *FLAGPTR(argptr);
1754         if(flg >= fFIXNUM || flg == fSTRING) {
1755             return Hbsearch1(argptr,vptr,flg);
1756         }
1757         else {
1758             error(bsearchsym,"lacking compare function",voidsym);
1759             return(brkerr());
1760         }
1761     }
1762     else {      /* argn=3, user supplied compare function */
1763         if(*FLAGPTR(argStkPtr) != fSYMBOL)
1764             goto badcompare;
1765         sptr = SYMPTR(argStkPtr);
1766         if(*FLAGPTR(sptr) != sFUNCTION)
1767             goto badcompare;
1768         *argStkPtr = sptr->bind.t;
1769         if(*FUNARGCPTR(argStkPtr) != 2)
1770             goto badcompare;
1771         usercmpfun = argStkPtr;     /* global variable */
1772 
1773         n1 = 0;
1774         n2 = *VECLENPTR(vptr);
1775         while(n2 > n1) {
1776             m = (n1 + n2)/2;
1777             ele = VECTORPTR(vptr) + m;
1778             vergl = ucompfun(argptr,ele);
1779             if(vergl < 0)
1780                 n2 = m;
1781             else if(vergl > 0)
1782                 n1 = m+1;
1783             else
1784                 return(mkfixnum(m));
1785         }
1786         return(mksfixnum(-1));
1787     }
1788   badcompare:
1789     error(bsearchsym,"bad compare function",voidsym);
1790     return(brkerr());
1791 }
1792 /*---------------------------------------------------------*/
1793 /*
1794 ** binary search in array of numbers or strings
1795 */
Hbsearch1(ele,vptr,flg)1796 PRIVATE truc Hbsearch1(ele,vptr,flg)
1797 truc *ele, *vptr;
1798 int flg;
1799 {
1800     int flg1, vergl;
1801     truc *arr;
1802     unsigned n1, n2, m;
1803 
1804     arr = VECTORPTR(vptr);
1805     n1 = 0;
1806     n2 = *VECLENPTR(vptr);
1807     if(flg == fSTRING) {
1808         tttype = flg;
1809         while(n2 > n1) {
1810             m = (n1 + n2)/2;
1811             flg1 = *FLAGPTR(arr+m);
1812             if(flg1 != flg) {
1813                 error(bsearchsym,err_str,arr[m]);
1814                 return(brkerr());
1815             }
1816             vergl = compfun(ele,arr+m);
1817             if(vergl < 0)
1818                 n2 = m;
1819             else if(vergl > 0)
1820                 n1 = m+1;
1821             else
1822                 return(mkfixnum(m));
1823         }
1824         return(mksfixnum(-1));
1825     }
1826     else if(flg >= fFIXNUM) {
1827         while(n2 > n1) {
1828             m = (n1 + n2)/2;
1829             flg1 = *FLAGPTR(arr+m);
1830             if(flg1 < fFIXNUM) {
1831                 error(bsearchsym,err_num,arr[m]);
1832                 return(brkerr());
1833             }
1834             tttype = (flg1 > flg ? flg1 : flg);
1835             vergl = compfun(ele,arr+m);
1836             if(vergl < 0)
1837                 n2 = m;
1838             else if(vergl > 0)
1839                 n1 = m+1;
1840             else
1841                 return(mkfixnum(m));
1842         }
1843         return(mksfixnum(-1));
1844     }
1845     else {
1846         error(bsearchsym,err_case,voidsym);
1847         return(brkerr());
1848     }
1849 }
1850 /*---------------------------------------------------------*/
vectaddr(ptr,ppvec,parr,plen)1851 PRIVATE int vectaddr(ptr,ppvec,parr,plen)
1852 truc *ptr;
1853 truc **ppvec;
1854 truc **parr;
1855 unsigned *plen;
1856 {
1857     truc *vecptr;
1858     truc *arr;
1859     long len, n0, n1;
1860     int ret;
1861 
1862     ret = Lvaladdr(ptr,&vecptr);
1863     switch(ret) {
1864     case vARRELE:
1865     case vRECFIELD:
1866         vecptr = Ltrucf(ret,vecptr);
1867         if(vecptr == NULL)
1868             return(aERROR);
1869         /* else fall through */
1870     case vBOUND:
1871         if(*FLAGPTR(vecptr) != fVECTOR) {
1872             return(aERROR);
1873         }
1874         len = *VECLENPTR(vecptr);
1875         arr = VECTORPTR(vecptr);
1876         break;
1877     case vSUBARRAY:
1878         ARGpush(vecptr[1]);
1879         ARGpush(vecptr[2]);
1880         argStkPtr[-1] = eval(argStkPtr-1);
1881         argStkPtr[0] = eval(argStkPtr);
1882         vecptr = argStkPtr-1;
1883         if(*FLAGPTR(vecptr) != fVECTOR) {
1884             ARGnpop(2);
1885             return(aERROR);
1886         }
1887         len = *VECLENPTR(vecptr);
1888         ret = indrange(argStkPtr,len,&n0,&n1);
1889         ARGnpop(2);
1890         if(ret == aERROR) {
1891             return(aERROR);
1892         }
1893         len = n1 - n0 + 1;
1894         arr = VECTORPTR(vecptr) + (size_t)n0;
1895         break;
1896     default:
1897         return(aERROR);
1898     }
1899     *ppvec = vecptr;
1900     *parr = arr;
1901     *plen = (unsigned)len;
1902     return(ret);
1903 }
1904 /*---------------------------------------------------------*/
bytestraddr(ptr,ppbstr,ppch,plen)1905 PUBLIC int bytestraddr(ptr,ppbstr,ppch,plen)
1906 truc *ptr;
1907 truc **ppbstr;
1908 byte **ppch;
1909 unsigned *plen;
1910 {
1911     struct strcell *string;
1912     truc *bstrptr;
1913     byte *cpt;
1914     long len, n0, n1;
1915     int flg, ret;
1916 
1917     ret = Lvaladdr(ptr,&bstrptr);
1918     switch(ret) {
1919     case vARRELE:
1920     case vRECFIELD:
1921         bstrptr = Ltrucf(ret,bstrptr);
1922         if(bstrptr == NULL)
1923             return(aERROR);
1924         /* else fall through */
1925     case vBOUND:
1926         flg = *FLAGPTR(bstrptr);
1927         if(flg != fBYTESTRING && flg != fSTRING) {
1928             return(aERROR);
1929         }
1930         string = STRCELLPTR(bstrptr);
1931         len = string->len;
1932         cpt = (byte *)&(string->ch0);
1933         break;
1934     case vSUBARRAY:
1935         ARGpush(bstrptr[1]);
1936         ARGpush(bstrptr[2]);
1937         argStkPtr[-1] = eval(argStkPtr-1);
1938         argStkPtr[0] = eval(argStkPtr);
1939         bstrptr = argStkPtr-1;
1940         flg = *FLAGPTR(bstrptr);
1941         if(flg != fBYTESTRING && flg != fSTRING) {
1942             ARGnpop(2);
1943             return(aERROR);
1944         }
1945         string = STRCELLPTR(bstrptr);
1946         ret = indrange(argStkPtr,(long)string->len,&n0,&n1);
1947         ARGnpop(2);
1948         if(ret == aERROR) {
1949             return(aERROR);
1950         }
1951         len = n1 - n0 + 1;
1952         cpt = (byte *)&(string->ch0) + (size_t)n0;
1953         break;
1954     default:
1955         return(aERROR);
1956     }
1957     *ppbstr = bstrptr;
1958     *ppch = cpt;
1959     *plen = (unsigned)len;
1960     return(flg);
1961 }
1962 /*---------------------------------------------------------*/
Ltrucf(flg,pptr)1963 PRIVATE truc *Ltrucf(flg,pptr)
1964 int flg;
1965 truc *pptr;
1966 {
1967     truc *ptr;
1968     long n0;
1969 
1970     switch(flg) {
1971     case vARRELE:
1972         ARGpush(pptr[1]);
1973         ARGpush(pptr[2]);
1974         argStkPtr[-1] = eval(argStkPtr-1);
1975         argStkPtr[0] = eval(argStkPtr);
1976         flg = arrindex(argStkPtr-1,&n0);
1977         if(flg == fVECTOR) {
1978             ptr = vectele(argStkPtr-1,n0);
1979         }
1980         else {
1981             ptr = NULL;
1982         }
1983         ARGnpop(2);
1984         break;
1985     case vRECFIELD:
1986         ARGpush(pptr[1]);
1987         *argStkPtr = eval(argStkPtr);
1988         ptr = recfield(argStkPtr,pptr[2]);
1989         ARGpop();
1990         break;
1991     default:
1992         ptr = NULL;
1993     }
1994     return(ptr);
1995 }
1996 /*--------------------------------------------------------------------*/
Ftextstring()1997 PRIVATE truc Ftextstring()
1998 {
1999     variant v;
2000     int flg;
2001 
2002     flg = *FLAGPTR(argStkPtr);
2003     if(flg == fSTRING) {
2004         return(*argStkPtr);
2005     }
2006     else if(flg != fBYTESTRING) {
2007         error(str_sym,err_bystr,*argStkPtr);
2008         return(brkerr());
2009     }
2010     else { /* flg == fBYTESTRING */
2011         *argStkPtr = mkcopy(argStkPtr);
2012     }
2013     v.xx = *argStkPtr;
2014     v.pp.b0 = fSTRING;
2015     return(v.xx);
2016 }
2017 /*---------------------------------------------------------*/
2018 /*
2019 ** byte_string(x,n: integer): byte_string;
2020 **   Interpretiert integer x als byte_string der Laenge n;
2021 **   negative Zahlen in Zweier-Komplement-Darstellung
2022 ** byte_string(s: string): byte_string;
2023 **   verwandelt string in byte_string;
2024 */
Fbstring(argn)2025 PRIVATE truc Fbstring(argn)
2026 int argn;
2027 {
2028     truc *argptr;
2029     truc bstr;
2030     word2 *x;
2031     byte *ptr;
2032     unsigned len, i, m;
2033     unsigned u, v;
2034     int flg, n, sign, pad;
2035     variant vv;
2036 
2037     argptr = argStkPtr - argn + 1;
2038     flg = *FLAGPTR(argptr);
2039     if(argn == 1) {
2040         if(flg == fSTRING) {
2041             *argStkPtr = mkcopy(argStkPtr);
2042             vv.xx = *argStkPtr;
2043             vv.pp.b0 = fBYTESTRING;
2044             return(vv.xx);
2045         }
2046         else if(flg == fBYTESTRING) {
2047             return *argStkPtr;
2048         }
2049     }
2050     if(flg < fINTTYPE0 || flg > fINTTYPE1) {
2051         error(bstringsym,err_intt,*argptr);
2052         return(brkerr());
2053     }
2054     if(argn == 2) {
2055         if((*FLAGPTR(argStkPtr) != fFIXNUM) || *SIGNPTR(argStkPtr)) {
2056             error(bstringsym,err_pfix,*argStkPtr);
2057             return(brkerr());
2058         }
2059         len = *WORD2PTR(argStkPtr);
2060     }
2061     else {
2062         n = bigref(argStkPtr,&x,&sign);
2063         len = (bit_length(x,n) + 7) >> 3;
2064     }
2065     bstr = mkbstr0(len);
2066     ptr = (byte *)STRING(bstr);
2067     x = AriBuf;
2068     if(flg == fGF2NINT) {
2069         n = bigretr(argptr,x,&sign);
2070         pad = 0;
2071     }
2072     n = twocretr(argptr,x);
2073     pad = (n >= (len+1)/2 ? 0 : 1);
2074     m = (pad ? n : len/2);
2075     if(pad)
2076         v = x[n];   /* 0x00 or 0xFF */
2077     for(i=0; i<m; i++) {
2078         u = *x++;
2079         *ptr++ = u;
2080         *ptr++ = (u >> 8);
2081     }
2082     if(!pad && (len & 1)) {
2083         *ptr = *x;
2084     }
2085     else if(pad) {
2086         len -= 2*m;
2087         for(i=0; i<len; i++)
2088             *ptr++ = v;
2089     }
2090     return(bstr);
2091 }
2092 /*---------------------------------------------------------*/
Smembtest()2093 PRIVATE truc Smembtest()
2094 {
2095     return(GmemBi(mbtestsym));
2096 }
2097 /*---------------------------------------------------------*/
Smembset()2098 PRIVATE truc Smembset()
2099 {
2100     return(GmemBi(mbsetsym));
2101 }
2102 /*---------------------------------------------------------*/
Smembclear()2103 PRIVATE truc Smembclear()
2104 {
2105     return(GmemBi(mbclrsym));
2106 }
2107 /*---------------------------------------------------------*/
Smemshift()2108 PRIVATE truc Smemshift()
2109 {
2110     return(GmemBi(mshiftsym));
2111 }
2112 /*---------------------------------------------------------*/
Smemand()2113 PRIVATE truc Smemand()
2114 {
2115     return(GmemBB(mandsym));
2116 }
2117 /*---------------------------------------------------------*/
Smemor()2118 PRIVATE truc Smemor()
2119 {
2120     return(GmemBB(morsym));
2121 }
2122 /*---------------------------------------------------------*/
Smemxor()2123 PRIVATE truc Smemxor()
2124 {
2125     return(GmemBB(mxorsym));
2126 }
2127 /*---------------------------------------------------------*/
Smemnot()2128 PRIVATE truc Smemnot()
2129 {
2130     return(GmemBB(mnotsym));
2131 }
2132 /*---------------------------------------------------------*/
Smembitsw()2133 PRIVATE truc Smembitsw()
2134 {
2135     return(GmemBB(mbitswsym));
2136 }
2137 /*---------------------------------------------------------*/
Smembytesw()2138 PRIVATE truc Smembytesw()
2139 {
2140     return(GmemBi(mbyteswsym));
2141 }
2142 /*---------------------------------------------------------*/
GmemBi(symb)2143 PRIVATE truc GmemBi(symb)
2144 truc symb;
2145 {
2146     truc *argptr, *bstrptr;
2147     truc obj;
2148     byte *cpt;
2149     long pos;
2150     unsigned len, n, k;
2151     unsigned mask = 1;
2152     int ret;
2153 
2154     obj = eval(ARG1PTR(evalStkPtr));
2155     pos = intretr(&obj);
2156     argptr = ARG0PTR(evalStkPtr);
2157     if(pos == LONGERROR) {
2158         error(symb,err_p4int,obj);
2159         goto errexit;
2160     }
2161     ret = bytestraddr(argptr,&bstrptr,&cpt,&len);
2162     if(ret != fBYTESTRING)
2163         goto errexit;
2164 
2165     if(symb == mshiftsym) {
2166         byteshift(cpt,len,pos);
2167         return(*bstrptr);
2168     }
2169     if(symb == mbyteswsym) {
2170         byteswap(cpt,len,(unsigned)pos);
2171         return(*bstrptr);
2172     }
2173     n = pos >> 3;
2174     k = pos & 0x7;
2175     mask <<= k;
2176     if(symb == mbtestsym) {
2177         if(pos < 0 || n >= len)
2178             return(zero);
2179         else if(cpt[n] & mask)
2180             return(constone);
2181         else
2182             return(zero);
2183 
2184     }
2185     if(pos >= 0 && n < len) {
2186         if(symb == mbsetsym)
2187             cpt[n] |= mask;
2188         else if(symb == mbclrsym)
2189             cpt[n] &= ~mask;
2190     }
2191     return(*bstrptr);
2192   errexit:
2193     error(symb,err_vbystr,*argptr);
2194     return(brkerr());
2195 }
2196 /*---------------------------------------------------------*/
GmemBB(symb)2197 PRIVATE truc GmemBB(symb)
2198 truc symb;
2199 {
2200     truc *argptr, *bstrptr, *bstrptr2;
2201     byte *cpt, *cpt2;
2202     unsigned len, len2, u;
2203     int ret;
2204 
2205     argptr = ARG0PTR(evalStkPtr);
2206     ret = bytestraddr(argptr,&bstrptr,&cpt,&len);
2207     if(ret != fBYTESTRING)
2208         goto errexit;
2209 
2210     if(symb == mnotsym) {
2211         while(len--) {
2212             u = *cpt;
2213             *cpt++ = ~u;
2214         }
2215         return(*bstrptr);
2216     }
2217     else if(symb == mbitswsym) {
2218         while(len--) {
2219             u = *cpt;
2220             *cpt++ = BitSwap[u];
2221         }
2222         return(*bstrptr);
2223     }
2224     WORKpush(*bstrptr);
2225 
2226     argptr = ARG1PTR(evalStkPtr);
2227     ret = bytestraddr(argptr,&bstrptr2,&cpt2,&len2);
2228     if(ret != fBYTESTRING)
2229         goto errexit2;
2230     if(len2 < len)
2231         len = len2;
2232     if(symb == mxorsym) {
2233         while(len--)
2234             *cpt++ ^= *cpt2++;
2235     }
2236     else if(symb == mandsym) {
2237         while(len--)
2238             *cpt++ &= *cpt2++;
2239     }
2240     else if(symb == morsym) {
2241         while(len--)
2242             *cpt++ |= *cpt2++;
2243     }
2244     return(WORKretr());
2245   errexit2:
2246     WORKpop();
2247   errexit:
2248     error(symb,err_vbystr,*argptr);
2249     return(brkerr());
2250 }
2251 /*---------------------------------------------------------*/
byteshift(ptr,len,sh)2252 PRIVATE void byteshift(ptr,len,sh)
2253 byte *ptr;
2254 unsigned len;
2255 long sh;
2256 {
2257     word4 k;
2258     unsigned m, sh0, sh1;
2259 
2260     k = (sh > 0 ? sh >> 3 : (-sh) >> 3);
2261     if(k >= len) {
2262         for(m=0; m<len; m++)
2263             *ptr++ = 0;
2264         return;
2265     }
2266     sh0 = (sh > 0 ? sh & 0x7 : (-sh) & 0x7);
2267     if(sh > 0) {
2268         if(k) {
2269             for(m=len; m>k; --m)
2270                 ptr[m-1] = ptr[m-k-1];
2271             for(m=0; m<k; m++)
2272                 ptr[m] = 0;
2273         }
2274         if(sh0) {
2275             sh1 = 8 - sh0;
2276             for(m=len-1; m>k; m--)
2277                 ptr[m] = (ptr[m] << sh0) | (ptr[m-1] >> sh1);
2278             ptr[k] <<= sh0;
2279         }
2280     }
2281     else if(sh < 0) {
2282         if(k) {
2283             for(m=k; m<len; m++)
2284                 ptr[m-k] = ptr[m];
2285             for(m=len-k; m<len; m++)
2286                 ptr[m] = 0;
2287         }
2288         if(sh0) {
2289             sh1 = 8 - sh0;
2290             for(m=1; m<len-k; m++)
2291                 ptr[m-1] = (ptr[m-1]>>sh0) | (ptr[m]<<sh1);
2292             ptr[len-k-1] >>= sh0;
2293         }
2294     }
2295 }
2296 /*---------------------------------------------------------*/
byteswap(ptr,len,grp)2297 PRIVATE void byteswap(ptr,len,grp)
2298 byte *ptr;
2299 unsigned len, grp;
2300 {
2301     byte *ptr1, *ptr2;
2302     unsigned x,k;
2303 
2304     if(len < grp || !grp)
2305         return;
2306     len -= grp;
2307     for(k=0; k<=len; k+=grp,ptr+=grp) {
2308         ptr1 = ptr;
2309         ptr2 = ptr1 + grp - 1;
2310         while(ptr2 > ptr1) {
2311         x = *ptr1;
2312         *ptr1++ = *ptr2;
2313         *ptr2-- = x;
2314         }
2315     }
2316 }
2317 /*--------------------------------------------------------------------*/
2318 /*
2319 ** Beschafft die Addresse einer Pointer-Variablen
2320 */
Paddr(ptr,pvptr)2321 PRIVATE int Paddr(ptr,pvptr)
2322 truc *ptr;
2323 trucptr *pvptr;
2324 {
2325     truc *vptr;
2326     int ret;
2327 
2328     ret = Lvaladdr(ptr,&vptr);
2329     switch(ret) {
2330     case vBOUND:
2331         break;
2332     case vARRELE:
2333     case vRECFIELD:
2334         vptr = Ltrucf(ret,vptr);
2335         if(vptr == NULL)
2336             return(aERROR);
2337         break;
2338     default:
2339         return(aERROR);
2340     }
2341     if(*FLAGPTR(vptr) != fPOINTER)
2342         ret = aERROR;
2343     else
2344         *pvptr = vptr;
2345     return(ret);
2346 }
2347 /*--------------------------------------------------------------------*/
2348 /*
2349 ** Argument in *argStkPtr ist ein 2n-tupel mit
2350 ** n Feldbezeichnungen und n Anfangswerten bzw. Prozeduren,
2351 ** die Anfangswerte erzeugen.
2352 ** Resultat ein initialisierter Record
2353 */
Fmkrec0()2354 PRIVATE truc Fmkrec0()
2355 {
2356     truc *ptr;
2357     truc obj;
2358     unsigned i, n;
2359 
2360     n = *VECLENPTR(argStkPtr);
2361     n /= 2;
2362     ptr = VECTORPTR(argStkPtr) + n;
2363     for(i=0; i<n; i++)
2364         ARGpush(ptr[i]);
2365     ptr = argStkPtr - n + 1;
2366     for(i=0; i<n; i++,ptr++)
2367         *ptr = eval(ptr);
2368     obj = mkrecord(fRECORD,argStkPtr-n,n);
2369     ARGnpop(n);
2370     return(obj);
2371 }
2372 /*--------------------------------------------------------------------*/
Srecfield()2373 PRIVATE truc Srecfield()
2374 {
2375     truc *ptr;
2376     truc field;
2377 
2378     field = *ARG1PTR(evalStkPtr);
2379     ARGpush(*ARG0PTR(evalStkPtr));
2380     *argStkPtr = eval(argStkPtr);
2381     ptr = recfield(argStkPtr,field);
2382     ARGpop();
2383     if(ptr == NULL) {
2384         return(brkerr());
2385     }
2386     else {
2387         return(*ptr);
2388     }
2389 }
2390 /*--------------------------------------------------------------------*/
Sderef()2391 PRIVATE truc Sderef()
2392 {
2393     truc *ptr;
2394     truc obj;
2395 
2396     obj = eval(ARG0PTR(evalStkPtr));
2397     ARGpush(obj);
2398     if(*FLAGPTR(argStkPtr) != fPOINTER) {
2399         error(derefsym,err_vpoint,voidsym);
2400         obj = brkerr();
2401     }
2402     else {
2403         ptr = TAddress(argStkPtr);
2404         obj = ptr[2];
2405         if(obj == nil) {
2406             error(derefsym,err_nil,voidsym);
2407             obj = brkerr();
2408         }
2409     }
2410     ARGpop();
2411     return(obj);
2412 }
2413 /*--------------------------------------------------------------------*/
2414 /*
2415 ** Argument ist muss eine Pointer-Variable in *evalStkPtr sein
2416 */
Snew()2417 PRIVATE truc Snew()
2418 {
2419     return(pnew10(ARG0PTR(evalStkPtr),1));
2420 }
2421 /*--------------------------------------------------------------------*/
Pdispose(ptr)2422 PUBLIC truc Pdispose(ptr)
2423 truc *ptr;
2424 {
2425     return(pnew10(ptr,0));
2426 }
2427 /*--------------------------------------------------------------------*/
pnew10(ptr,mode)2428 PRIVATE truc pnew10(ptr,mode)
2429 truc *ptr;
2430 int mode;   /* mode = 1: new, mode = 0: dispose */
2431 {
2432     truc *vptr;
2433     truc obj, symb;
2434 
2435     if(Paddr(ptr,&vptr) == aERROR) {
2436         symb = (mode ? mknewsym : nil);
2437         error(symb,err_vpoint,voidsym);
2438         return(brkerr());
2439     }
2440     if(mode) {
2441         ptr = TAddress(vptr);
2442         ARGpush(ptr[1]);
2443         *argStkPtr = Fmkrec0();
2444         *vptr = mkcopy(vptr);
2445         obj = ARGretr();
2446     }
2447     else
2448         obj = nil;
2449     *PTARGETPTR(vptr) = obj;
2450     return(obj);
2451 }
2452 /*--------------------------------------------------------------------*/
2453 /*
2454 ** Schreibt in das Feld field des Records *rptr den Eintrag obj
2455 */
recfassign(rptr,field,obj)2456 PUBLIC truc recfassign(rptr,field,obj)
2457 truc *rptr;
2458 truc field, obj;
2459 {
2460     truc *ptr;
2461 
2462     ptr = recfield(rptr,field);
2463     if(ptr == NULL) {
2464         return(brkerr());
2465     }
2466     *ptr = obj;
2467     return(obj);
2468 }
2469 /*--------------------------------------------------------------------*/
2470 /*
2471 ** Zuweisung von obj an den Record *rptr
2472 ** Es wird vorausgesetzt, dass bereits gecheckt ist, dass *rptr
2473 ** tatsaechlich ein Record ist
2474 ** und dass obj eine Kopie des urspruenglichen Objects ist.
2475 ** Die Vertraeglichkeit der Feldtypen wird nicht geprueft
2476 */
fullrecassign(rptr,obj)2477 PUBLIC truc fullrecassign(rptr,obj)
2478 truc *rptr;
2479 truc obj;
2480 {
2481     struct record *ptr1, *ptr2;
2482 
2483     ptr1 = RECORDPTR(rptr);
2484     ptr2 = recordptr(obj);
2485 
2486     if(ptr2->flag != fRECORD || ptr2->len != ptr1->len) {
2487         error(assignsym,err_mism,voidsym);
2488         return(brkerr());
2489     }
2490     ptr2->recdef = ptr1->recdef;
2491     return(*rptr = obj);
2492 }
2493 /*--------------------------------------------------------------------*/
recfield(rptr,field)2494 PRIVATE truc *recfield(rptr,field)
2495 truc *rptr;
2496 truc field;
2497 {
2498     struct record *sptr;
2499     truc *ptr, *fptr;
2500     unsigned n, i;
2501     int flg;
2502 
2503     flg = *FLAGPTR(rptr);
2504     if(flg == fPOINTER) {
2505         sptr = RECORDPTR(rptr);
2506         if(sptr->field1 != nil) {
2507             rptr = &(sptr->field1);
2508             flg = *FLAGPTR(rptr);
2509         }
2510     }
2511     if(flg != fRECORD) {
2512         error(recordsym,"record variable expected",*rptr);
2513         return(NULL);
2514     }
2515     ptr = TAddress(rptr);
2516     fptr = TAddress(ptr+1);
2517     n = *WORD2PTR(fptr) / 2;
2518     fptr++;
2519     for(i=0; i<n; i++) {
2520         if(*fptr++ == field)
2521             return(ptr + i + 2);
2522     }
2523     error(recordsym,err_field,field);
2524     return(NULL);
2525 }
2526 /**********************************************************************/
2527