![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam5.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp|
Return to lam5.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 ! root 1: #include "global.h" ! 2: #include "chkrtab.h" ! 3: ! 4: /*=========================================== ! 5: - ! 6: - explode functions ! 7: - The following function partially implement two explode functions, ! 8: - explodec and exploden. They only work for atom arguments. ! 9: - ! 10: -===========================================*/ ! 11: ! 12: #include "chars.h" ! 13: lispval ! 14: Lexpldx(kind,slashify) ! 15: int kind, slashify; /* 0=explodec 1=exploden */ ! 16: { ! 17: int typ, i; ! 18: char ch, *strb, strbb[BUFSIZ]; /* temporary string buffer */ ! 19: register lispval last, handy; ! 20: char Idqc = Xdqc; ! 21: snpand(4); /* kludge register save mask */ ! 22: ! 23: chkarg(1); ! 24: ! 25: handy = Vreadtable->clb; ! 26: chkrtab(handy); ! 27: handy = lbot->val; ! 28: *strbuf = 0; ! 29: typ=TYPE(handy); /* we only work for a few types */ ! 30: ! 31: ! 32: /* put the characters to return in the string buffer strb */ ! 33: ! 34: switch(typ) { ! 35: case STRNG: ! 36: strb = (char *) handy; ! 37: if(Xsdc)Idqc = Xsdc; ! 38: goto common; ! 39: case ATOM: ! 40: strb = handy->pname; ! 41: if(strb[0]==0) { ! 42: strb = strbb; ! 43: strbb[0] = Xdqc; ! 44: strbb[1] = Xdqc; ! 45: strbb[2] = 0; ! 46: } else ! 47: common: ! 48: if(slashify != 0) ! 49: { ! 50: register char *cp, *out = strbb; ! 51: cp = strb; ! 52: strb = strbb; ! 53: if(ctable[(*cp)&0177]==VNUM) ! 54: *out++ = Xesc; ! 55: for(; *cp; cp++) ! 56: { ! 57: if(ctable[*cp]& QUTMASK) ! 58: *out++ = Xesc; ! 59: *out++ = *cp; ! 60: } ! 61: *out = 0; ! 62: } ! 63: ! 64: break; ! 65: case INT: ! 66: strb = strbb; ! 67: sprintf(strb, "%d", lbot->val->i); ! 68: break; ! 69: case DOUB: ! 70: strb = strbb; ! 71: sprintf(strb, "%0.16G", lbot->val->r); ! 72: break; ! 73: case SDOT: ! 74: { ! 75: struct _iobuf _strbuf; ! 76: register count; ! 77: for((handy = lbot->val), count = 12; ! 78: handy->CDR!=(lispval) 0; ! 79: (handy = handy->CDR), count += 12); ! 80: strb = (char *) alloca(count); ! 81: ! 82: _strbuf._flag = _IOWRT+_IOSTRG; ! 83: _strbuf._ptr = strb; ! 84: _strbuf._cnt = count; ! 85: pbignum(lbot->val,&_strbuf); ! 86: putc('.',&_strbuf); ! 87: putc(0,&_strbuf); ! 88: break; ! 89: } ! 90: default: ! 91: errorh(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy); ! 92: return(nil); ! 93: } ! 94: ! 95: ! 96: if( strb[0] != NULL_CHAR ) /* if there is something to do */ ! 97: { ! 98: register lispval prev; ! 99: ! 100: protect(handy = last = newdot()); ! 101: strbuf[1] = NULL_CHAR ; /* set up for getatom */ ! 102: atmlen = 2; ! 103: ! 104: for(i=0; ch = strb[i++]; ) { ! 105: switch(kind) { ! 106: ! 107: case 0: strbuf[0] = hash = ch; /* character explode */ ! 108: hash = 177 & hash; /* cut 1st bit off if any */ ! 109: last->car = (lispval) getatom(); /* look in oblist */ ! 110: break; ! 111: ! 112: case 1: ! 113: last->car = inewint(ch); ! 114: break; ! 115: } ! 116: ! 117: /* advance pointers */ ! 118: prev = last; ! 119: last->cdr = newdot(); ! 120: last = last->cdr; ! 121: } ! 122: ! 123: /* end list with a nil pointer */ ! 124: prev->cdr = nil; ! 125: return(handy); ! 126: } ! 127: else return(nil); /* return nil if no characters */ ! 128: } ! 129: ! 130: /*=========================== ! 131: - ! 132: - (explodec 'atm) returns (a t m) ! 133: - (explodec 234) returns (\2 \3 \4) ! 134: -===========================*/ ! 135: ! 136: lispval ! 137: Lexpldc() ! 138: { return(Lexpldx(0,0)); } ! 139: ! 140: ! 141: /*=========================== ! 142: - ! 143: - (exploden 'abc) returns (65 66 67) ! 144: - (exploden 123) returns (49 50 51) ! 145: -=============================*/ ! 146: ! 147: ! 148: lispval ! 149: Lexpldn() ! 150: { return(Lexpldx(1,0)); } ! 151: ! 152: /*=========================== ! 153: - ! 154: - (explodea "123") returns (\\ \1 \2 \3); ! 155: - (explodea 123) returns (\1 \2 \3); ! 156: -=============================*/ ! 157: ! 158: lispval ! 159: Lexplda() ! 160: { return(Lexpldx(0,1)); } ! 161: ! 162: /* ! 163: * (argv) returns how many arguments where on the command line which invoked ! 164: * lisp; (argv i) returns the i'th argument made into an atom; ! 165: */ ! 166: ! 167: lispval ! 168: Largv() ! 169: { ! 170: register lispval handy; ! 171: register index; ! 172: register char c, *base; ! 173: extern int Xargc; ! 174: extern char **Xargv; ! 175: ! 176: chkarg(1); ! 177: handy = lbot->val; ! 178: ! 179: if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) { ! 180: strcpy(strbuf,Xargv[handy->i]); ! 181: return(getatom()); ! 182: } else { ! 183: return(inewint(Xargc)); ! 184: } ! 185: } ! 186: /* ! 187: * (chdir <atom>) executes a chdir command ! 188: * if successful, return t otherwise returns nil ! 189: */ ! 190: lispval Lchdir(){ ! 191: register lispval handy; ! 192: ! 193: chkarg(1); ! 194: handy=lbot->val; ! 195: if(TYPE(handy)==ATOM && (chdir(handy->pname)>=0)) ! 196: return(tatom); ! 197: else ! 198: return(nil); ! 199: } ! 200: ! 201: /* ========================================================== ! 202: - ! 203: - ascii - convert from number to ascii character ! 204: - ! 205: - form:(ascii number) ! 206: - ! 207: - the number is checked so that it is in the range 0-255 ! 208: - then it is made a character and returned ! 209: - =========================================================*/ ! 210: ! 211: lispval ! 212: Lascii() ! 213: { ! 214: register lispval handy; ! 215: ! 216: handy = lbot->val; /* get argument */ ! 217: ! 218: if(TYPE(handy) != INT) /* insure that it is an integer */ ! 219: { error("argument not an integer",FALSE); ! 220: return(nil); ! 221: } ! 222: ! 223: if(handy->i < 0 || handy->i > 0377) /* insure that it is in range*/ ! 224: { error("argument is out of ascii range",FALSE); ! 225: return(nil); ! 226: } ! 227: ! 228: strbuf[0] = handy->i ; /* ok value, make into a char */ ! 229: strbuf[1] = NULL_CHAR; ! 230: ! 231: /* lookup and possibly intern the atom given in strbuf */ ! 232: ! 233: return( (lispval) getatom() ); ! 234: } ! 235: ! 236: /* ! 237: * boole - maclisp bitwise boolean function ! 238: * (boole k x y) where k determines which of 16 possible bitwise ! 239: * truth tables may be applied. Common values are 1 (and) 6 (xor) 7 (or) ! 240: * the result is mapped over each pair of bits on input ! 241: */ ! 242: lispval ! 243: Lboole(){ ! 244: register x, y; ! 245: register lispval result; ! 246: register struct argent *mynp; ! 247: int k; ! 248: ! 249: if(np - lbot < 3) ! 250: error("Boole demands at least 3 args",FALSE); ! 251: mynp = lbot+AD; ! 252: k = mynp->val->i & 15; ! 253: x = (mynp+1)->val->i; ! 254: for(mynp += 2; mynp < np; mynp++) { ! 255: y = mynp->val->i; ! 256: switch(k) { ! 257: ! 258: case 0: x = 0; ! 259: break; ! 260: case 1: x = x & y; ! 261: break; ! 262: case 2: x = y & ~x; ! 263: break; ! 264: case 3: x = y; ! 265: break; ! 266: case 4: x = x & ~y; ! 267: break; ! 268: /* case 5: x = x; break; */ ! 269: case 6: x = x ^ y; ! 270: break; ! 271: case 7: x = x | y; ! 272: break; ! 273: case 8: x = ~(x | y); ! 274: break; ! 275: case 9: x = ~(x ^ y); ! 276: break; ! 277: case 10: x = ~x; ! 278: break; ! 279: case 11: x = ~x | y; ! 280: break; ! 281: case 12: x = ~y; ! 282: break; ! 283: case 13: x = x | ~y; ! 284: break; ! 285: case 14: x = ~x | ~y; ! 286: break; ! 287: case 15: x = -1; ! 288: } ! 289: } ! 290: return(inewint(x)); ! 291: } ! 292: lispval ! 293: Lfact() ! 294: { ! 295: register lispval result, handy; ! 296: register itemp; ! 297: snpand(3); /* fixup entry mask */ ! 298: ! 299: result = lbot->val; ! 300: if(TYPE(result)!=INT) error("Factorial of Non-fixnum. If you want me\ ! 301: to calculate fact of > 2^30 We will be here till doomsday!.",FALSE); ! 302: itemp = result->i; ! 303: protect(result = newsdot()); ! 304: result->CDR=(lispval)0; ! 305: result->i = 1; ! 306: for(; itemp > 1; itemp--) ! 307: dmlad(result,itemp,0); ! 308: if(result->CDR) return(result); ! 309: (handy = newint())->i = result->i; ! 310: return(handy); ! 311: } ! 312: /* ! 313: * fix -- maclisp floating to fixnum conversion ! 314: * for the moment, mereley convert floats to ints. ! 315: * eventual convert to bignum if too big to fit. ! 316: */ ! 317: lispval Lfix() ! 318: { ! 319: register lispval result, handy; ! 320: ! 321: chkarg(1); ! 322: handy = lbot->val; ! 323: switch(TYPE(handy)) { ! 324: default: ! 325: error("innaproriate arg to fix.",FALSE); ! 326: case INT: ! 327: case SDOT: ! 328: return(handy); ! 329: case DOUB: ! 330: if(handy->r >= 0) ! 331: return(inewint((int)handy->r)); ! 332: else ! 333: return(inewint(((int)handy->r)-1)); ! 334: } ! 335: } ! 336: ! 337: lispval ! 338: Lfloat() ! 339: { ! 340: register lispval handy,result; ! 341: chkarg(1); ! 342: handy = lbot->val; ! 343: switch(TYPE(handy)) ! 344: { ! 345: case DOUB: return(handy); ! 346: ! 347: ! 348: case INT: result = newdoub(); ! 349: result->r = (double) handy->i; ! 350: return(result); ! 351: ! 352: ! 353: default: error(Vermisc,"Bad argument to float",nil,FALSE,0,handy); ! 354: } ! 355: } ! 356: ! 357: /* Lbreak ***************************************************************/ ! 358: /* If first argument is not nil, this is evaluated and printed. Then */ ! 359: /* error is called with the "breaking" message. */ ! 360: lispval Lbreak() { ! 361: register lispval hold; ! 362: ! 363: if (np > lbot) { ! 364: printr(lbot->val,poport); ! 365: dmpport(poport); ! 366: } ! 367: return(error("",TRUE)); ! 368: } ! 369: ! 370: ! 371: lispval LDivide() { ! 372: register lispval result, work, temp; ! 373: register struct argent *mynp; ! 374: register struct argent *lbot, *np; ! 375: int typ; ! 376: lispval quo, rem; struct sdot dummy; ! 377: ! 378: chkarg(2); ! 379: mynp = lbot; ! 380: result = mynp->val; ! 381: work = (mynp+1)->val; ! 382: ! 383: if((typ=TYPE(result))==INT) { ! 384: protect(temp=newsdot()); ! 385: temp->i = result->i; ! 386: result = temp; ! 387: } else if (typ!=SDOT) ! 388: error("First arg to divide neither a bignum nor int.",FALSE); ! 389: typ = TYPE(work); ! 390: if(typ != INT && typ != SDOT) ! 391: error("second arg to Divide neither an sdot nor an int.",FALSE); ! 392: if(typ == INT) { ! 393: dummy.CDR = (lispval) 0; ! 394: dummy.I = work->i; ! 395: work = (lispval) &dummy; ! 396: } ! 397: divbig(result,work, &quo, &rem); ! 398: protect(quo); ! 399: if(rem==((lispval) &dummy)) ! 400: protect(rem = inewint(dummy.I)); ! 401: protect(result = work = newdot()); ! 402: work->car = quo; ! 403: (work->cdr = newdot())->car = rem; ! 404: return(result); ! 405: } ! 406: lispval LEmuldiv(){ ! 407: register struct argent * mynp = lbot+AD; ! 408: register lispval work, result; ! 409: int quo, rem; ! 410: snpand(3); /* fix register mask */ ! 411: ! 412: /* (Emuldiv mul1 mult2 add quo) => ! 413: temp = mul1 + mul2 + sext(add); ! 414: result = (list temp/quo temp%quo); ! 415: to mix C and lisp a bit */ ! 416: ! 417: Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i, ! 418: mynp[3].val->i, &quo, &rem); ! 419: protect(result=newdot()); ! 420: (result->car=inewint(quo)); ! 421: work = result->cdr = newdot(); ! 422: (work->car=inewint(rem)); ! 423: return(result); ! 424: } ! 425: static Imuldiv() { ! 426: asm(" emul 4(ap),8(ap),12(ap),r0"); ! 427: asm(" ediv 16(ap),r0,*20(ap),*24(ap)"); ! 428: } ! 429: ! 430:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.