From 8cd657f44b6ad3646895fb25c110e98fad549a52 Mon Sep 17 00:00:00 2001 From: John Foderaro Date: Sun, 2 Dec 1979 10:17:30 -0800 Subject: [PATCH] BSD 3 development Work on file usr/src/cmd/lisp/adbig.s Work on file usr/src/cmd/lisp/bind.c Work on file usr/src/cmd/lisp/chars.h Work on file usr/src/cmd/lisp/chkrtab.h Work on file usr/src/cmd/lisp/crt0.s Work on file usr/src/cmd/lisp/data.c Work on file usr/src/cmd/lisp/dfuncs.h Work on file usr/src/cmd/lisp/divbig.c Work on file usr/src/cmd/lisp/dodiv.s Work on file usr/src/cmd/lisp/dmlad.s Work on file usr/src/cmd/lisp/dsneg.s Work on file usr/src/cmd/lisp/eval2.c Work on file usr/src/cmd/lisp/fex2.c Work on file usr/src/cmd/lisp/fex4.c Work on file usr/src/cmd/lisp/fexr.c Work on file usr/src/cmd/lisp/ffasl.c Work on file usr/src/cmd/lisp/fixpbig.e Work on file usr/src/cmd/lisp/fpipe.c Work on file usr/src/cmd/lisp/frame.h Work on file usr/src/cmd/lisp/gtabs.h Work on file usr/src/cmd/lisp/inewint.s Work on file usr/src/cmd/lisp/io.c Work on file usr/src/cmd/lisp/lam1.c Work on file usr/src/cmd/lisp/lam2.c Work on file usr/src/cmd/lisp/lam3.c Synthesized-from: 3bsd --- usr/src/cmd/lisp/adbig.s | 162 +++++++++ usr/src/cmd/lisp/bind.c | 174 ++++++++++ usr/src/cmd/lisp/chars.h | 41 +++ usr/src/cmd/lisp/chkrtab.h | 4 + usr/src/cmd/lisp/crt0.s | 115 +++++++ usr/src/cmd/lisp/data.c | 78 +++++ usr/src/cmd/lisp/dfuncs.h | 49 +++ usr/src/cmd/lisp/divbig.c | 265 +++++++++++++++ usr/src/cmd/lisp/dmlad.s | 41 +++ usr/src/cmd/lisp/dodiv.s | 23 ++ usr/src/cmd/lisp/dsneg.s | 19 ++ usr/src/cmd/lisp/eval2.c | 78 +++++ usr/src/cmd/lisp/fex2.c | 257 ++++++++++++++ usr/src/cmd/lisp/fex4.c | 317 ++++++++++++++++++ usr/src/cmd/lisp/fexr.c | 96 ++++++ usr/src/cmd/lisp/ffasl.c | 109 ++++++ usr/src/cmd/lisp/fixpbig.e | 11 + usr/src/cmd/lisp/fpipe.c | 32 ++ usr/src/cmd/lisp/frame.h | 9 + usr/src/cmd/lisp/gtabs.h | 6 + usr/src/cmd/lisp/inewint.s | 11 + usr/src/cmd/lisp/io.c | 635 +++++++++++++++++++++++++++++++++++ usr/src/cmd/lisp/lam1.c | 668 +++++++++++++++++++++++++++++++++++++ usr/src/cmd/lisp/lam2.c | 593 ++++++++++++++++++++++++++++++++ usr/src/cmd/lisp/lam3.c | 504 ++++++++++++++++++++++++++++ 25 files changed, 4297 insertions(+) create mode 100644 usr/src/cmd/lisp/adbig.s create mode 100644 usr/src/cmd/lisp/bind.c create mode 100644 usr/src/cmd/lisp/chars.h create mode 100644 usr/src/cmd/lisp/chkrtab.h create mode 100644 usr/src/cmd/lisp/crt0.s create mode 100644 usr/src/cmd/lisp/data.c create mode 100644 usr/src/cmd/lisp/dfuncs.h create mode 100644 usr/src/cmd/lisp/divbig.c create mode 100644 usr/src/cmd/lisp/dmlad.s create mode 100644 usr/src/cmd/lisp/dodiv.s create mode 100644 usr/src/cmd/lisp/dsneg.s create mode 100644 usr/src/cmd/lisp/eval2.c create mode 100644 usr/src/cmd/lisp/fex2.c create mode 100644 usr/src/cmd/lisp/fex4.c create mode 100644 usr/src/cmd/lisp/fexr.c create mode 100644 usr/src/cmd/lisp/ffasl.c create mode 100644 usr/src/cmd/lisp/fixpbig.e create mode 100644 usr/src/cmd/lisp/fpipe.c create mode 100644 usr/src/cmd/lisp/frame.h create mode 100644 usr/src/cmd/lisp/gtabs.h create mode 100644 usr/src/cmd/lisp/inewint.s create mode 100644 usr/src/cmd/lisp/io.c create mode 100644 usr/src/cmd/lisp/lam1.c create mode 100644 usr/src/cmd/lisp/lam2.c create mode 100644 usr/src/cmd/lisp/lam3.c diff --git a/usr/src/cmd/lisp/adbig.s b/usr/src/cmd/lisp/adbig.s new file mode 100644 index 0000000000..f7005b55d3 --- /dev/null +++ b/usr/src/cmd/lisp/adbig.s @@ -0,0 +1,162 @@ + +# bignum add routine +# basic data representation is each bigit is a positive number +# less than 2^30, except for the leading bigit, which is in +# the range -2^30 < x < 2^30. + + .globl _adbig + .globl Bexport + .globl backfr +# +# Initialization section +# +_adbig: .word 0x0fc0 #save registers 6-11 + movl 4(ap),r1 #arg1 = addr of 1st bignum + movl 8(ap),r2 #arg2 = addr of 2nd bignum + clrl r5 #r5 = carry + movl $0xC0000000,r4 #r4 = clear constant. + movl sp,r10 #save start address of bignum on stack. + #note well that this is 4 above the actual + #low order word. +# +# first loop is to waltz through both bignums adding +# bigits, pushing them onto stack. +# +loop1: addl3 (r1),(r2),r0 #add bigits + addl2 r5,r0 #add carry + bicl3 r4,r0,-(sp) #save sum, no overflow possible + extv $30,$2,r0,r5 #sign extend two high order bits + #to be next carry. + movl 4(r1),r1 #get cdr + bleq out1 #negative indicates end of list. + movl 4(r2),r2 #get cdr of second bignum + bgtr loop1 #if neither list at end, do it again +# +# second loop propagates carries through higher order words. +# It assumes remaining list in r1. +# +loop2: addl3 (r1),r5,r0 #add bigits and carry + bicl3 r4,r0,-(sp) #save sum, no overflow possible + extv $30,$2,r0,r5 #sign extend two high order bits + #to be next carry. + movl 4(r1),r1 #get cdr +out2: bgtr loop2 #negative indicates end of list. +out2a: pushl r5 +# +# suppress unnecessary leading zeroes and -1's +# +iexport:movl sp,r11 #more set up for output routine +ckloop: +Bexport:tstl (r11) #look at leading bigit + bgtr copyit #if positive, can allocate storage etc. + blss negchk #if neg, still a chance we can get by + cmpl r11,r10 #check to see that + bgeq copyit #we don't pop everything off of stack + tstl (r11)+ #incr r11 + brb ckloop #examine next +negchk: + mcoml (r11),r3 #r3 is junk register + bneq copyit #short test for -1 + tstl 4(r11) #examine next bigit + beql copyit #if zero must must leave as is. + cmpl r11,r10 #check to see that + bgeq copyit #we don't pop everything off of stack + tstl (r11)+ #incr r11 + bisl2 r4,(r11) #set high order two bits + brb negchk #try to supress more leading -1's +# +# The following code is an error exit from the first loop +# and is out of place to avoid a jump around a jump. +# +out1: movl 4(r2),r1 #get next addr of list to continue. + brb out2 #if second list simult. exhausted, do + #right thing. +# +# loop3 is a faster version of loop2 when carries are no +# longer necessary. +# +loop3a: pushl (r1) #get datum +loop3: movl 4(r1),r1 #get cdr + bgtr loop3a #if not at end get next cell + brb out2a + +# +# create linked list representation of bignum +# +copyit: subl3 r11,r10,r2 #see if we can get away with allocating an int + bneq on1 #test for having popped everything + subl3 $4,r10,r11 #if so, fix up pointer to bottom + brb intout #and allocate int. +on1: cmpl r2,$4 #if = 4, then can do + beql intout + calls $0,_newsdot #get new cell for new bignum +backfr: movl r0,(r6)+ #push address of cell on + #arg stack to save from garbage collection. + #There is guaranteed to be slop for a least one + #push without checking. + movl r0,r8 #r8 = result of adbig +loop4: movl -(r10),(r0) #save bigit + movl r0,r9 #r9 = old cell, to link + cmpl r10,r11 #have we copy'ed all the bigits? + bleq done + calls $0,_newsdot #get new cell for new bignum + movl r0,4(r9) #link new cell to old + brb loop4 +done: + clrl 4(r9) #indicate end of list with 0 + movl -(r6),r0 #give resultant address. + ret +# +# export integer +# +intout: pushl (r11) + calls $1,_inewint + ret + .globl _mulbig +# +# bignum multiplication routine +# +# Initialization section +# +_mulbig:.word 0x0fc0 #save regs 6-11 + movl 4(ap),r1 #get address of first bignum + movl sp,r11 #save top of 1st bignum +mloop1: pushl (r1) #get bigit + movl 4(r1),r1 #get cdr + bgtr mloop1 #repeat if not done + movl sp,r10 #save bottom of 1st bignum, top of 2nd bignum + + movl 8(ap),r1 #get address of 2nd bignum +mloop2: pushl (r1) #get bigit + movl 4(r1),r1 #get cdr + bgtr mloop2 #repeat if not done + movl sp,r9 #save bottom of 2nd bignum + subl3 r9,r11,r6 #r6 contains sum of lengths of bignums + subl2 r6,sp + movl sp,r8 #save bottom of product bignum +# +# Actual multiplication +# +m1: movc5 $0,(r8),$0,r6,(r8)#zap out stack space + movl r9,r7 #r7 = &w[j +n] (+4 for a.d.) through calculation + subl3 $4,r10,r4 #r4 = &v[j] + +m3: movl r7,r5 #r7 = &w[j+n] + subl3 $4,r11,r3 #r3 = &u[i] + clrl r2 #clear carry. + +m4: addl2 -(r5),r2 #add w[i + j] to carry (no ofl poss) + emul (r3),(r4),r2,r0 #r0 = u[i] * v[j] + sext(carry) + extzv $0,$30,r0,(r5) #get new bigit + extv $30,$32,r0,r2 #get new carry + +m5: acbl r10,$-4,r3,m4 #r3 =- 4; if(r3 >= r10) goto m4; r10 = &[u1]; + movl r2,-(r5) #save w[j] = carry + +m6: subl2 $4,r7 #add just &w[j+n] (+4 for autodec) + acbl r9,$-4,r4,m3 #r4 =- 4; if(r4>=r9) goto m5; r9 = &v[1] + + movl r9,r10 #set up for output routine + movl $0xC0000000,r4 #r4 = clear constant. + movq 20(fp),r6 #restor _np and _lbot ! + brw iexport #do it! diff --git a/usr/src/cmd/lisp/bind.c b/usr/src/cmd/lisp/bind.c new file mode 100644 index 0000000000..e76a5bada0 --- /dev/null +++ b/usr/src/cmd/lisp/bind.c @@ -0,0 +1,174 @@ +#include "global.h" +#include +#define STRLIM 1024 + +static lispval mkptr(); +static struct exec header; +static struct nlist nlist; +static lispval *linkaddr; +static int *bindaddr; +static int fildes; +static lispval currtab; +static lispval curibase; +extern int fvirgin; +extern int initflag; +lispval +Lbind(){ + register struct argent *mlbot = lbot; + register lispval work; + char *sbrk(), *tfile, cbuf[512], *mytemp(), *gstab(); + + snpand(2); + + strcpy(cbuf, gstab()); + printf("getting symbol table from %s\n",cbuf); fflush(stdout); + if((fildes = open(cbuf,0))<0) + return(nil); + /* + * Read a.out header to find out where symbol table is. + */ + if(read(fildes,(char *)&header,sizeof(header)) <= 0) { + close(fildes); + return(nil); + } + + lseek(fildes, header.a_text+header.a_data+header.a_trsize + +header.a_drsize, 1); + + currtab = Vreadtable->clb; + Vreadtable->clb = strtab; + curibase = ibase->clb; + ibase->clb = inewint(10); + while((sizeof nlist)==read(fildes,&nlist,sizeof nlist)) { + if( nlist.n_name[0]!='.' || nlist.n_name[1]!='.') + continue; + + linkaddr = (lispval *)*(int *)nlist.n_value; + bindaddr = (int *)*(int *)(nlist.n_value+sizeof(int)); + do_linker(); + do_binder(); + } + ibase->clb = curibase; + Vreadtable->clb = currtab; + return(tatom); +} + +static do_linker() +{ + register int *i, *end, temp; + char array[STRLIM]; + extern lispval *bind_lists; + + /* first link this linkage table to the garbage + collector's list. We will try to be tricky + so that if the garbage collector is invoked + by mkptr we will not cause markdp() to go off + the deep end. + */ + *(linkaddr-1) = (lispval) bind_lists; + bind_lists = linkaddr; + i = (int *)linkaddr; + initflag = TRUE; + for(; *i!=-1; i++) { + temp = *i; + *i = -1; /* clobber to short circuit gc */ + findstr(temp, array); + *i = (int)mkptr(array); + } + initflag = FALSE; +} +static do_binder() +{ + char array[STRLIM]; + register lispval handy; + struct binder {lispval (*b_entry)(); + int b_atmlnk; + int b_type;} bindage, *pos; + + pos = (struct binder *)bindaddr; + initflag = TRUE; + for(bindage= *pos++; bindage.b_atmlnk!=-1; bindage = *pos++) { + if( bindage.b_type == 99) { + struct argent *olbot; + /* we must evaluate this form for effect */ + + findstr(bindage.b_atmlnk, array); + /* garbage collection appears to + cause problems at this point */ + /* if(ISNIL(copval(gcload,CNIL)) && loading->clb != tatom) + gc(CNIL); /* do a gc if gc will be off */ + handy = mkptr(array); + olbot = lbot; + lbot = np; + ibase->clb=curibase; + Vreadtable->clb = currtab; + (np++)->val = handy; + Leval(); + Vreadtable->clb = strtab; + curibase = ibase->clb; + ibase->clb = inewint(10); + np = lbot; + lbot = olbot; + } else { + handy = newfunct(); + handy->entry = bindage.b_entry; + handy->discipline = (bindage.b_type == 0 ? lambda : + bindage.b_type == 1 ? nlambda : + macro); + + findstr(bindage.b_atmlnk, array); + protect(handy); + mkptr(array)->fnbnd = handy; + } + } + initflag = FALSE; +} + +static +findstr(ptr,array) +int ptr; +char *array; +{ + int cnt = 0; + char *cp; + + cp = ptr + (char *)bindaddr; + while(cnt_flag&(_IOREAD|_IOWRT);p++) + if(p >= _iob + _NFILE) + error("Too many open files to do readlist",FALSE); + p->_flag = _IOREAD | _IOSTRG; + p->_base = p->_ptr = str; + p->_cnt = strlen(str) + 1; + + olbot = lbot; + lbot = np; + piport = p; + protect(P(p)); + work = Lread(); + piport = opiport; + lbot = olbot; + p->_cnt = 0; + p->_ptr = p->_base = 0; + p->_file = 0; + p->_flag=0; + return(work); +} + + + + diff --git a/usr/src/cmd/lisp/chars.h b/usr/src/cmd/lisp/chars.h new file mode 100644 index 0000000000..9a0cf24137 --- /dev/null +++ b/usr/src/cmd/lisp/chars.h @@ -0,0 +1,41 @@ +/* lexical table for input and output ***********************************/ +/* the format of the entries are: ab..xxxx */ +/* */ +/* where a is set iff the atom containing the symbol must be quoted */ +/* where b is set iff the character separates atoms normally */ +/* where xxxx is a number unique to the class of symbol */ + +#define VNUM 0000 +#define VMINUS 0001 +#define VSIGN 0001 +#define VCHAR 0002 +#define VSCA 0102 +#define VLPARA 0303 +#define VRPARA 0304 +#define VPERD 0305 +#define VLBRCK 0306 +#define VRBRCK 0307 +#define VEOF 0310 +#define VSQ 0311 +#define VDQ 0212 +#define VSD 0211 +#define VERR 0313 +#define VSEP 0314 +#define VSPL 0315 +#define VMAC 0316 +#define VESC 0217 +#define VQUO 0326 + + +#define QUTMASK 0200 +#define SEPMASK 0100 + +#define TSCA 1 +#define TLPARA 2 +#define TRPARA 3 +#define TPERD 4 +#define TEOF 5 +#define TSPL 6 +#define TMAC 7 +#define TSQ 8 +#define TLBKT 9 diff --git a/usr/src/cmd/lisp/chkrtab.h b/usr/src/cmd/lisp/chkrtab.h new file mode 100644 index 0000000000..720593b24d --- /dev/null +++ b/usr/src/cmd/lisp/chkrtab.h @@ -0,0 +1,4 @@ +#define chkrtab(p); \ + if(p!=lastrtab){ if(TYPE(p)!=ARRAY && TYPE(p->data)!=INT) rtaberr();\ + else { lastrtab = p; ctable = p->data; } } +extern lispval lastrtab; diff --git a/usr/src/cmd/lisp/crt0.s b/usr/src/cmd/lisp/crt0.s new file mode 100644 index 0000000000..4d59c0948f --- /dev/null +++ b/usr/src/cmd/lisp/crt0.s @@ -0,0 +1,115 @@ +# C runtime startoff + + .set exit,1 +.globl _exit +.globl start +.globl _main +.globl _environ +.globl _xports +.globl _gstart +.globl _proflush + + +# +# C language startup routine + +# +# special 512 byte area for nil (and possibly other atoms) +# and special block of smallnums. +# + .long 0 + .long 0 + .long 0 + .long -4 + .long 20 + .byte 'n,'i,'l,0 + .long 0 + .long 0 + .long -4 + .long 40 + .byte 'e,'o,'f,0 + .space 512-44 + .long -128,-127,-126,-125,-124,-123,-122,-121 + .long -120,-119,-118,-117,-116,-115,-114,-113 + .long -112,-111,-110,-109,-108,-107,-106,-105 + .long -104,-103,-102,-101,-100,-99,-98,-97 + .long -96,-95,-94,-93,-92,-91,-90,-89 + .long -88,-87,-86,-85,-84,-83,-82,-81 + .long -80,-79,-78,-77,-76,-75,-74,-73 + .long -72,-71,-70,-69,-68,-67,-66,-65 + .long -64,-63,-62,-61,-60,-59,-58,-57 + .long -56,-55,-54,-53,-52,-51,-50,-49 + .long -48,-47,-46,-45,-44,-43,-42,-41 + .long -40,-39,-38,-37,-36,-35,-34,-33 + .long -32,-31,-30,-29,-28,-27,-26,-25 + .long -24,-23,-22,-21,-20,-19,-18,-17 + .long -16,-15,-14,-13,-12,-11,-10,-9 + .long -8,-7,-6,-5,-4,-3,-2,-1 + .long 0,1,2,3,4,5,6,7 + .long 8,9,10,11,12,13,14,15 + .long 16,17,18,19,20,21,22,23 + .long 24,25,26,27,28,29,30,31 + .long 32,33,34,35,36,37,38,39 + .long 40,41,42,43,44,45,46,47 + .long 48,49,50,51,52,53,54,55 + .long 56,57,58,59,60,61,62,63 + .long 64,65,66,67,68,69,70,71 + .long 72,73,74,75,76,77,78,79 + .long 80,81,82,83,84,85,86,87 + .long 88,89,90,91,92,93,94,95 + .long 96,97,98,99,100,101,102,103 + .long 104,105,106,107,108,109,110,111 + .long 112,113,114,115,116,117,118,119 + .long 120,121,122,123,124,125,126,127 +_xports: + .long __iob+0 + .long __iob+16 + .long __iob+32 + .long __iob+48 + .long __iob+64 + .long __iob+80 + .long __iob+96 + .long __iob+112 + .long __iob+128 + .long __iob+144 + .long __iob+160 + .long __iob+176 + .long __iob+192 + .long __iob+208 + .long __iob+224 + .long __iob+240 + .long __iob+256 + .long __iob+272 + .long __iob+288 + .long __iob+304 + .space 512 - (20 * 4) + +start: + .word 0x0000 + subl2 $8,sp + movl 8(sp),(sp) # argc + movab 12(sp),r0 + movl r0,4(sp) # argv +L1: + tstl (r0)+ # null args term ? + bneq L1 + cmpl r0,*4(sp) # end of 'env' or 'argv' ? + blss L2 + tstl -(r0) # envp's are in list +L2: + movl r0,8(sp) # env + movl r0,_environ # indir is 0 if no env ; not 0 if env + calls $3,_main + pushl r0 + calls $1,_exit + chmk $exit +_gstart: + .word 0 + moval start,r0 + ret +_proflush: + .word 0 + ret +# + .data +_environ: .space 4 diff --git a/usr/src/cmd/lisp/data.c b/usr/src/cmd/lisp/data.c new file mode 100644 index 0000000000..5e30ca2ebe --- /dev/null +++ b/usr/src/cmd/lisp/data.c @@ -0,0 +1,78 @@ +#include + +#include "global.h" +#include "gtabs.h" + +lispval lispsys[SIGNIF]; /* lisp data used by system */ + +lispval gftab[GFTABLEN]; /* global function table for interpreter */ + +lispval gctab[GCTABLEN] = /* global constant table for interpreter */ + {nil,0,SMALL(-1),SMALL(0),SMALL(1),SMALL(2),SMALL(3),SMALL(4)}; + + +/* Port definitions *****************************************************/ +FILE *piport, /* standard input port */ + *poport, /* standard output port */ + *errport, /* port for error messages */ + *rdrport, /* temporary port for readr */ + *proport; /* port for protocal */ +int lineleng = 80; /* line length desired */ +int rlevel; /* used to indicate depth of recursion + in reader. No longer really necessary */ +char keybin = FALSE; /* logical flag: using keyboard */ +char protflag = FALSE; /* logical flag: want protocall */ +char rbktf; /* logical flag: ] mode */ + + +/* name stack ***********************************************************/ +struct argent *namptr, /* temporary pointer */ + *nplim; /* don't have this = np */ +struct nament *bnp, /* top of bind stack */ + *orgbnp, /* absolute bottom of ""*/ + *bnplim; /* absolute top of "" */ + + +/* the typeing table ****************************************************/ +#ifndef ROWAN +char typetab[TTSIZE] = {UNBO,ATOM,INT,INT,PORT}; +#else +char typetab[TTSIZE] = {UNBO,ATOM,INT,INT,INT,PORT}; +#endif + +/* hashing things *******************************************************/ +struct atom *hasht[HASHTOP]; +int hash; /* set by ratom */ +int atmlen; /* length of atom including final null */ + + +/* big string buffer for whomever needs it ******************************/ +char strbuf[STRBLEN]; +char *endstrb = strbuf + 255; + +/* set by sstatus commands */ +int uctolc = 0; /* when set, uc chars in atoms go to lc */ +int dmpmode = 413; /* default mode for dumplisp + (note this is decimal not octal) */ + +/* break and error declarations *****************************************/ +int depth = 0; /* depth of nested breaks */ +lispval contval; /* the value being returned up */ +struct argent *orgnp; /* used by top level to reset to start */ +int retval; /* used by each error/prog call */ + + +/* other stuff **********************************************************/ +lispval ftemp,vtemp,argptr,ttemp; /* temporaries: use briefly */ +int itemp; +lispval sigacts[16]; /* for catching interrupts */ +int sigstruck,sigdelay; /* for catching interrupts */ +lispval stattab[16]; /* miscelleneous options */ + +/* interpreter globals */ + +int lctrace; +int fvirgin; +int GCtime; +int errp; /* where are lying through our teeth. This + is a pointer to inside a function. */ diff --git a/usr/src/cmd/lisp/dfuncs.h b/usr/src/cmd/lisp/dfuncs.h new file mode 100644 index 0000000000..4a4cefddfa --- /dev/null +++ b/usr/src/cmd/lisp/dfuncs.h @@ -0,0 +1,49 @@ +FILE * okport(); +char *brk(); +char *getsp(); +char *inewstr(); +char *mkmsg(); +char *newstr(); +char *rstore(); +char *sbrk(); +char *xsbrk(); +char *ysbrk(); +int csizeof(); +int finterp(); +lispval Iget(); +lispval Imkrtab(); +lispval Iputprop(); +lispval Lfuncal(); +lispval Lnegp(); +lispval Lsub(); +lispval alloc(); +lispval copval(); +lispval csegment(); +lispval error(); +lispval errorh(); +lispval eval(); +lispval gc(); +lispval getatom(); +lispval inewint(); +lispval inewval(); +lispval linterp(); +lispval matom(); +lispval mfun(); +lispval mstr(); +lispval newarray(); +lispval newdot(); +lispval newdoub(); +lispval newfunct(); +lispval newint(); +lispval newsdot(); +lispval newval(); +lispval popnames(); +lispval protect(); +lispval r(); +lispval ratomr(); +lispval readr(); +lispval readrx(); +lispval readry(); +lispval typred(); +lispval unprot(); +struct atom * newatom(); diff --git a/usr/src/cmd/lisp/divbig.c b/usr/src/cmd/lisp/divbig.c new file mode 100644 index 0000000000..c598f2d56d --- /dev/null +++ b/usr/src/cmd/lisp/divbig.c @@ -0,0 +1,265 @@ +#include "global.h" + +#define b 0x40000000 +#define toint(p) ((int) (p)) + +divbig(dividend, divisor, quotient, remainder) +lispval dividend, divisor, *quotient, *remainder; +{ + register *ujp, *vip; + int *sp(), *alloca(), d, negflag = 0, m, n, carry, rem, qhat, j; + int borrow, negrem = 0; + int *utop = sp(), *ubot, *vbot, *qbot; + register lispval work; lispval export(); + + /* copy dividend */ + for(work = dividend; work; work = work ->CDR) + stack(work->I); + ubot = sp(); + if(*ubot < 0) { /* knuth's division alg works only for pos + bignums */ + negflag ^= 1; + negrem = 1; + dsmult(utop-1,ubot,-1); + } + stack(0); + ubot = sp(); + + + /*copy divisor */ + for(work = divisor; work; work = work->CDR) + stack(work->I); + + vbot = sp(); + stack(0); + if(*vbot < 0) { + negflag ^= 1; + dsmult(ubot-1,vbot,-1); + } + + /* check validity of data */ + n = ubot - vbot; + m = utop - ubot - n - 1; + if (n == 1) { + /* do destructive division by a single. */ + rem = dsdiv(utop-1,ubot,*vbot); + if(negrem) + rem = -rem; + if(negflag) + dsmult(utop-1,ubot,-1); + if(remainder) + *remainder = inewint(rem); + if(quotient) + *quotient = export(utop,ubot); + return; + } + if (m < 0) { + if (remainder) + *remainder = dividend; + if(quotient) + *quotient = inewint(0); + return; + } + qbot = alloca(toint(utop) + toint(vbot) - 2 * toint(ubot)); +d1: + d = b /(*vbot +1); + dsmult(utop-1,ubot,d); + dsmult(ubot-1,vbot,d); + +d2: for(j=0,ujp=ubot; j <= m; j++,ujp++) { + + d3: + qhat = calqhat(ujp,vbot); + d4: + if((borrow = mlsb(ujp + n, ujp, ubot, -qhat)) < 0) { + adback(ujp + n, ujp, ubot); + qhat--; + } + qbot[j] = qhat; + } +d8: if(remainder) { + dsdiv(utop, utop - n, d); + if(negrem) dsmult(utop-1,utop-n,-1); + *remainder = export(utop,utop-n); + } + if(quotient) { + if(negflag) + dsmult(qbot+m,qbot,-1); + *quotient = export(qbot + m + 1, qbot); + } +} +/*static*/ calqhat(ujp,v1p) +register int *ujp, *v1p; +{ +asm(" movl $0x3fffffff,r0"); +asm(" cmpl (r10),(r11)"); +asm(" beql on1"); +asm(" emul (r11),$0x40000000,4(r11),r1"); +asm(" ediv (r10),r1,r0,r5"); +asm("on1:"); +asm(" emul r0,4(r10),$0,r1"); +asm(" emul r5,$0x40000000,8(r11),r3"); +asm(" subl2 r3,r1"); +asm(" sbwc r4,r2"); +asm(" bleq out1"); +asm(" decl r0"); +asm("out1:"); +} +/*static*/ mlsb(utop,ubot,vtop,nqhat) +register int *utop, *ubot, *vtop; +register int nqhat; +{ +asm(" clrl r0"); +asm("loop2: addl2 (r11),r0"); +asm(" emul r8,-(r9),r0,r2"); +asm(" extzv $0,$30,r2,(r11)"); +asm(" extv $30,$32,r2,r0"); +asm(" acbl r10,$-4,r11,loop2"); +} +/*static*/ adback(utop,ubot,vtop) +register int *utop, *ubot, *vtop; +{ +asm(" clrl r0"); +asm("loop3: addl2 -(r9),r0"); +asm(" addl2 (r11),r0"); +asm(" extzv $0,$30,r0,(r11)"); +asm(" extv $30,$2,r0,r0"); +asm(" acbl r10,$-4,r11,loop3"); +} +/*static*/ dsdiv(top,bot,div) +register int* bot; +{ +asm(" clrl r0"); +asm("loop4: emul r0,$0x40000000,(r11),r1"); +asm(" ediv 12(ap),r1,(r11),r0"); +asm(" acbl 4(ap),$4,r11,loop4"); +} +/*static*/ dsmult(top,bot,mult) +register int* top; +{ +asm(" clrl r0"); +asm("loop5: emul 12(ap),(r11),r0,r1"); +asm(" extzv $0,$30,r1,(r11)"); +asm(" extv $30,$32,r1,r0"); +asm(" acbl 8(ap),$-4,r11,loop5"); +asm(" movl r1,4(r11)"); +} +/*static*/ lispval export(top,bot) +register lispval bot; +{ + register r10, r9, r8, r7, r6; +asm(" movl 4(ap),r10"); +asm(" movl $0xC0000000,r4"); +asm(" jmp Bexport"); +} + +#define MAXINT 0x8000000L + +Ihau(fix) +register int fix; +{ + register count; + if(fix==MAXINT) + return(32); + if(fix < 0) + fix = -fix; + for(count = 0; fix; count++) + fix /= 2; + return(count); +} +lispval +Lhau() +{ + register count; + register lispval handy; + register dum1,dum2; + register struct argent *lbot, *np; + lispval Labsval(); + + handy = lbot->val; +top: + switch(TYPE(handy)) { + case INT: + count = Ihau(handy->i); + break; + case SDOT: + lbot->val = Labsval(); + for(count = 0; handy->CDR!=((lispval) 0); handy = handy->CDR) + count += 30; + count += Ihau(handy->I); + break; + default: + handy = errorh(Vermisc,"Haulong: bad argument",nil, + TRUE,997,handy); + goto top; + } + return(inewint(count)); +} +lispval +Lhaipar() +{ + int *sp(); + register lispval work; + register n; + register int *top = sp() - 1; + register int *bot; + register struct argent *lbot, *np; + int mylen; + + /*chkarg(2);*/ + work = lbot->val; + /* copy data onto stack */ +on1: + switch(TYPE(work)) { + case INT: + stack(work->i); + break; + case SDOT: + for(; work!=((lispval) 0); work = work->CDR) + stack(work->I); + break; + default: + work = errorh(Vermisc,"Haipart: bad first argument",nil, + TRUE,996,work); + goto on1; + } + bot = sp(); + if(*bot < 0) { + stack(0); + dsmult(top,bot,-1); + bot--; + } + for(; *bot==0 && bot < top; bot++); + /* recalculate haulong internally */ + mylen = (top - bot) * 30 + Ihau(*bot); + /* get second argument */ + work = lbot[1].val; + while(TYPE(work)!=INT) + work = errorh(Vermisc,"Haipart: 2nd arg not int",nil, + TRUE,995,work); + n = work->i; + if(n >= mylen || -n >= mylen) + goto done; + if(n >= 0) { + /* Here we want n most significant bits + so chop off mylen - n bits */ + stack(0); + n = mylen - n; + for(n; n >= 30; n -= 30) + top--; + if(top < bot) + error("Internal error in haipart #1",FALSE); + dsdiv(top,bot,1<car times mul + carry +# ediv $0x40000000,r0,r10,(r11)#cell->car gets prod % 2**30 +# #carry gets quotient + extzv $0,$30,r0,(r11) + extv $30,$32,r0,r10 + movl r11,r9 #save last cell for fixup at end. + movl 4(r11),r11 #move to next cell + bneq loop #done indicated by 0 for next sdot + tstl r10 #if carry zero no need to allocate + beql done #new bigit + mcoml r10,r3 #test to see if neg 1. + bneq alloc #if not must allocate new cell. + tstl (r9) #make sure product isn't -2**30 + beql alloc + movl r0,(r9) #save old lower half of product. + brb done +alloc: calls $0,_newsdot #otherwise allocate new bigit + movl r10,(r0) #store carry + movl r0,4(r9) #save new link cell +done: movl 4(ap),r0 + ret diff --git a/usr/src/cmd/lisp/dodiv.s b/usr/src/cmd/lisp/dodiv.s new file mode 100644 index 0000000000..dc22a21925 --- /dev/null +++ b/usr/src/cmd/lisp/dodiv.s @@ -0,0 +1,23 @@ + .globl _dodiv +# +# routine to destructively divide array representation of a bignum by +# 1000000000 +# +# invocation: +# remainder = dodiv(top,bottom) +# int *top, *bottom; +# where *bottom is the address of the biggning of the array, *top is +# the top of the array. +# +# register assignments: +# r0 = carry +# r1 & r2 = 64bit temporary +# r3 = pointer +# +_dodiv: .word 0 + clrl r0 #no carry to begin. + movl 8(ap),r3 #get pointer to array. +loop: emul $0x40000000,r0,(r3),r1 + ediv $1000000000,r1,(r3),r0 + acbl 4(ap),$4,r3,loop + ret diff --git a/usr/src/cmd/lisp/dsneg.s b/usr/src/cmd/lisp/dsneg.s new file mode 100644 index 0000000000..9eead2bc77 --- /dev/null +++ b/usr/src/cmd/lisp/dsneg.s @@ -0,0 +1,19 @@ + .globl _dsneg +# +# dsneg(top, bot); +# int *top, *bot; +# +# routine to destructively negate a bignum stored in array format +# lower order stuff at higher addresses. It is assume that the +# result will be positive. +# +_dsneg: .word 0 + movl 4(ap),r1 #load up address. + clrl r2 #set carry +loop: mnegl (r1),r0 #negate and take carry into account. + addl2 r2,r0 + extzv $0,$30,r0,(r1) + extv $30,$2,r0,r2 + acbl 8(ap),$-4,r1,loop + #decrease r1, and branch back if appropriate. + ret diff --git a/usr/src/cmd/lisp/eval2.c b/usr/src/cmd/lisp/eval2.c new file mode 100644 index 0000000000..b0cc6e295e --- /dev/null +++ b/usr/src/cmd/lisp/eval2.c @@ -0,0 +1,78 @@ +#include "global.h" +lispval +Iarray(fun,args) +register lispval fun,args; +{ + register lispval reg, temp; + register struct argent *lbot, *np; + snpand(2); + + lbot = np; + if(np + 3 > nplim) + namerr(); + np++->val = fun->accfun; + np++->val = args; + np++->val = fun; + return(vtemp = Lfuncal()); + +} +#define FINTF 1 +#define FDOUBF 2 +#define FORTSUB 0 + +lispval +Ifcall(a) +register lispval a; +{ + int *alloca(); + register int *arglist; + register int index; + register struct argent *mynp; + register lispval ltemp; + register struct argent *lbot; + register struct argent *np; + int nargs = np - lbot; + + arglist = alloca((nargs + 1) * sizeof(int)); + mynp = lbot; + *arglist = nargs; + for(index = 1; index <= nargs; index++) { + switch(TYPE(mynp->val)) { + case INT: + arglist[index] = sp(); + stack(0); + *(int *) arglist[index] = mynp->val->i; + break; + case DOUB: + stack(0); + arglist[index] = sp(); + stack(0); + *(double *) arglist[index] = mynp->val->r; + break; + case ARRAY: + arglist[index] = (int) mynp->val->data; + } + mynp++; + } + switch(a->discipline->i) { + case FINTF: + ltemp = inewint(callg(a->entry,arglist)); + break; + + case FDOUBF: + ltemp = newdoub(); + ltemp->r = (* ((double (*)()) callg))(a->entry,arglist); + break; + + default: + case FORTSUB: + callg(a->entry,arglist); + ltemp = tatom; + } +} +callg(funct,arglist) +lispval (*funct)(); +int *arglist; +{ + asm(" callg *8(ap),*4(ap)"); +} diff --git a/usr/src/cmd/lisp/fex2.c b/usr/src/cmd/lisp/fex2.c new file mode 100644 index 0000000000..b4d0acd9fe --- /dev/null +++ b/usr/src/cmd/lisp/fex2.c @@ -0,0 +1,257 @@ +#include "global.h" +#define NDOVARS 15 +#include +/* + * Ndo maclisp do function. + */ +lispval +Ndo() +{ + register lispval current, where, handy; + register struct nament *mybnp; + register struct argent *lbot, *np; + lispval atom, temp; + lispval body, endtest, endform, varstuf, renewals[NDOVARS] ; + struct argent *start, *last, *getem, *savedlbot; + struct nament *savedbnp, *lastbnd; + int count, index, saveme[SAVSIZE], virgin = 1; + int myerrp; extern int errp; + + savedlbot = lbot; + myerrp = errp; + savedbnp = bnp; + getexit(saveme); /* common nonlocal return */ + if(retval = setexit()) { + errp = myerrp; + if(retval == BRRETN) { + resexit(saveme); + lbot = savedlbot; + popnames(savedbnp); + return((lispval) contval); + } else { + resexit(saveme); + lbot = savedlbot; + reset(retval); + } + } + current = lbot->val; + varstuf = current->car; + switch( TYPE(varstuf) ) { + + case ATOM: /* This is old style maclisp do; + atom is var, cadr(current) = init; + caddr(current) = repeat etc. */ + atom = varstuf; + if(varstuf==nil) goto newstyle; + bnp->atm = atom; /* save current binding of atom */ + bnp++->val = atom->clb; + if(bnp > bnplim) + binderr(); + current = current->cdr; + atom->clb = eval(current->car); + /* Init var. */ + *renewals = (current = current->cdr)->car; + /* get repeat form */ + endtest = (current = current->cdr)->car; + body = current->cdr; + + while(TRUE) { + if(eval(endtest)!=nil) { + resexit(saveme); + popnames(savedbnp); + return(nil); + } + doprog(body); + atom->clb = eval(*renewals); + } + + + newstyle: + case DTPR: /* New style maclisp do; atom is + list of things of the form + (var init repeat) */ + count = 0; + start = np; + for(where = varstuf; where != nil; where = where->cdr) { + /* do inits and count do vars. */ + /* requires "simultaneous" eval + of all inits */ + handy = where->car->cdr; + temp = nil; + if(handy !=nil) + temp = eval(handy->car); + protect(temp); + count++; + } + if(count > NDOVARS) + error("More than 15 do vars",FALSE); + bnp += count; + if(bnp >= bnplim) { + bnp = savedbnp; + namerr(); + } + last = np; + where = varstuf; + mybnp = savedbnp; + getem = start; + for(index = 0; index < count; index++) { + + handy = where->car; + /* get var name from group */ + atom = handy->car; + mybnp->atm = atom; + mybnp->val = atom->clb; + /* Swap current binding of atom + for init val pushed on stack */ + + atom->clb = getem++->val; + /* As long as we are down here in the + list, save repeat form */ + handy = handy->cdr->cdr; + if(handy==nil) + handy = CNIL; /* be sure not to rebind later */ + else + handy = handy->car; + renewals[index] = handy; + + /* more loop "increments" */ + where = where->cdr; + mybnp++; + } + /* Examine End test and End form */ + current = current->cdr; + handy = current->car; + body = current->cdr; + if (handy == nil) { + doprog(body); + popnames(savedbnp); + resexit(saveme); + return(nil); + } + endtest = handy->car; + endform = handy->cdr; + /* The following is the loop: */ + loop: + if(eval(endtest)!=nil) { + for(handy = nil; endform!=nil; endform = endform->cdr){ + handy = eval(endform->car); + } + resexit(saveme); + popnames(savedbnp); + return(handy); + } + doprog(body); + /* Simultaneously eval repeat forms */ + for(index = 0; index < count; index++) { + + temp = renewals[index]; + if (temp == nil || temp == CNIL) + protect(temp); + else + protect(eval(temp)); + } + getem = (np = last); + /* now simult. rebind all the atoms */ + mybnp = savedbnp; + for(index = 0; index < count; index++, getem++) { + if( (getem)->val != CNIL ) /* if this atom has a repeat form */ + mybnp->atm->clb = (getem)->val; /* rebind */ + mybnp++; + } + goto loop; + } +} +doprog(body) +register lispval body; + { + int saveme[SAVSIZE]; + register lispval where, temp; + /*register struct nament *savednp = np, *savedlbot = lbot;*/ + extern int errp; int myerrp = errp; + struct nament *savedbnp = bnp; + snpand(2); + + where = body; + getexit(saveme); + if(retval = setexit()) { + errp = myerrp; + switch (retval) { + + default: resexit(saveme); + reset(retval); + + case BRGOTO: + for(where = body; + where->car != (lispval) contval; where = where->cdr) { + + if(where==nil) { + resexit(saveme); + reset(retval); + } + /* np is automatically restored here by + virtue of being a register */ + } + popnames(savedbnp); + } + } + while (TYPE(where) == DTPR) { + temp = where->car; + if((TYPE(temp))!=ATOM) eval(temp); + where = where->cdr; + } + resexit(saveme); +} +lispval +Nprogv() +{ + register lispval argptr, where, handy, atoms; + register struct argent *lbot, *np; + struct argent *namptr, *start; + struct nament *oldbnp = bnp; + + where = lbot->val; + protect(eval(where->car)); /* list of vars */ + atoms = lbot[1].val; + protect(eval((where = where->cdr)->car)); + /* list of vals */ + handy = lbot[2].val; + start = np; + for(;handy!=nil; handy = handy->cdr) { + (np++)->val = eval(handy->car); + TNP; + } + rebind(atoms,start); + handy = nil; + for(where = where->cdr; where != nil; where = where->cdr) + handy = eval(where->car); + popnames(oldbnp); + return(handy); +} + +lispval +Nprogn() +{ + register lispval result, where; + snpand(2); + + result = nil; + for(where = lbot->val; where != nil; where = where->cdr) + result = eval(where->car); + return(result); + + +} +lispval +Nprog2() +{ + register lispval result, where; + snpand(2); + + where = lbot->val; + eval(where->car); + result = eval((where = where->cdr)->car); + protect(result); + for(where = where->cdr; where != nil; where = where->cdr) + eval(where->car); + return(result); +} diff --git a/usr/src/cmd/lisp/fex4.c b/usr/src/cmd/lisp/fex4.c new file mode 100644 index 0000000000..da0b941119 --- /dev/null +++ b/usr/src/cmd/lisp/fex4.c @@ -0,0 +1,317 @@ +#include "global.h" +#include "lfuncs.h" +#include "chkrtab.h" +#include + +lispval +Nsyscall() { + register lispval aptr, temp; + register int acount = 0; + int args[50]; + snpand(3); + + aptr = lbot->val; + temp = eval(aptr->car); + if (TYPE(temp) != INT) + return(error("syscall", FALSE)); + args[acount++] = temp->i; + aptr = aptr->cdr; + while( aptr != nil && acount < 49) { + temp = eval(aptr->car); + switch(TYPE(temp)) { + + case ATOM: + args[acount++] = (int)temp->a.pname; + break; + + case INT: + args[acount++] = (int)temp->i; + break; + + default: + return(error("syscall", FALSE)); + } + aptr = aptr->cdr; + } + + if (acount==0) chkarg(2); /* produce arg count message */ + temp = newint(); + temp->i = vsyscall(args); + return(temp); +} + +/* eval-when: this has the form (eval-when ...) + where the list may contain any combination of `eval', `load', `compile'. + The interpreter (us) looks for the atom `eval', if it is present + we treat the rest of the forms as a progn. +*/ + +lispval +Nevwhen() +{ + register lispval handy; + snpand(1); + + for(handy=(lbot->val)->car ; handy != nil ; handy = handy->cdr) + if (handy->car == (lispval) Veval) { lbot=np ; + protect(((lbot-1)->val)->cdr); + return(Nprogn()); } ; + + + return(nil); /* eval not seen */ +} + + +/* Status functions. + * These operate on the statuslist stlist which has the form: + * ( status_elem_1 status_elem_2 status_elem_3 ...) + * where each status element has the form: + * ( name readcode setcode . readvalue) + * where + * name - name of the status feature (the first arg to the status + * function). + * readcode - fixnum which tells status how to read the value of + * this status name. The codes are #defined. + * setcode - fixnum which tells sstatus how to set the value of + * this status name + * readvalue - the value of the status feature is usually stored + * here. + * + * Readcodes: + * + * ST_READ - if no second arg, return readvalue. + * if the second arg is given, we return t if it is eq to + * the readvalue. + * ST_FEATR - used in (status feature xxx) where we test for xxx being + * in the status features list + * ST_SYNT - used in (status syntax c) where we return c's syntax code + * ST_INTB - read stattab entry + * ST_NFETR - used in (status nofeature xxx) where we test for xxx not + * being in the status features list + * ST_DMPR - read the dumpmode + * + * Setcodes: + * ST_NO - if not allowed to set this status through sstatus. + * ST_SET - if the second arg is made the readvalue. + * ST_FEATW - for (sstatus feature xxx), we add xxx to the + * (status features) list. + * ST_TOLC - if non nil, map upper case chars in atoms to lc. + * ST_CORE - if non nil, have bus errors and segmentation violations + * dump core, if nil have them produce a bad-mem err msg + * ST_INTB - set stattab table entry + * ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx + * from the status feature list. + * ST_DMPW - set the dumpmode + */ + + +lispval +Nstatus() +{ + register lispval handy,curitm,valarg; + int indx; + int typ; + extern char *ctable; + extern int dmpmode; + lispval Istsrch(); + + if(lbot->val == nil) return(nil); + handy = lbot->val; /* arg list */ + + while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE); + + curitm = Istsrch(handy->car); /* look for feature */ + + if( curitm == nil ) return(nil); /* non existant */ + + if( handy->cdr == nil ) valarg = (lispval) CNIL; + else valarg = handy->cdr->car; + + /* now do the processing with curitm pointing to the requested + item in the status list + */ + + switch( typ = curitm->cdr->car->i ) { /* look at readcode */ + + + case ST_READ: + curitm = Istsrch(handy->car); /* look for name */ + if(curitm == nil) return(nil); + if( valarg != (lispval) CNIL) + error("status: Second arg not allowed.",FALSE); + else return(curitm->cdr->cdr->cdr); + + case ST_NFETR: /* look for feature present */ + case ST_FEATR: /* look for feature */ + curitm = Istsrch(matom("features")); + if( valarg == (lispval) CNIL) + error("status: need second arg",FALSE); + + for( handy = curitm->cdr->cdr->cdr; + handy != nil; + handy = handy->cdr) + if(handy->car == valarg) + return(typ == ST_FEATR ? tatom : nil); + + return(typ == ST_FEATR ? nil : tatom); + + case ST_SYNT: /* want characcter syntax */ + handy = Vreadtable->clb; + chkrtab(handy); + if( valarg == (lispval) CNIL) + error("status: need second arg",FALSE); + + while (TYPE(valarg) != ATOM) + valarg = error("status: second arg must be atom",TRUE); + + indx = valarg->pname[0]; /* get first char */ + + if(valarg->pname[1] != '\0') + error("status: only one character atom allowed",FALSE); + + (handy = newint())->i = ctable[indx] & 0377; + return(handy); + + case ST_RINTB: + return(stattab[curitm->cdr->cdr->cdr->i]); + + case ST_DMPR: + return(inewint(dmpmode)); + + } +} +lispval +Nsstatus() +{ + register lispval handy; + lispval Isstatus(); + + handy = lbot->val; + + while( TYPE(handy) != DTPR || TYPE(handy->cdr) != DTPR) + handy = error("sstatus: Bad args",TRUE); + + return(Isstatus(handy->car,handy->cdr->car)); +} + +/* Isstatus - internal routine to do a set status. */ +lispval +Isstatus(curnam,curval) +lispval curnam,curval; +{ + register lispval curitm,head; + lispval Istsrch(),Iaddstat(); + int badmemr(); + extern int uctolc, dmpmode; + + curitm = Istsrch(curnam); + /* if doesnt exist, make one up */ + + if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil); + + switch (curitm->cdr->cdr->car->i) { + + case ST_NO: error("sstatus: cannot set this status",FALSE); + + case ST_SET: goto setit; + + case ST_FEATW: curitm = Istsrch(matom("features")); + (curnam = newdot())->car = curval; + curnam->cdr = curitm->cdr->cdr->cdr; /* old val */ + curitm->cdr->cdr->cdr = curnam; + return(curval); + + case ST_NFETW: /* remove from features list */ + curitm = Istsrch(matom("features"))->cdr->cdr; + for(head = curitm->cdr; head != nil; head = head->cdr) + { + if(head->car == curval) curitm->cdr = head->cdr; + else curitm = head; + } + return(nil); + + + case ST_TOLC: if(curval == nil) uctolc = FALSE; + else uctolc = TRUE; + goto setit; + + case ST_CORE: if(curval == nil) + { + signal(SIGBUS,badmemr); /* catch bus errors */ + signal(SIGSEGV,badmemr); /* and segmentation viols */ + } + else { + signal(SIGBUS,SIG_DFL); /* let them core dump */ + signal(SIGSEGV,SIG_DFL); + } + goto setit; + + case ST_INTB: + stattab[curitm->cdr->cdr->cdr->i] = curval; + return(curval); + + case ST_DMPW: + if(TYPE(curval) != INT || + (curval->i != 413 && + curval->i != 410)) errorh(Vermisc,"sstatus: bad dump mode:", + nil,FALSE,0,curval); + dmpmode= curval->i; + return(curval); + } + + setit: /* store value in status list */ + curitm->cdr->cdr->cdr = curval; + return(curval); + + +} + +/* Istsrch - utility routine to search the status list for the + name given as an argument. If such an entry is not found, + we return nil + */ + +lispval Istsrch(nam) +lispval nam; +{ + register lispval handy; + + for(handy = stlist ; handy != nil ; handy = handy->cdr) + if(handy->car->car == nam) return(handy->car); + + return(nil); +} + +/* Iaddstat - add a status entry to the status list */ +/* return new entry in status list */ + +lispval +Iaddstat(name,readcode,setcode,valu) +lispval name,valu; +int readcode,setcode; +{ + register lispval handy,handy2; + snpand(2); + + + protect(handy=newdot()); /* build status list here */ + + (handy2 = newdot())->car = name; + + handy->car = handy2; + + ((handy2->cdr = newdot())->car = newint())->i = readcode; + + handy2 = handy2->cdr; + + ((handy2->cdr = newdot())->car = newint())->i = setcode; + + handy2->cdr->cdr = valu; + + /* link this one in */ + + handy->cdr = stlist; + stlist = handy; + + return(handy->car); /* return new item in stlist */ +} diff --git a/usr/src/cmd/lisp/fexr.c b/usr/src/cmd/lisp/fexr.c new file mode 100644 index 0000000000..6ab802c97f --- /dev/null +++ b/usr/src/cmd/lisp/fexr.c @@ -0,0 +1,96 @@ +#include "global.h" + +/* Ngcafter *************************************************************/ +/* */ +/* Default garbage collector routine which does nothing. */ + +lispval +Ngcafter() + { + return(nil); + } + +/* Nopval *************************************************************/ +/* */ +/* Routine which allows system registers and options to be examined */ +/* and modified. Calls copval, the routine which is called by c code */ +/* to do the same thing from inside the system. */ + +lispval +Nopval() + { + lispval quant; + snpand(0); + + if( TYPE(lbot->val) != DTPR ) + return(error("BAD CALL TO OPVAL",TRUE)); + quant = eval(lbot->val->car); /* evaluate name of sys variable */ + while( TYPE(quant) != ATOM ) + quant = error("FIRST ARG TO OPVAL MUST BE AN ATOM",TRUE); + + if( (vtemp=lbot->val->cdr) != nil && TYPE(lbot->val->cdr) != DTPR ) + return(error("BAD ARG LIST FOR OPVAL",TRUE)); + return(copval( + quant, + vtemp==nil ? (lispval)CNIL : eval(vtemp->car) + )); + } +/* copval *************************************************************/ +/* This routine keeps track of system quantities, and is called from */ +/* C code. If the second argument is CNIL, no change is made in the */ +/* quantity. */ +/* Since this routine may call newdot() if the second argument is not */ +/* CNIL, the arguments should be protected somehow in that case. */ + +lispval +copval(option,value) + lispval option, value; + { + struct dtpr fake; + lispval rval; + snpand(0); + + + if( option->plist == nil && value != (lispval) CNIL) + { + protect(option); protect(value); + option->plist = newdot(); + option->plist->car = sysa; + option->plist->cdr = newdot(); + option->plist->cdr->car = value; + unprot(); unprot(); + return(nil); + } + + + if( option->plist == nil ) return(nil); + + fake.cdr = option->plist; + option = (lispval) (&fake); + + while( option->cdr != nil ) /* can't be nil first time through */ + { + option = option->cdr; + if( option->car == sysa ) + { + rval = option->cdr->car; + if( value != (lispval)CNIL ) + option->cdr->car = value; + return(rval); + } + option = option->cdr; + } + + if( value != (lispval)CNIL ) + { + protect(option); protect(value); + option->cdr = newdot(); + option->cdr->car = sysa; + option->cdr->cdr = newdot(); + option->cdr->cdr->car = value; + unprot(); unprot(); + } + + + return(nil); + } diff --git a/usr/src/cmd/lisp/ffasl.c b/usr/src/cmd/lisp/ffasl.c new file mode 100644 index 0000000000..45a5c2985d --- /dev/null +++ b/usr/src/cmd/lisp/ffasl.c @@ -0,0 +1,109 @@ +#include "global.h" +#include +#define round(x,s) ((((x)-1) & ~((s)-1)) + (s)) + +char *stabf = 0; +int fvirgin = 1; + +lispval +Lffasl(){ + register struct argent *mlbot = lbot; + register lispval work; + int fildes, totsize, readsize; + lispval csegment(); + char *sbrk(), *currend, *tfile, cbuf[512], *mytemp(), *gstab(); + struct exec header; + snpand(2); + + if(np - mlbot != 3 || TYPE(mlbot[1].val)!=ATOM) + mlbot[1].val = error("Incorrect .o file specification",TRUE); + if(np - mlbot != 3 || TYPE(mlbot[2].val)!=ATOM) + mlbot[2].val = error("Incorrect entry specification for fasl" + ,TRUE); + if(np - mlbot != 3 || TYPE(mlbot[3].val)!=ATOM || mlbot[3].val==nil) + mlbot[3].val = error( "Bad associated atom name for fasl",TRUE); + + /* + * Invoke loader. + */ + currend = sbrk(0); + tfile = mytemp(); + sprintf(cbuf, + "nld -A %s -T %x -N %s -e %s -o %s", + gstab(), + currend, + mlbot[1].val->pname, + mlbot[2].val->pname, + tfile); + printf(cbuf); fflush(stdout); + if(system(cbuf)!=0) { + unlink(tfile); + return(nil); + } + if(fvirgin) + fvirgin = 0; + else + unlink(stabf); + stabf = tfile; + if((fildes = open(tfile,0))<0) + return(nil); + /* + * Read a.out header to find out how much room to + * allocate and attempt to do so. + */ + if(read(fildes,(char *)&header,sizeof(header)) <= 0) { + close(fildes); + return(nil); + } + readsize = header.a_text + header.a_data; + totsize = readsize + header.a_bss; + totsize = round(totsize,512); + /* + * Fix up system indicators, typing info, etc. + */ + currend = (char *)csegment(int_name,totsize/4); + + if(readsize!=read(fildes,currend,readsize)) + return(nil); + work = newfunct(); + work->entry = (lispval (*)())header.a_entry; + work->discipline = lambda; + return(mlbot[3].val->fnbnd = work); +} +#include "types.h" +#include +static char myname[100]; +char * +gstab() +{ + register char *cp, *cp2; char *getenv(); + struct stat stbuf; + extern char **Xargv; + + if(stabf==0) { + cp = getenv("PATH"); + if(cp==0) + cp=":/usr/ucb:/bin:/usr/bin"; + if(*cp==':') { + cp++; + if(stat(Xargv[0],&stbuf)==0) { + strcpy(myname,Xargv[0]); + return(stabf = myname); + } + } + for(;*cp;) { + + /* copy over current directory + and then append argv[0] */ + + for(cp2=myname;(*cp)!=0 && (*cp)!=':';) + *cp2++ = *cp++; + *cp2++ = '/'; + strcpy(cp2,Xargv[0]); + if(*cp) cp++; + if(0!=stat(myname,&stbuf)) continue; + return(stabf = myname); + } + error("Could not find which file is being executed.",FALSE); + } else return (stabf); +} diff --git a/usr/src/cmd/lisp/fixpbig.e b/usr/src/cmd/lisp/fixpbig.e new file mode 100644 index 0000000000..6bef1cf1c1 --- /dev/null +++ b/usr/src/cmd/lisp/fixpbig.e @@ -0,0 +1,11 @@ +/calls $[0-9]*,_stack/d +/calls $0,_unstack/s//movl (sp)+,r0/ +/calls $0,_sp/s//movl sp,r0/ +/\*_np\([ , ]\)/s//(r6)\1/g +/\*_lbot\([ , ]\)/s//(r7)\1/g +/_np\([ , ]\)/s//r6\1/g +/_lbot\([ , ]\)/s//r7\1/g +/\*_np$/s//(r6)/g +/\*_lbot$/s//(r7)/g +/_np$/s//r6/g +/_lbot$/s//r7/g diff --git a/usr/src/cmd/lisp/fpipe.c b/usr/src/cmd/lisp/fpipe.c new file mode 100644 index 0000000000..05c8dd1c74 --- /dev/null +++ b/usr/src/cmd/lisp/fpipe.c @@ -0,0 +1,32 @@ +#include +FILE *_dofpip(iodes) +int iodes; +{ + register FILE *p; + + for(p=_iob; (p->_flag&(_IOWRT|_IOREAD))!=0; p++) + if (p >= _iob+_NFILE) + return(NULL); + p->_file = iodes; + p->_cnt = 0; + p->_base = p->_ptr = NULL; + return(p); +} + +FILE * fpipe(info) +FILE *info[2]; +{ + register FILE *p; + int descrips[2]; + + if(0 > pipe(descrips)) return( (FILE *) -1); + + if(NULL==(p = _dofpip(descrips[0]))) return( (FILE *) -1); + p->_flag = (_IONBF|_IOREAD); + info[0] = p; + + if(NULL==(p = _dofpip(descrips[1]))) return( (FILE *) -1); + p->_flag = _IOWRT; + info[1] = p; + return((FILE *) 2); /*indicate sucess*/ +} diff --git a/usr/src/cmd/lisp/frame.h b/usr/src/cmd/lisp/frame.h new file mode 100644 index 0000000000..aa515d9458 --- /dev/null +++ b/usr/src/cmd/lisp/frame.h @@ -0,0 +1,9 @@ +struct frame { + lispval (*handler)(); + long mask; + lispval *ap; +struct frame *fp; + lispval (*pc)(); + lispval *r6; + lispval *r7; +}; diff --git a/usr/src/cmd/lisp/gtabs.h b/usr/src/cmd/lisp/gtabs.h new file mode 100644 index 0000000000..9a45a6dd7c --- /dev/null +++ b/usr/src/cmd/lisp/gtabs.h @@ -0,0 +1,6 @@ +/* these are the tables of global lispvals known to the interpreter */ +/* and compiler. They are not used by the garbage collector. */ +#define GFTABLEN 200 +#define GCTABLEN 8 +extern lispval gftab[GFTABLEN]; +extern lispval gctab[GCTABLEN]; diff --git a/usr/src/cmd/lisp/inewint.s b/usr/src/cmd/lisp/inewint.s new file mode 100644 index 0000000000..24406a5bcd --- /dev/null +++ b/usr/src/cmd/lisp/inewint.s @@ -0,0 +1,11 @@ + .globl _inewint +_inewint:.word 0 + cvtlb 4(ap),r0 + bvs nofit + ashl $2,4(ap),r0 + addl2 $1024,r0 + ret +nofit: + calls $0,_newint + movl 4(ap),0(r0) + ret diff --git a/usr/src/cmd/lisp/io.c b/usr/src/cmd/lisp/io.c new file mode 100644 index 0000000000..798112f33b --- /dev/null +++ b/usr/src/cmd/lisp/io.c @@ -0,0 +1,635 @@ +#include "global.h" +#include +#include +#include "chars.h" + +struct readtable { +char ctable[132]; +} initread = { +/* ^@ nul ^A soh ^B stx ^C etx ^D eot ^E eng ^F ack ^G bel */ + VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR, +/* ^H bs ^I ht ^J nl ^K vt ^L np ^M cr ^N so ^O si */ + VCHAR, VSEP, VSEP, VSEP, VSEP, VSEP, VERR, VERR, +/* ^P dle ^Q dc1 ^R dc2 ^S dc3 ^T dc4 ^U nak ^V syn ^W etb */ + VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR, +/* ^X can ^Y em ^Z sub ^[ esc ^\ fs ^] gs ^^ rs ^_ us */ + VERR, VERR, VERR, VSEP, VERR, VERR, VERR, VERR, +/* sp ! " # $ % & ' */ + VSEP, VCHAR, VDQ, VCHAR, VCHAR, VCHAR, VCHAR, VSQ, +/* ( ) * + , - . / */ + VLPARA, VRPARA, VCHAR, VSIGN, VCHAR, VSIGN, VPERD, VCHAR, +/* 0 1 2 3 4 5 6 7 */ + VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, +/* 8 9 : ; < = > ? */ + VNUM, VNUM, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, +/* @ A B C D E F G */ + VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, +/* H I J K L M N O */ + VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, +/* P Q R S T U V W */ + VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, +/* X Y Z [ \ ] ^ _ */ + VCHAR, VCHAR, VCHAR, VLBRCK, VESC, VRBRCK, VCHAR, VCHAR, +/* ` a b c d e f g */ + VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, +/* h i j k l m n o */ + VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, +/* p q r s t u v w */ + VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, +/* x y z { | } ~ del */ + VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VEOF, +/* unused unused Xesc Xdqc */ + 0, 0, '\\', '"' +}; + +char *ctable = initread.ctable; +lispval atomval; /* external varaible containing atom returned + from internal atom reading routine */ +lispval protect(); +lispval unprotect(); +lispval readrx(); lispval readr(); lispval readry(); +int keywait; +static int dbqflag; +static int macflag; +static int splflag; +static int mantisfl = 0; +lispval lastrtab; /* external variable designating current reader + table */ +static char baddot1[]= +"Bad reader construction: (. )\nShould be (nil . )\n"; +static char baddot2[]= +"Bad reader construction: ( .)\n\ +Should be ( . ), assumed to be ()"; +static char baddot3[]= +"Bad reader construction: ( . not followed by )"; + +#include "chkrtab.h" +/* readr ****************************************************************/ +/* returns a s-expression read in from the port specified as the first */ +/* argument. Handles superbrackets, reader macros. */ +lispval +readr(useport) +FILE *useport; +{ + register lispval handy = Vreadtable->clb; + + chkrtab(handy); + rbktf = FALSE; + rdrport = (FILE *) useport; + if(useport==stdin) + keywait = TRUE; + handy = readrx(Iratom()); + if(useport==stdin) + keywait = FALSE; + return(handy); + +} + + +/* readrx **************************************************************/ +/* returns a s-expression beginning with the syntax code of an atom */ +/* passed in the first */ +/* argument. Does the actual work for readr, including list, dotted */ +/* pair, and quoted atom detection */ +lispval +readrx(code) +register int code; +{ + register lispval work; + register lispval *current; + register struct argent *result; + register struct argent *lbot, *np; + int inlbkt = FALSE; + lispval errorh(); + +top: + switch(code) + { + case TLBKT: + inlbkt = TRUE; + case TLPARA: + result = np; + current = (lispval *)np; + np++->val = nil; /*protect(nil);*/ + for(EVER) { + switch(code = Iratom()) + { + case TRPARA: + if(rbktf && inlbkt) + rbktf = FALSE; + return(result->val); + default: + atomval = readrx(code); + case TSCA: + np++->val=atomval; + *current = work = newdot(); + work->car = atomval; + np--; + current = (lispval *) &(work->cdr); + break; + case TSPL: + macrox(); /* input and output in atomval */ + *current = atomval; + while(*current!=nil) { + if(TYPE(*current)!=DTPR) + errorh(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current); + current=(lispval *)&((*current)->cdr); + } + break; + case TPERD: + if(result->val==nil) { + work = result->val=newdot(); + current = (lispval *) &(work->cdr); + fprintf(stderr,baddot1); + } + code = Iratom(); + if(code==TRPARA) { + return(errorh(Vermisc,baddot2,nil,TRUE,58,result->val)); + } + *current = readrx(code); + if((code = Iratom())!=TRPARA) { + errorh(Vermisc,baddot3,nil,TRUE,59,result->val,atomval); + } + if(rbktf && inlbkt) + rbktf = FALSE; + return(result->val); + case TEOF: + clearerr(rdrport); + error("Premature end of file.", FALSE); + } + if(rbktf) { + if(inlbkt) + rbktf = FALSE; + return(result->val); + } + } + case TSCA: + return(atomval); + case TEOF: + return(eofa); + case TMAC: + macrox(); + return(atomval); + case TSPL: + macrox(); + if((work = atomval)!=nil) { + if(TYPE(work)==DTPR && work->cdr==nil) + return(work->car); + else + errorh(Vermisc, +"Improper value returned from splicing macro at top-level",nil,FALSE,9,work); + } + code = Iratom(); + goto top; + /* return(readrx(Iratom())); */ + case TSQ: + result = np; + protect(newdot()); + (work = result->val)->car = quota; + work = work->cdr = newdot(); + work->car = readrx(Iratom()); + return(result->val); + default: + return(error("Readlist error",FALSE)); + } +} +macrox() +{ + lispval Lapply(); + + snpand(0); + lbot = np; + protect(Iget(atomval,macro)); + protect(nil); + atomval = Lapply(); + return; +} + + + +/* ratomr ***************************************************************/ +/* this routine returns a pointer to an atom read in from the port given*/ +/* by the first argument */ +lispval +ratomr(useport) +register FILE *useport; +{ + rdrport = useport; + switch(Iratom()) + { + case TEOF: + return(eofa); + case TSQ: + case TRPARA: + case TLPARA: + case TLBKT: + case TPERD: + strbuf[1]=0; + return(getatom()); + default: + return(atomval); + } +} +Iratom() +{ + register FILE *useport = rdrport; + register char c, marker, *name; + extern lispval finatom(), calcnum(), getnum(); + char positv = TRUE; + int code; + int strflag = FALSE; + + name = strbuf; + +again: c = getc(useport) & 0177; + *name = c; + + switch(ctable[c] & 0377) { + + default: goto again; + + case VNUM: + + case VSIGN: *name++ = c; + atomval = (getnum(name)); + return(TSCA); + + case VESC: + dbqflag = TRUE; + *name++ = getc(useport) & 0177; + atomval = (finatom(name)); + return(TSCA); + + case VCHAR: + *name++ = c; + atomval = (finatom(name)); + return(TSCA); + + case VLPARA: return(TLPARA); + + case VRPARA: return(TRPARA); + + case VPERD: c = peekc(useport); + if(VNUM!=ctable[c]) + return(TPERD); + *name++ = '.'; + mantisfl = 1; + atomval = (getnum(name)); + return(TSCA); + + case VLBRCK: return(TLBKT); + + case VRBRCK: rbktf = TRUE; + return(TRPARA); + + case VEOF: /*printf("returning eof atom\n");*/ + return(TEOF); + + case VSQ: return(TSQ); + + case VSD: strflag = TRUE; + case VDQ: name = strbuf; + marker = c; + while ((c = getc(useport)) != marker) { + + if(VESC==ctable[c]) c = getc(useport); + *name++ = c; + if (name >= endstrb) + error("ATOM TOO LONG",FALSE); + if (feof(useport)) { + clearerr(useport); + error("EOF ecountered while reading atom", FALSE); + } + } + *name = NULL_CHAR; + if(strflag) + atomval = (lispval) inewstr(strbuf); + else + atomval = (getatom(name)); + return(TSCA); + + case VERR: if (c == '\0') goto same; /* null pname */ + fprintf(stderr,"%c (%o): ",c,(int) c); + error("ILLEGAL CHARACTER IN ATOM",TRUE); + + case VSPL: + code = TSPL; + goto same; + case VMAC: + code = TMAC; + goto same; + case VSCA: + code = TSCA; + same: + strbuf[0] = c; + strbuf[1] = 0; + atomval = (getatom()); + return(code); + } +} + +#define push(); if(name==endstrb) error("Int too long",FALSE); else *name++=c; +#define next() (stats = ctable[c=getc(useport) & 0177]) + +lispval +getnum(name) +register char *name; +{ + register char c; + register lispval result; + register FILE *useport=rdrport; + char stats; + double realno; + extern lispval finatom(), calcnum(), newdoub(), dopow(); + + if(mantisfl) { + mantisfl = 0; + next(); + goto mantissa; + } + while(VNUM==next()) { + push(); /* recognize [0-9]*, in "ex" parlance */ + } + if(stats==VPERD) { + push(); /* continue */ + } else if(stats & SEPMASK) { + ungetc(c,useport); + return(calcnum(strbuf,name,ibase->clb->i)); + } else if(c=='^') { + push(); + return(dopow(name,ibase->clb->i)); + } else if(c=='_') { + push(); + return(dopow(name,2)); + } else{ + ungetc(c,useport); + return(finatom(name)); + } + /* at this point we have [0-9]*\. , which might + be a decimal int or the leading part of a + float */ + if(next()!=VNUM) { + if(c=='e' || c=='E' || c=='d' ||c=='D') + goto expt; + else if(c=='^') { + push(); + return(dopow(name,ibase->clb->i)); + } else if(c=='_') { + push(); + return(dopow(name,2)); + } else { + /* Here we have 1.x where x not num, not sep */ + /* Here we have decimal int. NOT FORTRAN! */ + ungetc(c,useport); + return(calcnum(strbuf,name-1,10)); + } + } +mantissa: + do { + push(); + } while (VNUM==next()); + /* Here we have [0-9]*\.[0-9]* */ + if(stats & SEPMASK) + goto last; + else if(c!='e' && c!='E' && c!='d' && c!='D') { + ungetc(c,useport); + goto verylast; + } +expt: push(); + next(); + if(c=='+' || c =='-') { + push(); + next(); + } + while (VNUM==stats) { + push(); + next(); + } +last: ungetc(c,useport); + if(! (stats & SEPMASK) ) + return(finatom(name)); + +verylast: + *name=0; + sscanf(strbuf,"%F",&realno); + (result = newdoub())->r = realno; + return(result); +} + +lispval +dopow(part2,base) +lispval base; +char *part2; +{ + register char *name = part2; + register char c; + register FILE *useport = rdrport; + register int power; + register struct argent *lbot, *np; + char stats; + char *end1 = part2 - 1; lispval Ltimes(); + + while(VNUM==next()) { + push(); + } + if(c!='.') { + ungetc(c,useport); + } + if(c!='.' && !(stats & SEPMASK)) { + return(finatom(name)); + } + lbot = np; + np++->val = inewint(base); + /* calculate "mantissa"*/ + if(*end1=='.') + np++->val = calcnum(strbuf,end1-1,10); + else + np++->val = calcnum(strbuf,end1,ibase->clb->i); + + /* calculate exponent */ + if(c=='.') + power = calcnum(part2,name,10)->i; + else + power = calcnum(part2,name,ibase->clb->i)->i; + while(power-- > 0) + lbot[1].val = Ltimes(); + return(lbot[1].val); +} + + +lispval +calcnum(strbuf,name,base) +char *name; +char *strbuf; +{ + register char *p; + register lispval result, temp; + int negflag = 0; + + temp = rdrsdot; /* initialize sdot cell */ + temp->CDR = nil; + temp->i = 0; + p = strbuf; + if(*p=='+') p++; + else if(*p=='-') {negflag = 1; p++;} + *name = 0; + if(p>=name) return(getatom()); + + for(;p < name; p++) + dmlad(temp,base,*p-'0'); + if(negflag) + dmlad(temp,-1,0); + + if(temp->CDR==0) { + result = inewint(temp->i); + return(result); + } else { + (result = newsdot())->i = temp->i; + result->CDR = temp->CDR; + temp->CDR = 0; + } + return(result); +} +lispval +finatom(name) +register char *name; +{ + extern int uctolc; + register FILE *useport = rdrport; + register char c, stats; + register char *savenm; + savenm = name - 1; /* remember start of name */ + while(!(next()&SEPMASK)) { + + if(stats == VESC) c = getc(useport) & 0177; + *name++=c; + if (name >= endstrb) + error("ATOM TOO LONG",FALSE); + } + *name = NULL_CHAR; + ungetc(c,useport); + if (uctolc) for(; *savenm ; savenm++) + if( isupper(*savenm) ) *savenm = tolower(*savenm); + return(getatom()); +} + +/* printr ***************************************************************/ +/* prints the first argument onto the port specified by the second */ +printr(a,useport) +register lispval a; +register FILE *useport; +{ + register lispval temp; + char strflag = 0; + char Idqc = 0; + + +val_loop: + if( ! VALID(a) ) + { + error("BAD LISP DATA ENCOUNTERED BY PRINTR",TRUE); + a = badst; + } + + switch (TYPE(a)) { + + + case UNBO: fputs("",useport); + break; + + case VALUE: fputs("(ptr to)",useport); + a = a->l; + goto val_loop; + + case INT: fprintf(useport,"%d",a->i); + break; + + case DOUB: fprintf(useport,"%0.16G",a->r); + break; + + case PORT: fputs("port",useport); + break; + + case ARRAY: fputs("array[",useport); + printr(a->length,useport); + fputs("]",useport); + break; + + case BCD: fprintf(useport,"#%X-",a->entry); + printr(a->discipline,useport); + break; + + case SDOT: pbignum(a,useport); + break; + + case DTPR: if(a->car==quota && a->cdr!=nil + && a->cdr->cdr==nil) { + putc('\'',useport); + printr(a->cdr->car,useport); + break; + } + putc('(',useport); + morelist: printr(a->car,useport); + if ((a = a->cdr) != nil) + { + putc(' ',useport); + if (TYPE(a) == DTPR) goto morelist; + fputs(". ",useport); + printr(a,useport); + } + fputc(')',useport); + break; + + case STRNG: strflag = TRUE; + Idqc = Xsdc; + + case ATOM: { + char *front, *temp; int clean; + temp = front = (strflag ? ((char *) a) : a->pname); + if(Idqc==0) Idqc = Xdqc; + + if(Idqc) { + clean = *temp; + if (*temp == '-') temp++; + clean = clean && (ctable[*temp] != VNUM); + while (clean && *temp) + clean = (!(ctable[*temp++] & QUTMASK)); + if (clean) + fputs(front,useport); + else { + putc(Idqc,useport); + for(temp=front;*temp;temp++) { + if( *temp==Idqc + || ctable[*temp] == VESC) + putc(Xesc,useport); + putc(*temp,useport); + } + putc(Idqc,useport); + } + + } else { + register char *cp = front; + + if(ctable[*cp]==VNUM) + putc(Xesc,useport); + for(; *cp; cp++) { + if(ctable[*cp]& QUTMASK) + putc(Xesc,useport); + putc(*cp,useport); + } + + } + + } + } +} + +/* dmpport ****************************************************************/ +/* outputs buffer indicated by first argument whether full or not */ +dmpport(useport) +register lispval useport; + { + fflush(useport); +} + +/* protect and unprot moved to eval.c (whr) */ diff --git a/usr/src/cmd/lisp/lam1.c b/usr/src/cmd/lisp/lam1.c new file mode 100644 index 0000000000..66595b350c --- /dev/null +++ b/usr/src/cmd/lisp/lam1.c @@ -0,0 +1,668 @@ + +# include "global.h" +# include +# include "chkrtab.h" +/**************************************************************************/ +/* */ +/* file: ccdfns.i */ +/* contents: LISP functions coded in C */ +/* */ +/* These include LISP primitives, numeric and boolean functions and */ +/* predicates, some list-processing functions, i/o support functions */ +/* and control flow functions (e.g. cont, break). */ +/* There are two types of functions: lambda (prefixed "L") and nlambda */ +/* (prefixed "N"). */ +/* Lambda's all call chkarg to insure that at least the minimum number */ +/* of necessary arguments are on the namestack. */ +/* All functions take their arguments from the namestack in a read- */ +/* only manner, and return their results via the normal C value */ +/* return mechanism. */ +/* */ + + + +lispval +Leval() +{ + register lispval temp; + + chkarg(1); + temp = lbot->val; + return(eval(temp)); +} + +lispval +Lxcar() +{ register int typ; + register lispval temp, result; + + chkarg(1); + temp = lbot->val; + if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM)) + return(temp -> car); + else if(typ == SDOT) { + result = inewint(temp->i); + return(result); + } else if(Schainp!=nil && typ==ATOM) + return(nil); + else + return(error("BAD ARG TO CAR",FALSE)); + +} + +lispval +Lxcdr() +{ register int typ; + register lispval temp, result; + + chkarg(1); + temp = lbot->val; + if(temp==nil) return (nil); + + if ((typ = TYPE(temp)) == DTPR) + return(temp -> cdr); + else if(typ==SDOT) { + if(temp->CDR==0) return(nil); + return(temp->CDR); + } else if(Schainp!=nil && typ==ATOM) + return(nil); + else + return(error("BAD ARG TO CDR",FALSE)); +} + +lispval +cxxr(as,ds) +register int as,ds; +{ + + register lispval temp, temp2; + int i, typ; + lispval errorh(); + + chkarg(1); + temp = lbot->val; + + for( i=0 ; i cdr; + else if(typ==SDOT) { + if(temp->CDR==0) temp = nil; + else temp = temp->CDR; + } + else if(Schainp!=nil && typ==ATOM) + return(nil); + else + return(errorh(Vermisc,"BAD ARG TO CDR",nil,FALSE,5,temp)); + } + } + + for( i=0 ; i car; + else if(typ == SDOT) + temp2 = inewint(temp->i), temp = temp2; + else if(Schainp!=nil && typ==ATOM) + return(nil); + else + return(errorh(Vermisc,"BAD ARG TO CAR",nil,FALSE,5,temp)); + } + } + + return(temp); +} + + +lispval +Lcar() +{ return(cxxr(1,0)); +} + +lispval +Lcdr() +{ return(cxxr(0,1)); +} + +lispval +Lcadr() +{ return(cxxr(1,1)); +} + +lispval +Lcaar() +{ return(cxxr(2,0)); +} + +lispval +Lc02r() +{ return(cxxr(0,2)); /* cddr */ +} + +lispval +Lc12r() +{ return(cxxr(1,2)); /* caddr */ +} + +lispval +Lc03r() +{ return(cxxr(0,3)); /* cdddr */ +} + +lispval +Lc13r() +{ return(cxxr(1,3)); /* cadddr */ +} + +lispval +Lc04r() +{ return(cxxr(0,4)); /* cddddr */ +} + +lispval +Lc14r() +{ return(cxxr(1,4)); /* caddddr */ +} + +/************************* +* +* (nthelem num list) +* returns the num'th element of the list, by doing a caddddd...ddr +* where there are num-1 d's +* if num<=0 or greater than the length of the list, we return nil +******************************************************/ + +lispval +Lnthelem() +{ + register lispval temp; + register int i; + + chkarg(2); + + if( TYPE(temp = lbot->val) != INT) + return (error ("First arg to nthelem must be a fixnum",FALSE)); + + i = temp->i; /* pick up the first arg */ + + if( i <= 0) return(nil); + + ++lbot; /* fix lbot for call to cxxr() 'cadddd..r' */ + temp = cxxr(1,i-1); + --lbot; + + return(temp); +} + + + + + +lispval +Lscons() +{ + register struct argent *argp = lbot; + register lispval retp, handy; + register int typ; + + chkarg(2); + retp = newsdot(); + handy = (argp) -> val; + if(TYPE(handy)!=INT) + error("First arg to scons must be an int.",FALSE); + retp->I = handy->i; + handy = (argp+1)->val; + if(handy==nil) + retp->CDR = (lispval) 0; + else { + if(TYPE(handy)!=SDOT) + error("Currently you may only link sdots to sdots.",FALSE); + retp->CDR = handy; + } + return(retp); +} +lispval +Lcons() +{ register struct argent *argp; + lispval retp; + + chkarg(2); + retp = newdot(); + retp -> cdr = ((argp = np-1) -> val); + retp -> car = (--argp) -> val; + return(retp); +} +#define CA 0 +#define CD 1 + +lispval +rpla(what) +int what; +{ register struct argent *argp; + register int typ; register lispval first, second; + + chkarg(2); + argp = np-1; + first = (argp-1)->val; + while(first==nil) + first = error("Attempt to rplac[ad] nil.",TRUE); + second = argp->val; + if (((typ = TYPE(first)) == DTPR) || (typ == ATOM)) { + if (what == CA) + first->car = second; + else + first->cdr = second; + return(first); + } + if (typ==SDOT) { + if(what == CA) { + typ = TYPE(second); + if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE); + first->i = second->i; + } else { + if(second==nil) + first->CDR = (lispval) 0; + else + first->CDR = second; + } + return(first); + } + return(error("BAD ARG TO RPLA",FALSE)); +} +lispval +Lrplaca() +{ return(rpla(CA)); } + +lispval +Lrplacd() +{ return(rpla(CD)); } + + +lispval +Leq() +{ + register struct argent *mynp = lbot + AD; + int itemp, flag; + + chkarg(2); + if(mynp->val==(mynp+1)->val) return(tatom); + return(nil); +} + + + +lispval +Lnull() +{ chkarg(1); + return ((lbot->val == nil) ? tatom : nil); +} + + + +/* Lreturn **************************************************************/ +/* Returns the first argument - which is nill if not specified. */ +Lreturn() + { + chkarg(1); + contval = lbot->val; + reset(BRRETN); + } + + +/* Lretbrk **************************************************************/ +/* The first argument must be an integer and must be in the range */ +/* -1 .. -depth. */ +lispval +Lretbrk() + { + lispval number; + register level; + + + chkarg(1); + number = lbot->val; + if (TYPE(number) != INT) + level = -1; + else + level = number->i; + if(level < 0) + level += depth; + contval = (lispval) level; + if (level < depth) + reset(BRRETB); + return(nil); +} + + + +lispval +Linfile() +{ + FILE *port; + register lispval name; + snpand(1); + + chkarg(1); + name = lbot->val; + while (TYPE(name)!=ATOM) + name = error("Please supply atom name for port.",TRUE); + /* return nil if file couldnt be opened + if ((port = fopen(name->pname,"r")) == NULL) return(nil); */ + + while ((port = fopen(name->pname,"r")) == NULL) + name = errorh(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name); + + return((lispval)(xports + (port - _iob))); +} + +lispval +Loutfile() +{ + FILE *port; register lispval name; + + chkarg(1); + name = lbot->val; + while (TYPE(name)!=ATOM) + name = error("Please supply atom name for port.",TRUE); + while ((port = fopen(name->pname,"w")) == NULL) + name = errorh(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name); + return((lispval)(xports + (port - _iob))); +} +lispval +Lterpr() +{ + FILE *port; + + chkarg(1); + port = okport(lbot->val,okport(Vpoport->clb,stdout)); + putc('\n',port); + fflush(port); + return(nil); +} +lispval +Lclose() +{ + lispval port; + + if(lbot==np) + port = error("Close requires one argument of type port",TRUE); + port = lbot->val; + if((TYPE(port))==PORT) fclose(port->p); + return(tatom); +} + +lispval +Lnwritn() +{ + register FILE *port; + register value; + + chkarg(1); + port = okport(lbot->val,okport(Vpoport->clb,stdout)); + value = port->_ptr - port->_base; + return(inewint(value)); +} + +lispval +Ldrain() +{ + register FILE *port; + register int iodes; + struct sgttyb arg; + + chkarg(1); + port = okport(lbot->val, okport(Vpoport->clb,stdout)); + if(port->_flag & _IOWRT) { + fflush(port); + return(nil); + } + if(! port->_flag & _IOREAD) return(nil); + port->_cnt = 0; + port->_ptr = port->_base; + iodes = fileno(port); + if(gtty(iodes,&arg) != -1) stty(iodes,&arg); + return((lispval)(xports + (port - _iob))); +} +lispval +Llist() +{ + /* added for the benefit of mapping functions. */ + register struct argent *ulim, *namptr; + register lispval temp, result; + register struct argent *lbot, *np; + + ulim = np; + namptr = lbot + AD; + temp = result = (lispval) np; + protect(nil); + for(; namptr < ulim;) { + temp = temp->l = newdot(); + temp->car = (namptr++)->val; + } + temp->l = nil; + return(result->l); +} + +lispval +Lnumberp() +{ + chkarg(1); + switch(TYPE(lbot->val)) { + case INT: case DOUB: case SDOT: + return(tatom); + } + return(nil); +} + +lispval +Latom() +{ + chkarg(1); + if(TYPE(lbot->val)==DTPR) + return(nil); + else + return(tatom); +} +lispval +Ltype() +{ + chkarg(1); + switch(TYPE(lbot->val)) { + case INT: + return(int_name); + case ATOM: + return(atom_name); + case SDOT: + return(sdot_name); + case DOUB: + return(doub_name); + case DTPR: + return(dtpr_name); + case STRNG: + return(str_name); + case ARRAY: + return(array_name); + case BCD: + return(funct_name); + case VALUE: + return(val_name); + case PORT: + return(matom("port")); /* fix this when name exists */ + } + return(nil); +} + +lispval +Ldtpr() +{ + chkarg(1); + return(typred(DTPR,lbot->val)); +} + +lispval +Lbcdp() +{ + chkarg(1); + return(typred(BCD,lbot->val)); +} + +lispval +Lportp() +{ + chkarg(1); + return(typred(PORT,lbot->val)); +} + +lispval +Larrayp() +{ + chkarg(1); + return(typred(ARRAY,lbot->val)); +} +lispval +Lset() +{ + lispval varble; + snpand(0); + + chkarg(2); + varble = lbot->val; + switch(TYPE(varble)) + { + case ATOM: return(varble->clb = lbot[1].val); + + case VALUE: return(varble->l = lbot[1].val); + } + + error("IMPROPER USE OF SET",FALSE); +} +lispval +Lequal() +{ + chkarg(2); + + if( lbot[1].val == lbot->val ) return(tatom); + if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil); +} + +Iequal(first,second) +register lispval first, second; +{ + register type1, type2; + register struct argent *lbot, *np; + lispval Lsub(),Lzerop(); + + if(first==second) + return(1); + type1=TYPE(first); + type2=TYPE(second); + if(type1!=type2) { + if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) + goto dosub; + return(0); + } + switch(type1) { + case DTPR: + return( + Iequal(first->car,second->car) && + Iequal(first->cdr,second->cdr) ); + case DOUB: + return(first->r==second->r); + case INT: + return( (first->i==second->i)); +dosub: + case SDOT: + lbot = np; + np++->val = first; + np++->val = second; + lbot->val = Lsub(); + np = lbot + 1; + return(Lzerop()!=nil); + case VALUE: + return( first->l==second->l ); + case STRNG: + return(strcmp(first,second)==0); + } + return(0); +} + +lispval +Lprint() +{ + chkarg(2); + chkrtab(Vreadtable->clb); + printr(lbot->val,okport(lbot[1].val,okport(Vpoport->clb,poport))); + return(nil); +} + +FILE * +okport(arg,proper) +lispval arg; +FILE *proper; +{ + if(TYPE(arg)!=PORT) + return(proper); + else + return(arg->p); +} +lispval +Lpatom() +{ + register lispval temp; + FILE *port; + + chkarg(2); + temp = Vreadtable->clb; + chkrtab(temp); + port = okport(lbot[1].val, okport(Vpoport->clb,stdout)); + if ((TYPE((temp = (lbot)->val)))!=ATOM) + printr(temp, port); + else + fputs(temp->pname, port); + return(temp); +} + +/* + * (pntlen thing) returns the length it takes to print out + * an atom or number. + */ + +lispval +Lpntlen() +{ + register lispval temp; + return(inewint(Ipntlen())); +} +Ipntlen() +{ + register lispval temp; + register char *handy; + + temp = np[-1].val; +loop: switch(TYPE(temp)) { + + case ATOM: + handy = temp->pname; + break; + + case INT: + sprintf(strbuf,"%d",temp->i); + handy =strbuf; + break; + + case DOUB: + sprintf(strbuf,"%g",temp->r); + handy =strbuf; + break; + + default: + temp = error("Non atom or number to pntlen\n",TRUE); + goto loop; + } + + return( strlen(handy)); +} diff --git a/usr/src/cmd/lisp/lam2.c b/usr/src/cmd/lisp/lam2.c new file mode 100644 index 0000000000..85607b18e3 --- /dev/null +++ b/usr/src/cmd/lisp/lam2.c @@ -0,0 +1,593 @@ +# include "global.h" +/* + * (flatsize thing max) returns the smaller of max and the number of chars + * required to print thing linearly. + */ +static flen; /*Internal to this module, used as a running counter of flatsize*/ +static fmax; /*used for maximum for quick reference */ + +lispval +Lflatsi() +{ + register lispval current, temp; + register struct argent *mylbot = lbot; + snpand(3); /* fixup entry mask */ + + chkarg(2); + flen = 0; fmax = mylbot[1].val->i; + current = mylbot->val; + protect(nil); /*create space for argument to pntlen*/ + Iflatsi(current); + return(inewint(flen)); +} +/* + * Iflatsi does the real work of the calculation for flatsize + */ +Iflatsi(current) +register lispval current; +{ + register lispval handy; + register int temp; + + if(flen > fmax) return(fmax); + switch(TYPE(current)) { + + patom: + case INT: case ATOM: case DOUB: + np[-1].val = current; + flen += Ipntlen(); + return; + + pthing: + case DTPR: + flen++; + Iflatsi(current->car); + current = current->cdr; + if(current == nil) { + flen++; + return; + } + if(flen > fmax) return; + switch(TYPE(current)) { + case INT: case ATOM: case DOUB: + flen += 4; + goto patom; + case DTPR: + goto pthing; + } + } +} + + +#define EADC -1 +#define EAD -2 +lispval +Lread() +{ return (r(EAD)); } + +lispval +Lratom() +{ return (r(ATOM)); } + +lispval +Lreadc() +{ return (r(EADC)); } + +#include "chars.h" + +extern char *ctable; +/* r *********************************************************************/ +/* this function maps the desired read function into the system-defined */ +/* reading functions after testing for a legal port. */ +lispval +r(op) +int op; +{ + register char c; register lispval result; + int orlevel; extern int rlevel; + FILE *ttemp; + struct nament *oldbnp = bnp; + snpand(2); + + chkarg(2); + result = Vreadtable->clb; + orlevel = rlevel; + rlevel = 0; + ttemp = okport(Vpiport->clb,stdin); + ttemp = okport(lbot->val,ttemp); +/*printf("entering switch\n");*/ + fflush(stdout); /* flush any pending characters */ + + switch (op) + { + case EADC: rlevel = orlevel; + switch (ctable[c = getc(ttemp)] & 0377) + { + case VEOF: + return(lbot[1].val); + default: + strbuf[0] = hash = c; + strbuf[1] = 0; + atmlen = 2; + return((lispval)getatom()); + } + case ATOM: rlevel = orlevel; + result = (ratomr(ttemp)); + goto out; + + case EAD: PUSHDOWN(Vpiport,P(ttemp)); /* rebind Vpiport */ + result = readr(ttemp); + out: if(result==eofa) + result = lbot[1].val; + rlevel = orlevel; + popnames(oldbnp); /* unwind bindings */ + return(result); + } +} + +/* Lload *****************************************************************/ +/* Reads in and executes forms from the specified file. This should */ +/* really be an nlambda taking multiple arguments, but the error */ +/* handling gets funny in that case (one file out of several not */ +/* openable, for instance). */ +lispval +Lload() +{ + register FILE *port; + register char *p; register lispval ttemp, vtemp; + register struct argent *lbot, *np; + struct nament *oldbnp = bnp; + int orlevel; + char longname[100]; + char *shortname, *end2; + + chkarg(1); + ttemp = lbot->val; + if(TYPE(ttemp)!=ATOM) return(error("FILENAME MUST BE ATOMIC",FALSE)); + strcpy(longname,"/usr/lib/lisp/" ); + for(p = longname; *p; p++); + shortname = p; + strcpy(p,ttemp->pname); + for(; *p; p++); + end2 = p; + strcpy(p,".l"); + if ((port = fopen(shortname,"r")) == NULL && + (port = fopen(longname, "r")) == NULL) { + *end2 = 0; + if ((port = fopen(shortname,"r")) == NULL && + (port = fopen(longname, "r")) == NULL) + error("CAN'T OPEN FILE", FALSE); + } + orlevel = rlevel; + rlevel = 0; + + if(ISNIL(copval(gcload,CNIL)) && + loading->clb != tatom && + ISNIL(copval(gcdis,CNIL))) + gc(CNIL); /* do a gc if gc will be off */ + + /* shallow bind the value of lisp atom piport */ + /* so readmacros will work */ + PUSHDOWN(Vpiport,P(port)); + PUSHDOWN(loading,tatom); /* set indication of loading status */ + + while ((vtemp = readr(port)) != eofa) { + eval(vtemp); + } + popnames(oldbnp); /* unbind piport, loading */ + + rlevel = orlevel; + fclose(port); + return(nil); +} + +/* concat ************************************************** +- +- use: (concat arg1 arg2 ... ) +- +- concatenates the print names of all of its arguments. +- the arguments may be atoms, integers or real numbers. +- +- *********************************************************/ +lispval +Iconcat(unintern) +{ + register struct argent *temnp; + register int atmlen; /* Passt auf! atmlen in the external + sense calculated by newstr */ + int i; + lispval cur; + snpand(2); + + atmlen = 0 ; + strbuf[0] = NULL_CHAR ; + + /* loop for each argument */ + for(temnp = lbot + AD ; temnp < np ; temnp++) + { + cur = temnp->val; + loop: switch(TYPE(cur)) + { + case ATOM: + strcpy(&strbuf[atmlen], ((struct atom *) cur) -> pname) ; + break; + + case INT: + sprintf(&strbuf[atmlen],"%d",cur->i); + break; + + case DOUB: + sprintf(&strbuf[atmlen],"%f",cur->f); + break; + + default: + cur = error("Non atom or number to concat",TRUE); + goto loop; /* if returns value, try it */ + } + atmlen = strlen(strbuf); + + } + + if(unintern) + return( (lispval) newatom()); + else + return( (lispval) getatom()) ; +} +lispval +Lconcat(){ + return(Iconcat(FALSE)); +} +lispval +Luconcat(){ + return(Iconcat(TRUE)); +} + +lispval +Lputprop() +{ + register struct argent *argp = lbot; + lispval Iputprop(); + snpand(1); + chkarg(3); + return(Iputprop(argp->val,argp[1].val,argp[2].val)); +} + +lispval +Iputprop(atm,prop,ind) +register lispval prop, ind, atm; +{ + register lispval pptr; + lispval *tack; /* place to begin property list */ + lispval errorh(); + top: + switch (TYPE(atm)) { + case ATOM: + if(atm == nil) tack = &nilplist; + else tack = &(atm->plist); + break; + case DTPR: + for (pptr = atm->cdr ; pptr != nil ; pptr = pptr->cdr->cdr) + if(TYPE(pptr) != DTPR || TYPE(pptr->cdr) != DTPR) break; + if(pptr != nil) + { atm = errorh(Vermisc, + "putprop: bad disembodied property list", + nil,TRUE,0,atm); + goto top; + } + tack = (lispval *) &(atm->cdr); + break; + default: + errorh(Vermisc,"putprop: Bad first argument: ",nil,FALSE,0,atm); + } + pptr = *tack; /* start of property list */ + findit: + for (pptr = *tack ; pptr != nil ; pptr = pptr->cdr->cdr) + if (pptr->car == ind) { + (pptr->cdr)->car = prop; + return(prop); + } + else tack = &(pptr->cdr->cdr) ; + *tack = pptr = newdot(); + pptr->car = ind; + pptr = pptr->cdr = (lispval) newdot(); + pptr->car = prop; + return(prop); +} + +/* get from property list + * there are three routines to accomplish this + * Lget - lisp callable, the first arg can be a symbol or a disembodied + * property list. In the latter case we check to make sure it + * is a real one (as best we can). + * Iget - internal routine, the first arg must be a symbol, no disembodied + * plists allowed + * Igetplist - internal routine, the first arg is the plist to search. + */ +lispval +Lget() +{ + register lispval ind, atm; + register lispval dum1, dum2; + lispval Igetplist(); + snpand(2); + + chkarg(2); + ind = lbot[1].val; + atm = lbot[0].val; +top: + switch(TYPE(atm)) { + case ATOM: + if(atm==nil) atm = nilplist; + else atm = atm->plist; + break; + + case DTPR: + for (dum1 = atm->cdr; dum1 != nil; dum1 = dum1->cdr->cdr) + if((TYPE(dum1) != DTPR) || + (TYPE(dum1->cdr) != DTPR)) break; /* bad prop list */ + if(dum1 != nil) + { atm = errorh(Vermisc, + "putprop: bad disembodied property list", + nil,TRUE,0,atm); + goto top; + } + atm = atm -> cdr; + break; + default: + /* remove since maclisp doesnt treat + this as an error, ugh + return(errorh(Vermisc,"get: bad first argument: ", + nil,FALSE,0,atm)); + */ + return(nil); + } + return(Igetplist(atm,ind)); +} +/* + * Iget - the first arg must be a symbol. + */ + +lispval +Iget(atm,ind) +register lispval atm, ind; +{ + lispval Igetplist(); + + if(atm==nil) + atm = nilplist; + else + atm = atm->plist; + return(Igetplist(atm,ind)); +} + +/* + * Igetplist + * pptr is a plist + * ind is the indicator + */ + +lispval +Igetplist(pptr,ind) +register lispval pptr,ind; +{ + while (pptr != nil) + { + if (pptr->car == ind) + return ((pptr->cdr)->car); + pptr = (pptr->cdr)->cdr; + } + return(nil); +} +lispval +Lgetd() +{ + register lispval typ; + snpand(1); + + chkarg(1); + typ = lbot->val; + if (TYPE(typ) != ATOM) + errorh(Vermisc, + "getd: ONLY ATOMS HAVE FUNCTION DEFINITIONS", + nil, + FALSE, + 0, + typ); + return(typ->fnbnd); +} +lispval +Lputd() +{ + register lispval atom, list; + register lispval dum1, dum2; + register struct argent *lbot, *np; + snpand(2); + + chkarg(2); + list = lbot[1].val; + atom = lbot->val; + if (TYPE(atom) != ATOM) error("ONLY ATOMS HAVE FUNCTION DEFINITIONS",FALSE); + atom->fnbnd = list; + return(list); +} + +/* =========================================================== +- mapping functions which return a list of the answers +- mapcar applies the given function to successive elements +- maplist applies the given function to successive sublists +- ===========================================================*/ + +lispval +Lmapcrx(maptyp,join) +int maptyp; /* 0 = mapcar, 1 = maplist */ +int join; /* 0 = the above, 1 = s/car/can/ */ +{ + register struct argent *namptr; + register index; + register lispval temp; + register lispval current; + register struct argent *lbot; + register struct argent *np; + + struct argent *first, *last; + int count; + lispval lists[25], result; + + namptr = lbot + 1; + count = np - namptr; + if (count <= 0) return (nil); + /*oldlbot = lbot; /* lbot saved by virtue of entry mask */ + result = current = (lispval) np; + protect(nil); /* set up space for returned list */ + protect(lbot->val); /*copy funarg for call to funcall */ + lbot = np -1; + first = np; + last = np += count; + for(index = 0; index < count; index++) { + temp =(namptr++)->val; + if (TYPE (temp ) != DTPR && temp!=nil) + error ( "bad list argument to map",FALSE); + lists[index] = temp; + } + for(;;) { + for(namptr=first,index=0; indexval = temp->car; + else (namptr++)->val = temp; + + lists[index] = temp->cdr; + } + if (join == 0) { + current->l = newdot(); + current->l->car = Lfuncal(); + current = (lispval) ¤t->l->cdr; + } else { + current->l = Lfuncal(); + if ( TYPE ( current -> l) != DTPR && current->l != nil) + error("bad type returned from funcall inside map",FALSE); + else while ( current -> l != nil ) + current = (lispval) & (current ->l ->cdr); + } + np = last; + } +done: if (join == 0)current->l = nil; + /*lbot = oldlbot;*/ + return(result->l); +} + +/* ============================ +- +- Lmapcar +- =============================*/ + +lispval +Lmapcar() +{ + snpand(0); + return(Lmapcrx(0,0)); } /* call general routine */ + + +/* ============================ +- +- +- Lmaplist +- ==============================*/ + +lispval +Lmaplist() +{ + snpand(0); + return(Lmapcrx(1,0)); } /* call general routine */ + + +/* ================================================ +- mapping functions which return the value of the last function application. +- mapc and map +- ===================================================*/ + +lispval +Lmapcx(maptyp) +int maptyp; /* 0= mapc , 1= map */ +{ + register struct argent *namptr; + register index; + register lispval temp; + register lispval result; + register struct argent *lbot; + register struct argent *np; + + int count; + struct argent *first; + lispval lists[25], errorh(); + + namptr = lbot + 1; + count = np - namptr; + if(count <= 0) return(nil); + result = lbot[1].val; /*This is what macsyma wants so ... */ + /*copy funarg for call to funcall */ + lbot = np; protect((namptr - 1)->val); + first = np; np += count; + + for(index = 0; index < count; index++) { + temp = (namptr++)->val; + while(temp!=nil && TYPE(temp)!=DTPR) + temp = errorh(Vermisc,"Inappropriate list argument to mapc",nil,TRUE,0,temp); + lists[index] = temp; + } + for(;;) { + for(namptr=first,index=0; indexval = temp->car; + else + (namptr++)->val = temp; + lists[index] = temp->cdr; + } + Lfuncal(); + } +done: + return(result); +} + + +/* ================================== +- +- mapc map the car of the lists +- +- ==================================*/ + +lispval +Lmapc() +{ return( Lmapcx(0) ); } + + +/* ================================= +- +- map map the cdr of the lists +- +- ===================================*/ + +lispval +Lmap() +{ return( Lmapcx(1) ); } + + +lispval +Lmapcan() +{ + lispval Lmapcrx(); + + return ( Lmapcrx ( 0,1 ) ); +} + +lispval +Lmapcon() +{ + lispval Lmapcrx(); + + return ( Lmapcrx ( 1,1 ) ); +} diff --git a/usr/src/cmd/lisp/lam3.c b/usr/src/cmd/lisp/lam3.c new file mode 100644 index 0000000000..c0c51bfb8d --- /dev/null +++ b/usr/src/cmd/lisp/lam3.c @@ -0,0 +1,504 @@ +# include "global.h" +lispval +Lalfalp() +{ + register lispval first, second; + register struct argent *inp; + snpand(3); /* clobber save mask */ + + chkarg(2); + inp = lbot; + first = (inp)->val; + second = (inp+1)->val; + if( (TYPE(first))!=ATOM || (TYPE(second))!=ATOM) + error("alphalessp expects atoms"); + if(strcmp(first->pname,second->pname) <= 0) + return(tatom); + else + return(nil); +} + +lispval +Lncons() +{ + register lispval handy; + snpand(1); /* clobber save mask */ + + chkarg(1); + handy = newdot(); + handy -> cdr = nil; + handy -> car = lbot->val; + return(handy); +} +lispval +Lzerop() +{ + register lispval handy; + snpand(1); /* clobber save mask */ + + chkarg(1); + handy = lbot->val; + switch(TYPE(handy)) { + case INT: + return(handy->i==0?tatom:nil); + case DOUB: + return(handy->r==0.0?tatom:nil); + } + return(nil); +} +lispval +Lonep() +{ + register lispval handy; lispval Ladd(); + snpand(1); /* clobber save mask */ + + chkarg(1); + handy = lbot->val; + switch(TYPE(handy)) { + case INT: + return(handy->i==1?tatom:nil); + case DOUB: + return(handy->r==1.0?tatom:nil); + case SDOT: + protect(inewint(0)); + handy = Ladd(); + if(TYPE(handy)!=INT || handy->i !=1) + return(nil); + else + return(tatom); + } + return(nil); +} + +lispval +cmpx(lssp) +{ + register struct argent *argp; + register struct argent *outarg; + register struct argent *handy; + register count; + register struct argent *lbot; + register struct argent *np; + struct argent *onp = np; + + + argp = lbot + 1; + outarg = np; + while(argp < onp) { + + np = outarg + 2; + lbot = outarg; + if(lssp) + *outarg = argp[-1], outarg[1] = *argp++; + else + outarg[1] = argp[-1], *outarg = *argp++; + lbot->val = Lsub(); + np = lbot + 1; + if(Lnegp()==nil) return(nil); + } + return(tatom); +} + +lispval +Lgreaterp() +{ + return(cmpx(FALSE)); +} + +lispval +Llessp() +{ + return(cmpx(TRUE)); +} + +lispval +Ldiff() +{ + register lispval arg1,arg2; register handy = 0; + snpand(3); /* clobber save mask */ + + + chkarg(2); + arg1 = lbot->val; + arg2 = (lbot+1)->val; + if(TYPE(arg1)==INT && TYPE(arg2)==INT) { + handy=arg1->i - arg2->i; + } + else error("non-numeric argument",FALSE); + return(inewint(handy)); +} + +lispval +Lmod() +{ + register lispval arg1,arg2; lispval handy; + struct sdot fake1, fake2; + fake2.CDR = 0; + fake1.CDR = 0; + snpand(2); /* clobber save mask */ + + chkarg(2); + handy = arg1 = lbot->val; + arg2 = (lbot+1)->val; + switch(TYPE(arg1)) { + case SDOT: + break; + case INT: + fake1.I = arg1->i; + arg1 =(lispval) &fake1; + break; + default: + error("non-numeric argument",FALSE); + } + switch(TYPE(arg2)) { + case SDOT: + break; + case INT: + fake2.I = arg2->i; + arg2 =(lispval) &fake2; + break; + default: + error("non-numeric argument",FALSE); + } + if(Lzerop()!=nil) return(handy); + divbig(arg1,arg2,0,&handy); + if(handy==((lispval)&fake1)) + handy = inewint(fake1.I); + if(handy==((lispval)&fake2)) + handy = inewint(fake2.I); + return(handy); + +} + + +lispval +Ladd1() +{ + register lispval handy; + lispval Ladd(); + snpand(1); /* fixup entry mask */ + + handy = rdrint; + handy->i = 1; + protect(handy); + return(Ladd()); + +} + +lispval +Lsub1() +{ + register lispval handy; + lispval Ladd(); + snpand(1); /* fixup entry mask */ + + handy = rdrint; + handy->i = - 1; + protect(handy); + return(Ladd()); +} + +lispval +Lminus() +{ + register lispval arg1, handy; + register temp; + lispval subbig(); + snpand(3); /* clobber save mask */ + + chkarg(1); + arg1 = lbot->val; + handy = nil; + switch(TYPE(arg1)) { + case INT: + handy= inewint(0 - arg1->i); + break; + case DOUB: + handy = newdoub(); + handy->r = -arg1->r; + break; + case SDOT: + handy = rdrsdot; + handy->I = 0; + handy->CDR = (lispval) 0; + handy = subbig(handy,arg1); + break; + + default: + error("non-numeric argument",FALSE); + } + return(handy); +} + +lispval +Lnegp() +{ + register lispval handy = np[-1].val, work; + register flag = 0; + snpand(3); /* clobber save mask */ + +loop: + switch(TYPE(handy)) { + case INT: + if(handy->i < 0) flag = TRUE; + break; + case DOUB: + if(handy->r < 0) flag = TRUE; + break; + case SDOT: + for(work = handy; work->CDR!=(lispval) 0; work = work->CDR); + if(work->I < 0) flag = TRUE; + break; + default: + handy = errorh(Vermisc, + "minusp: Non-(int,real,bignum) arg: ", + nil, + TRUE, + 0, + handy); + goto loop; + } + if(flag) return(tatom); + return(nil); +} + +lispval +Labsval() +{ + register lispval arg1, handy; + register temp; + snpand(3); /* clobber save mask */ + + chkarg(1); + arg1 = lbot->val; + if(Lnegp()!=nil) return(Lminus()); + + return(arg1); +} + +#include "frame.h" +/* new version of showstack, + We will set fp to point where the register fp points. + Then fp+2 = saved ap + fp+4 = saved pc + fp+3 = saved fp + ap+1 = first arg + If we find that the saved pc is somewhere in the routine eval, + then we print the first argument to that eval frame. This is done + by looking one beyond the saved ap. +*/ +lispval +Lshostk() +{ lispval isho(); + return(isho(1)); +} +static lispval +isho(f) +int f; +{ + register struct frame *myfp; register lispval handy; + int **fp; /* this must be the first local */ + int virgin=1; + lispval _qfuncl(),tynames(); /* locations in qfuncl */ + + if(f==1) + printf("Forms in evaluation:\n"); + else + printf("Backtrace:\n\n"); + + myfp = (struct frame *) (&fp +1); /* point to current frame */ + + while(TRUE) + { + if( (myfp->pc > eval && /* interpreted code */ + myfp->pc < popnames) + || + (myfp->pc > _qfuncl && /* compiled code */ + myfp->pc < tynames) ) + { + handy = (myfp->ap[1]); + if(f==1) + printr(handy,stdout), putchar('\n'); + else { + if(virgin) + virgin = 0; + else + printf(" -- "); + printr((TYPE(handy)==DTPR)?handy->car:handy,stdout); + } + + } + + if(myfp > myfp->fp) break; /* end of frames */ + else myfp = myfp->fp; + } + putchar('\n'); + return(nil); +} +lispval +Lbaktrace() +{ + isho(0); +} +/* =========================================================== +- +**** baktrace **** (moved back by kls) +- +- baktrace will print the names of all functions being evaluated +- from the current one (baktrace) down to the first one. +- currently it only prints the function name. Planned is a +- list of local variables in all stack frames. +- written by jkf. +- +-============================================================*/ + +/*============================================================= +- +-*** oblist **** +- +- oblist returns a list of all symbols in the oblist +- +- written by jkf. +============================================================*/ + +lispval +Loblist() +{ + int indx; + lispval headp, tailp ; + struct atom *symb ; + + headp = tailp = newdot(); /* allocate first DTPR */ + protect(headp); /*protect the list from garbage collection*/ + /*line added by kls */ + + for( indx=0 ; indx <= HASHTOP-1 ; indx++ ) /* though oblist */ + { + for( symb = hasht[indx] ; + symb != (struct atom *) CNIL ; + symb = symb-> hshlnk) + { + tailp->car = (lispval) symb ; /* remember this atom */ + tailp = tailp->cdr = newdot() ; /* link to next DTPR */ + } + } + + tailp->cdr = nil ; /* close the list unfortunately throwing away + the last DTPR + */ + return(headp); +} + +/* + * Maclisp setsyntax function: + * (setsyntax c s x) + * c represents character either by fixnum or atom + * s is the atom "macro" or the atom "splicing" (in which case x is the + * macro to be invoked); or nil (meaning don't change syntax of c); or + * (well thats enough for now) if s is a fixnum then we modify the bits + * for c in the readtable. + */ +#define VMAC 0316 +#define VSPL 0315 +#define VDQ 0212 +#define VESC 0217 +#include "chkrtab.h" + +lispval +Lsetsyn() +{ + register lispval s, c; + register struct argent *mynp; + register index; + register struct argent *lbot, *np; + lispval x; + extern char *ctable; + int value; + + chkarg(3); + s = Vreadtable->clb; + chkrtab(s); + mynp = lbot; + c = (mynp++)->val; + s = (mynp++)->val; + x = (mynp++)->val; + + switch(TYPE(c)) { + default: + error("neither fixnum nor atom as char to setsyntax",FALSE); + + case ATOM: + index = *(c->pname); + if((c->pname)[1])error("Only 1 char atoms to setsyntax",FALSE); + break; + + case INT: + index = c->i; + } + switch(TYPE(s)) { + case INT: + if(s->i == VESC) Xesc = (char) index; + else if(s->i == VDQ) Xdqc = (char) index; + + if(ctable[index] == VESC /* if we changed the current esc */ + && s->i != VESC /* to something else, pick current */ + && Xesc == (char) index) { + ctable[index] = s->i; + rpltab(VESC,&Xesc); + } + else if(ctable[index] == VDQ /* likewise for double quote */ + && s->i != VDQ + && Xdqc == (char) index) { + ctable[index] = s->i; + rpltab(VDQ,&Xdqc); + } + else ctable[index] = s->i; + + break; + case ATOM: + if(s==splice) + ctable[index] = VSPL; + else if(s==macro) + ctable[index] = VMAC; + if(TYPE(c)!=ATOM) { + strbuf[0] = index; + strbuf[1] = 0; + c = (getatom()); + } + Iputprop(c,x,macro); + } + return(tatom); +} + + + +/* this aux function is used by setsyntax to determine the new current + escape or double quote character. It scans the character table for + the first character with the given class (either VESC or VDQ) and + puts that character in Xesc or Xdqc (whichever is pointed to by + addr). +*/ +rpltab(cclass,addr) +char cclass; +char *addr; +{ + register int i; + extern char *ctable; + for(i=0; i<=127 && ctable[i] != cclass; i++); + if(i<=127) *addr = (char) i; + else *addr = '\0'; +} + + + +lispval +Lzapline() +{ + register FILE *port; + extern FILE * rdrport; + + port = rdrport; + while (!feof(port) && (getc(port)!='\n') ); + return(nil); +} + -- 2.20.1