/* * File: fmisc.c * Contents: args, [callout], char, collect, copy, display, errorclear, iand, * icom, image, ior, ishift, ixor, ord, name, runerr, seq, sort, type, variable */ #include #include "..\h\config.h" #include "..\h\rt.h" #include "rproto.h" extern word coll_tot; extern word coll_stat; extern word coll_str; extern word coll_blk; struct dpair { struct descrip dr; struct descrip dv; }; /* * Prototypes. */ hidden int getname Params((dptr dp1, dptr dp2)); hidden int trefcmp Params((dptr d1,dptr d2)); hidden int tvalcmp Params((dptr d1,dptr d2)); hidden int trcmp3 Params((struct dpair *dp1,struct dpair *dp2)); hidden int tvcmp4 Params((struct dpair *dp1,struct dpair *dp2)); /* * args(x) - produce number of arguments for procedure x. */ FncDcl(args,1) { if (Arg1.dword != D_Proc) RunErr(106, &Arg1); MakeInt(((struct b_proc *)BlkLoc(Arg1))->nparam,&Arg0); Return; } #ifdef ExternalFunctions #ifdef IconCalling /* * callout - call a C routine with an argument count and a list of descriptors. */ FncDclV(callout) { dptr retval; struct pf_marker *newpfp; register word *newsp = sp; int signal; /*------------------------------------------------------------------------*/ /* * Build a procedure frame. This is not normal for "built-in" procedures, * but we're preparing to call Icon back, if necessary. To get rid of * this frame, on the way out signal a Pret. The code between the dashed * lines is copied largely from invoke(). */ newpfp = (struct pf_marker *)(newsp + 1); newpfp->pf_nargs = nargs; newpfp->pf_argp = argp; newpfp->pf_pfp = pfp; newpfp->pf_ilevel = ilevel; newpfp->pf_scan = NULL; newpfp->pf_ipc = ipc; newpfp->pf_gfp = gfp; newpfp->pf_efp = efp; argp = cargp; /* cargp is newargp in invoke() */ pfp = newpfp; newsp += Vwsizeof(*pfp); efp = 0; gfp = 0; sp = newsp; /*------------------------------------------------------------------------*/ /* * Little cheat here. Although this is a var-arg procedure, we need * at least one argument to get started: pretend there is a null on * the stack. NOTE: Actually, at present, varargs functions always * have at least one argument, so this doesn't plug the hole. */ if (nargs < 1) RunErr(103, &nulldesc); /* * Call the 'C routine caller' with a pointer to an array of descriptors. * Note that these are being left on the stack. We are passing * the name of the routine as part of the convention of calling * routines with an argc/argv technique. */ signal = -1; /* presume successful completion */ retval = extcall(&Arg1, nargs, &signal); if (signal >= 0) { if (retval == NULL) RunErr(-signal, NULL) else RunErr(signal, retval); } if (retval != NULL) { Arg0 = *retval; return A_Pret_uw; } else return A_Pfail_uw; } #else /* IconCalling */ /* * callout - call a C library routine (or any C routine which doesn't call Icon) * with an argument count and a list of descriptors. This routine * doesn't build a procedure frame to prepare for calling Icon back. */ FncDclV(callout) { dptr retval; int signal; /* * Little cheat here. Although this is a var-arg procedure, we need * at least one argument to get started: pretend there is a null on * the stack. NOTE: Actually, at present, varargs functions always * have at least one argument, so this doesn't plug the hole. */ if (nargs < 1) RunErr(103, &nulldesc); /* * Call the 'C routine caller' with a pointer to an array of descriptors. * Note that these are being left on the stack. We are passing * the name of the routine as part of the convention of calling * routines with an argc/argv technique. */ signal = -1; /* presume successful completiong */ retval = extcall(&Arg1, nargs, &signal); if (signal >= 0) { if (retval == NULL) RunErr(-signal, NULL) else RunErr(signal, retval); } if (retval != NULL) { Arg0 = *retval; Return; } else Fail; } #endif /* IconCalling */ #endif /* ExternalFunctions */ /* * char(i) - produce a string consisting of character i. */ FncDcl(char,1) { char c; if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (IntVal(Arg1) < 0 || IntVal(Arg1) >= 256) RunErr(205, &Arg1); if (strreq((uword)1) == Error) RunErr(0, NULL); c = IntVal(Arg1); StrLen(Arg0) = 1; StrLoc(Arg0) = alcstr(&FromAscii(c), (word)1); Return; } /* * collect(r,n) - call garbage collector to ensure n bytes in region r. */ FncDcl(collect,2) { long region, bytes; word coll = coll_tot; if ((defint(&Arg1, ®ion, (word)0) == Error) || (defint(&Arg2, &bytes, (word)0) == Error)) RunErr(0, NULL); if (bytes < 0) RunErr(205, &Arg2); switch ((int)region) { case 0: break; case Static: coll_stat++; break; case Strings: coll_str++; if (strreq((uword)bytes) == Error) Fail; break; case Blocks: coll_blk++; if (blkreq((uword)bytes) == Error) Fail; break; default: RunErr(205, &Arg1); }; if (coll == coll_tot) collect((int)region); Arg0 = nulldesc; Return; } /* * copy(x) - make a copy of object x. */ FncDcl(copy,1) { register int i; word slotnum; struct descrip *d1, *d2; struct b_slots *seg; register union block **tp, *ep, *bp, *op; if (Qual(Arg1)) /* * Arg1 is a string; just copy its descriptor * into Arg0. */ Arg0 = Arg1; else { switch (Type(Arg1)) { case T_Null: case T_Integer: #ifdef LargeInts case T_Bignum: #endif /* LargeInts */ case T_Real: case T_File: case T_Cset: case T_Proc: case T_Coexpr: case T_External: /* * Copy the null value, integers, long integers, reals, files, * csets, procedures, and such by copying the descriptor. * Note that for integers, this results in the assignment * of a value, for the other types, a pointer is directed to * a data block. */ Arg0 = Arg1; break; case T_List: /* * Pass the buck to cplist to copy a list. */ if (cplist(&Arg1, &Arg0, (word)1, BlkLoc(Arg1)->list.size + 1) == Error) RunErr(0, NULL); break; case T_Table: /* * Copy a Table. First, allocate and copy header and slot blocks. */ op = BlkLoc(Arg1); bp = hmake(T_Table, op->table.mask + 1, op->table.size); if (bp == NULL) RunErr(0, NULL); op = BlkLoc(Arg1); /* may have moved */ bp->table.size = op->table.size; bp->table.mask = op->table.mask; bp->table.defvalue = op->table.defvalue; for (i = 0; i < HSegs && op->table.hdir[i] != NULL; i++) memcopy((char *)bp->table.hdir[i], (char *)op->table.hdir[i], op->table.hdir[i]->blksize); /* * Work down the chain of element blocks in each bucket * and create identical chains in new table. */ for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { tp = &seg->hslots[slotnum]; for (ep = *tp; ep != NULL; ep = *tp) { *tp = (union block *)alctelem(); (*tp)->telem = ep->telem; tp = &(*tp)->telem.clink; } } Arg0.dword = D_Table; BlkLoc(Arg0) = bp; if (TooSparse(bp)) hshrink(&Arg0); break; case T_Set: /* * Pass the buck to cpset to copy a set. */ if (cpset(&Arg1, &Arg0, BlkLoc(Arg1)->set.size) == Error) RunErr(0, NULL); break; case T_Record: /* * Allocate space for the new record and copy the old * one into it. */ if (blkreq(BlkLoc(Arg1)->record.blksize) == Error) RunErr(0, NULL); i = (int)BlkLoc(Arg1)->record.recdesc->proc.nfields; bp = (union block *)alcrecd(i,&BlkLoc(Arg1)->record.recdesc); bp->record = BlkLoc(Arg1)->record; bp->record.id = bp->record.recdesc->proc.recid++; /* get new id */ d1 = bp->record.fields; d2 = BlkLoc(Arg1)->record.fields; while (i--) *d1++ = *d2++; /* * Return the copied record */ Arg0.dword = D_Record; BlkLoc(Arg0) = bp; break; default: RunErr(123,&Arg1); } } Return; } /* * display(i,f) - display local variables of i most recent * procedure activations, plus global variables. * Output to file f (default &errout). */ FncDcl(display,2) { long l; int count; FILE *f; /* * Arg1 defaults to &level; Arg2 defaults to &errout. */ if ((defint(&Arg1, &l, (word)k_level) == Error) || (deffile(&Arg2, &errout) == Error)) RunErr(0, NULL); /* * Produce error if file cannot be written. */ f = BlkLoc(Arg2)->file.fd; if ((BlkLoc(Arg2)->file.status & Fs_Write) == 0) RunErr(213, &Arg2); /* * Produce error if Arg1 is negative; constrain Arg1 to be >= &level. */ if (l < 0) { RunErr(205, &Arg1); } else if (l > k_level) count = k_level; else count = (int)l; fprintf(f,"co-expression_%ld(%ld)\n\n",BlkLoc(k_current)->coexpr.id, BlkLoc(k_current)->coexpr.size); fflush(f); xdisp(pfp,argp,count,f); Arg0 = nulldesc; /* Return null value. */ Return; } /* * errorclear() - clear error condition. */ FncDcl(errorclear,0) { k_errornumber = 0; k_errortext = ""; k_errorvalue = nulldesc; Arg0 = nulldesc; Return; } /* * iand(i,j) - produce bitwise AND of i and j. */ FncDcl(iand,2) { #ifdef LargeInts int t1, t2; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t2 == T_Real) { if (realtobig(&Arg2, &Arg2) == Error) /* alcbignum failed */ RunErr(0, NULL);; t2 = Type(Arg2); } if (t1 == T_Integer && t2 == T_Integer) { MakeInt(IntVal(Arg1) & IntVal(Arg2), &Arg0); } else if (bigand(&Arg1, &Arg2, &Arg0) == Error) /* alcvignum failed */ RunErr(0, NULL); #else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); MakeInt(IntVal(Arg1) & IntVal(Arg2), &Arg0); #endif /* LargeInts */ Return; } /* * icom(i) - produce bitwise complement (one's complement) of i. */ FncDcl(icom,1) { #ifdef LargeInts int t1; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t1 == T_Integer) { MakeInt(~IntVal(Arg1), &Arg0); } else { struct descrip td; td.dword = D_Integer; IntVal(td) = -1; if (bigsub(&td, &Arg1, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); } #else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); MakeInt(~IntVal(Arg1), &Arg0); #endif /* LargeInts */ Return; } /* * image(x) - return string image of object x. Nothing fancy here, * just plug and chug on a case-wise basis. */ FncDcl(image,1) { if (getimage(&Arg1,&Arg0) == Error) RunErr(0, NULL); Return; } /* * ior(i,j) - produce bitwise inclusive OR of i and j. */ FncDcl(ior,2) { #ifdef LargeInts int t1, t2; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t2 == T_Real) { if (realtobig(&Arg2, &Arg2) == Error) /* alcbignum failed */ RunErr(0, NULL); t2 = Type(Arg2); } if (t1 == T_Integer && t2 == T_Integer) { MakeInt(IntVal(Arg1) | IntVal(Arg2), &Arg0); } else if (bigor(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); #else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); MakeInt(IntVal(Arg1) | IntVal(Arg2), &Arg0); #endif /* LargeInts */ Return; } /* * ishift(i,j) - produce i shifted j bit positions (left if j<0, right if j>0). */ FncDcl(ishift,2) { uword i; /* unsigned to ensure zero fill on right shift */ word n; #ifdef LargeInts int t1; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t1 == T_Bignum || IntVal(Arg2) > 0) { if (bigshift(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); Return; } #else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); #endif /* LargeInts */ i = (uword)IntVal(Arg1); n = IntVal(Arg2); /* * Check for a shift of WordSize or greater; return an explicit 0 because * this is beyond C's defined behavior. Otherwise shift as requested. */ if (n <= -WordBits || n >= WordBits) i = 0; else if (n < 0) i >>= -n; else i <<= n; MakeInt(i, &Arg0); Return; } /* * ixor(i,j) - produce bitwise exclusive OR of i and j. */ FncDcl(ixor,2) { #ifdef LargeInts int t1, t2; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t2 == T_Real) { if (realtobig(&Arg2, &Arg2) == Error) /* alcbignum failed */ RunErr(0, NULL); t2 = Type(Arg2); } if (t1 == T_Integer && t2 == T_Integer) { MakeInt(IntVal(Arg1) ^ IntVal(Arg2), &Arg0); } else if (bigxor(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); #else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); MakeInt(IntVal(Arg1) ^ IntVal(Arg2), &Arg0); #endif /* LargeInts */ Return; } /* * ord(s) - produce integer ordinal (value) of single chracter. */ FncDcl(ord,1) { char sbuf[MaxCvtLen]; if (cvstr(&Arg1, sbuf) == CvtFail) RunErr(103, &Arg1); if (StrLen(Arg1) != 1) RunErr(205, &Arg1); MakeInt(ToAscii(*StrLoc(Arg1) & 0xFF), &Arg0); Return; } FncNDcl(name,1) { if (!Var(Arg1)) RunErr(111, &Arg1); if (getname(&Arg1, &Arg0) == Error) RunErr(0,NULL); Return; } /* * getname -- function to get print name of variable */ static int getname(dp1,dp0) dptr dp1, dp0; { dptr dp, varptr; union block *blkptr; char sbuf[100]; /* buffer; might be too small */ word i, j, k; extern word *ftabp, *records; word *rp; extern dptr fnames; /* * Is it a trapped variable? */ if Tvar(*dp1) { blkptr = BlkLoc(*dp1); switch (Type(*dp1)) { case T_Tvkywd: *dp0 = BlkLoc(*dp1)->tvkywd.kyname; return Success; case T_Tvsubs: getname(&(blkptr->tvsubs.ssvar),dp0); sprintf(sbuf,"[%ld:%ld]",blkptr->tvsubs.sspos, blkptr->tvsubs.sslen); j = strlen(sbuf); k = StrLen(*dp0); if (strreq(j + k) == Error) return Error; StrLoc(*dp0) = alcstr(StrLoc(*dp0),k); alcstr(sbuf,j); StrLen(*dp0) = j + k; return Success; case T_Tvtbl: return keyref(dp1,dp0); default: { syserr("name: invalid trapped variable"); } } } /* * Not a trapped variable; is it an identifier? */ dp = VarLoc(*dp1); /* get address of variable */ if (globals <= dp && dp < eglobals) { *dp0 = gnames[dp - globals]; /* global */ return Success; } else if (statics <= dp && dp < estatics) { blkptr = BlkLoc(*argp); i = dp - statics - blkptr->proc.fstatic; /* static */ if (i < 0 || i >= blkptr->proc.nstatic) syserr("name: unreferencable static variable"); i += abs(blkptr->proc.nparam) + abs(blkptr->proc.ndynam); *dp0 = blkptr->proc.lnames[i]; return Success; } else if (stack < (word *)dp && (word *)dp <= sp) { if ((struct pf_marker*)dp < pfp) { /* argument */ *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[(dp - argp) - 1]; } else { /* local */ *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[dp - pfp->pf_locals + ((struct b_proc *)VarLoc(*argp))->nparam]; } return Success; } /* * Must be an element of a structure. */ blkptr = (union block *)VarLoc(*dp1); varptr = (dptr)((word *)VarLoc(*dp1) + Offset(*dp1)); switch ((int)BlkType(blkptr)) { case T_Lelem: { /* list */ if ((i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1) < 1) i += blkptr->lelem.nslots; while (blkptr->lelem.listprev != NULL) { blkptr = blkptr->lelem.listprev; i += blkptr->lelem.nused; } sprintf(sbuf,"L[%ld]",i); i = strlen(sbuf); if (strreq(i) == Error) return Error; StrLoc(*dp0) = alcstr(sbuf,i); StrLen(*dp0) = i; return Success; } case T_Record: { /* record */ i = varptr - blkptr->record.fields; rp = records + 1; j = blkptr->record.recdesc->proc.recnum - 1; k = 0; while (ftabp[j] != i) { j += *records; k++; } sprintf(sbuf,"%s.%s",StrLoc(blkptr->record.recdesc->proc.recname), StrLoc(fnames[k])); i = strlen(sbuf); if (strreq(i) == Error) return Error; StrLoc(*dp0) = alcstr(sbuf,i); StrLen(*dp0) = i; return Success; } case T_Telem: { /* table */ return keyref(dp1,dp0); } default: /* none of the above */ syserr("name: invalid structure reference"); } } /* * keyref(bp,dp) -- print name of subscripted table */ int keyref(dp1, dp2) dptr dp1, dp2; { char *s; dp1 = &(((union block *)BlkLoc(*dp1))->telem.tref); if (getimage(dp1,dp2) == Error) return Error; if (strreq(StrLen(*dp2) + 3) == Error) return Error; s = alcstr("T[",(word)2); alcstr(StrLoc(*dp2),StrLen(*dp2)); alcstr("]",(word)1); StrLoc(*dp2) = s; StrLen(*dp2) = StrLen(*dp2) + 3; return Success; } /* * runerr(i,x) - produce runtime error i with value x. */ FncDclV(runerr) { if (nargs < 1) RunErr(-101, NULL); switch (cvint(&Arg1)) { case T_Integer: if (IntVal(Arg1) <= 0) RunErr(205, &Arg1); break; default: RunErr(101, &Arg1); } if (nargs == 1) { RunErr((int)(-IntVal(Arg1)), NULL); } else { RunErr((int)IntVal(Arg1), &Arg2); } } /* * seq(e1,e2) - generate e1, e1+e2, e1+e2+e2, ... . */ FncDcl(seq,2) { long from, by; /* * Default Arg1 and Arg2 to 1. */ if ((defint(&Arg1, &from, (word)1) == Error) || (defint(&Arg2, &by, (word)1) == Error)) RunErr(0, NULL); /* * Produce error if Arg2 is 0, i.e., an infinite sequence of Arg2s. */ if (by == 0) RunErr(211, &Arg2); /* * Suspend sequence, stopping when largest or smallest integer * is reached. */ while ((from <= MaxLong && by > 0) || (from >= MinLong && by < 0)) { MakeInt(from, &Arg0); Suspend; from += by; } Fail; } /* * sort(l) - sort list l. * sort(S) - sort set S. * sort(t,i) - sort table. */ FncDcl(sort,2) { register dptr d1; register word size, i, j; register struct b_slots *seg; word nslots; struct b_list *lp, *tp; union block *bp, *ep; if (Arg1.dword == D_List) { /* * Sort the list by copying it into a new list and then using * qsort to sort the descriptors. (That was easy!) */ size = BlkLoc(Arg1)->list.size; if (cplist(&Arg1, &Arg0, (word)1, size + 1) == Error) RunErr(0, NULL); qsort((char *)BlkLoc(Arg0)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), anycmp); } else if (Arg1.dword == D_Set) { /* * Create a list the size of the set, copy each element into the list, and * then sort the list using qsort as in list sorting and return the * sorted list. */ nslots = size = BlkLoc(Arg1)->set.size; if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) + nslots * sizeof(struct descrip)) == Error) RunErr(0, NULL); bp = BlkLoc(Arg1); lp = alclist(size); lp->listtail = (union block *)alclstb(nslots, (word)0, size); lp->listhead = lp->listtail; if (size > 0) { /* only need to sort non-empty sets */ d1 = lp->listhead->lelem.lslots; for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) *d1++ = ep->selem.setmem; qsort((char *)lp->listhead->lelem.lslots,(int)size, sizeof(struct descrip),anycmp); } Arg0.dword = D_List; BlkLoc(Arg0) = (union block *) lp; } else if (Arg1.dword == D_Table) { /* * Default i (the type of sort) to 1. */ if (defshort(&Arg2, 1) == Error) RunErr(0, NULL); switch ((int)IntVal(Arg2)) { /* * Cases 1 and 2 are as in standard Version 5. */ case 1: case 2: { /* * The list resulting from the sort will have as many elements as * the table has, so get that value and also make a valid list * block size out of it. */ nslots = size = BlkLoc(Arg1)->table.size; /* * Ensure space for: the list header block and a list element * block for the list which is to be returned, * a list header block and a list element block for each of the two * element lists the sorted list is to contain. Note that the * calculation might be better expressed as: * list_header_size + list_block_size + nslots * descriptor_size + * nslots * (list_header_size + list_block_size + 2*descriptor_size) */ if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) + nslots * (sizeof(struct b_list) + sizeof(struct b_lelem) + 3 * sizeof(struct descrip))) == Error) RunErr(0, NULL); /* * Point bp at the table header block of the table to be sorted * and point lp at a newly allocated list * that will hold the the result of sorting the table. */ bp = BlkLoc(Arg1); lp = alclist(size); lp->listtail = (union block *)alclstb(nslots, (word)0, size); lp->listhead = lp->listtail; /* * If the table is empty, there is no need to sort anything. */ if (size <= 0) break; /* * Point d1 at the start of the list elements in the new list * element block in preparation for use as an index into the list. */ d1 = lp->listhead->lelem.lslots; /* * Traverse the element chain for each table bucket. For each * element, allocate a two-element list and put the table * entry value in the first element and the assigned value in * the second element. The two-element list is assigned to * the descriptor that d1 points at. When this is done, the * list of two-element lists is complete, but unsorted. */ for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) { d1->dword = D_List; tp = alclist((word)2); BlkLoc(*d1) = (union block *)tp; tp->listtail = (union block *)alclstb((word)2, (word)0, (word)2); tp->listhead = tp->listtail; tp->listhead->lelem.lslots[0] = ep->telem.tref; tp->listhead->lelem.lslots[1] = ep->telem.tval; d1++; } /* * Sort the resulting two-element list using the sorting function * determined by i. */ if (IntVal(Arg2) == 1) qsort((char *)lp->listhead->lelem.lslots, (int)size, sizeof(struct descrip), trefcmp); else qsort((char *)lp->listhead->lelem.lslots, (int)size, sizeof(struct descrip), tvalcmp); break; /* from cases 1 and 2 */ } /* * Cases 3 and 4 were introduced in Version 5.10. */ case 3 : case 4 : { /* * The list resulting from the sort will have twice as many elements as * the table has, so get that value and also make a valid list * block size out of it. */ nslots = size = BlkLoc(Arg1)->table.size * 2; /* * Ensure space for: the list header block and a list element * block for the list which is to be returned, and two descriptors for * each table element. */ if (blkreq(sizeof(struct b_list) + Vsizeof(struct b_lelem) + (nslots * sizeof(struct descrip))) == Error) RunErr(0, NULL); /* * Point bp at the table header block of the table to be sorted * and point lp at a newly allocated list * that will hold the the result of sorting the table. */ bp = BlkLoc(Arg1); lp = alclist(size); lp->listtail = (union block *)alclstb(nslots, (word)0, size); lp->listhead = lp->listtail; /* * If the table is empty there's no need to sort anything. */ if (size <= 0) break; /* * Point d1 at the start of the list elements in the new list * element block in preparation for use as an index into the list. */ d1 = lp->listhead->lelem.lslots; /* * Traverse the element chain for each table bucket. For each * table element copy the the entry descriptor and the value * descriptor into adjacent descriptors in the lslots array * in the list element block. * When this is done we now need to sort this list. */ for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) { *d1++ = ep->telem.tref; *d1++ = ep->telem.tval; } /* * Sort the resulting two-element list using the sorting function * determined by i. */ if (IntVal(Arg2) == 3) qsort((char *)lp->listhead->lelem.lslots, (int)size / 2, (2 * sizeof(struct descrip)), trcmp3); else qsort((char *)lp->listhead->lelem.lslots, (int)size / 2, (2 * sizeof(struct descrip)), tvcmp4); break; /* from case 3 or 4 */ } default: RunErr(205, &Arg2); } /* end of switch statement */ /* * Make Arg0 point at the sorted list. */ Arg0.dword = D_List; BlkLoc(Arg0) = (union block *) lp; } else { /* Tried to sort something that wasn't a list or a table. */ RunErr(115, &Arg1); } Return; } /* * trefcmp(d1,d2) - compare two-element lists on first field. */ static int trefcmp(d1, d2) dptr d1, d2; { #ifdef DeBugIconx if (d1->dword != D_List || d2->dword != D_List) syserr("trefcmp: internal consistency check fails."); #endif /* DeBugIconx */ return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[0]))); } /* * tvalcmp(d1,d2) - compare two-element lists on second field. */ static int tvalcmp(d1, d2) dptr d1, d2; { #ifdef DeBugIconx if (d1->dword != D_List || d2->dword != D_List) syserr("tvalcmp: internal consistency check fails."); #endif /* DeBugIconx */ return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[1]))); } /* * The following two routines are used to compare descriptor pairs in the * experimental table sort. * * trcmp3(dp1,dp2) */ static int trcmp3(dp1, dp2) struct dpair *dp1,*dp2; { return (anycmp(&((*dp1).dr),&((*dp2).dr))); } /* * tvcmp4(dp1,dp2) */ static int tvcmp4(dp1, dp2) struct dpair *dp1,*dp2; { return (anycmp(&((*dp1).dv),&((*dp2).dv))); } /* * type(x) - return type of x as a string. */ FncDcl(type,1) { if (Qual(Arg1)) { StrLen(Arg0) = 6; StrLoc(Arg0) = "string"; } else { switch (Type(Arg1)) { case T_Null: StrLen(Arg0) = 4; StrLoc(Arg0) = "null"; break; #ifdef LargeInts case T_Bignum: #endif /* LargeInts */ case T_Integer: StrLen(Arg0) = 7; StrLoc(Arg0) = "integer"; break; case T_Real: StrLen(Arg0) = 4; StrLoc(Arg0) = "real"; break; case T_Cset: StrLen(Arg0) = 4; StrLoc(Arg0) = "cset"; break; case T_File: StrLen(Arg0) = 4; StrLoc(Arg0) = "file"; break; case T_Proc: StrLen(Arg0) = 9; StrLoc(Arg0) = "procedure"; break; case T_List: StrLen(Arg0) = 4; StrLoc(Arg0) = "list"; break; case T_Table: StrLen(Arg0) = 5; StrLoc(Arg0) = "table"; break; case T_Set: StrLen(Arg0) = 3; StrLoc(Arg0) = "set"; break; case T_Record: Arg0 = BlkLoc(Arg1)->record.recdesc->proc.recname; break; case T_Coexpr: StrLen(Arg0) = 13; StrLoc(Arg0) = "co-expression"; break; case T_External: StrLen(Arg0) = 8; StrLoc(Arg0) = "external"; break; default: RunErr(123,&Arg1); } } Return; } /* * variable(s) - find the variable with name s and return a * variable descriptor which points to its value. */ FncDcl(variable,1) { char sbuf[MaxCvtLen]; switch (cvstr(&Arg1, sbuf)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg1, sbuf); break; default: RunErr(103, &Arg1); } if (getvar(StrLoc(Arg1),&Arg0) == Success) Return; else Fail; }