├── liszt ├── tags ├── tahoe │ ├── lisprc.l │ ├── lisztrc.l │ └── Makefile ├── vax │ ├── lisprc.l │ ├── lisztrc.l │ └── Makefile ├── 68k │ ├── lisprc.l │ ├── lisztrc.l │ └── Makefile2 ├── ltags ├── lversion.l ├── Makefile ├── const.l ├── cmake.l ├── array.l └── chead.l ├── franz ├── 68k │ ├── tags │ ├── fixregs.sed │ ├── hack.s │ ├── fixbits.c │ ├── inewint.c │ ├── callg.s │ ├── exarith.c │ ├── dodiv.c │ ├── first8.c │ ├── emul.s │ ├── calqhat.c │ ├── dsmult.c │ ├── adbig.c │ ├── ediv.s │ ├── mulbig.c │ ├── nargs.c │ ├── dmlad.s │ └── mlsb.c ├── tahoe │ ├── tags │ ├── prunei.c │ ├── fixpbig.e │ ├── inewint.c │ ├── retfrom.s │ ├── callg.c │ ├── myfrexp.c │ ├── crt0.s │ ├── exarith.c │ ├── hcrt0.s │ ├── fixmask.c │ ├── dodiv.c │ ├── calqhat.s │ ├── dsmult.c │ ├── adbig.c │ ├── dmlad.s │ ├── pushframe.s │ ├── mulbig.c │ └── mlsb.c ├── vax │ ├── tags │ ├── hole.unx │ ├── crt0.s │ ├── fixpbig.e │ ├── hcrt0.s │ ├── fixmask.c │ ├── totxtfile.c │ ├── rawlisp.unx │ └── rawhlisp.unx ├── h │ ├── lconf.h │ ├── hpagsiz.h │ ├── 68kframe.h │ ├── tahoeframe.h │ ├── vaxframe.h │ ├── gc.h │ ├── chkrtab.h │ ├── gtabs.h │ ├── ltypes.h │ ├── catchfram.h │ ├── types.h │ ├── dualaout.h │ ├── structs.h │ ├── dfuncs.h │ ├── frame.h │ ├── chars.h │ ├── aout.h │ ├── lispo.h │ └── duallispo.h ├── lowaux.s ├── rlc.c ├── Makefile ├── subbig.c ├── pbignum.c ├── lamp.c ├── lisp.c ├── fpipe.c ├── fexr.c ├── lamgc.c └── trace.c ├── doc ├── indexsed ├── mantags ├── fixmks.sed ├── ch61.n ├── extrnames.awk ├── lmacs ├── ch17.n └── chc.n ├── lisplib ├── cmuenv.l ├── autorun │ ├── 68k │ ├── sun4.2 │ ├── unisoft │ ├── vax │ ├── tahoe │ └── mc500 ├── manual │ └── ch61.r ├── version.l ├── jkfmacs.l ├── fixit.ref ├── structini.l ├── ucido.l ├── syscall.l ├── buildlisp.l ├── common3.l ├── fcninfo.l ├── Makefile ├── flavorm.l └── ReadMe ├── pearl ├── ltags ├── pearlsmall.l ├── pearllib.l ├── pearlbase.l ├── inits.l ├── alias.l ├── pearlbulk.l ├── pearl.1 ├── pearl.l ├── ptags ├── Makefile ├── symord.l └── template ├── scriptcat ├── utils ├── Makefile ├── append.c ├── tackon.c └── divide.c ├── cvt.awk ├── Notice ├── ReadMe.tahoe ├── LICENSE ├── README.md └── lispconf /liszt/tags: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /franz/68k/tags: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /franz/tahoe/tags: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /franz/vax/tags: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /doc/indexsed: -------------------------------------------------------------------------------- 1 | // s//\\ / 2 | -------------------------------------------------------------------------------- /liszt/tahoe/lisprc.l: -------------------------------------------------------------------------------- 1 | (sstatus feature for-tahoe) 2 | -------------------------------------------------------------------------------- /liszt/vax/lisprc.l: -------------------------------------------------------------------------------- 1 | (sstatus feature for-vax) 2 | 3 | -------------------------------------------------------------------------------- /franz/68k/fixregs.sed: -------------------------------------------------------------------------------- 1 | /_np,/s//a2,/ 2 | /_np$/s//a2/ 3 | /_lbot/s//d3/ 4 | -------------------------------------------------------------------------------- /franz/h/lconf.h: -------------------------------------------------------------------------------- 1 | /* this file created by ../../lispconf */ 2 | #define vax_4_3 1 3 | -------------------------------------------------------------------------------- /liszt/vax/lisztrc.l: -------------------------------------------------------------------------------- 1 | (putprop 'chead nil 'version) 2 | (sstatus feature for-vax) 3 | -------------------------------------------------------------------------------- /liszt/68k/lisprc.l: -------------------------------------------------------------------------------- 1 | (sstatus feature for-68k) 2 | (sstatus feature no-global-reg) 3 | -------------------------------------------------------------------------------- /liszt/tahoe/lisztrc.l: -------------------------------------------------------------------------------- 1 | (putprop 'chead nil 'version) 2 | (sstatus feature for-tahoe) 3 | -------------------------------------------------------------------------------- /franz/lowaux.s: -------------------------------------------------------------------------------- 1 | .globl _holbeg 2 | .globl _holend 3 | .data 4 | _holbeg: 5 | _holend: 6 | -------------------------------------------------------------------------------- /doc/mantags: -------------------------------------------------------------------------------- 1 | /^\.Lf/ { print $2, FILENAME, "?^\.Lf " $2 "?" } 2 | /^\.Lx/ { print $2, FILENAME, "?^\.Lx " $2 "?" } 3 | -------------------------------------------------------------------------------- /liszt/ltags: -------------------------------------------------------------------------------- 1 | /^\(DEF/ { print $2 " " FILENAME " /^" $0 "$/" } 2 | /^\(def/ { print $2 " " FILENAME " /^" $0 "$/" } 3 | -------------------------------------------------------------------------------- /liszt/68k/lisztrc.l: -------------------------------------------------------------------------------- 1 | (putprop 'chead nil 'version) 2 | (sstatus feature for-68k) 3 | (sstatus feature no-global-reg) 4 | -------------------------------------------------------------------------------- /franz/vax/hole.unx: -------------------------------------------------------------------------------- 1 | .PSECT $$$$$$$$$$HOLE,LONG,PIC,USR,CON,REL,LCL,NOSHR,EXE,RD,WRT 2 | holbeg:: .BLKB %d 3 | holend:: 4 | .END 5 | -------------------------------------------------------------------------------- /doc/fixmks.sed: -------------------------------------------------------------------------------- 1 | / MK/s/// 2 | /"/s///g 3 | /,/s// /g 4 | /;.*/s/// 5 | /\\(pl/s//+/ 6 | /\\(mi/s//-/ 7 | /\\(\*\*/s//*/ 8 | /\\(eq/s//=/ 9 | 10 | -------------------------------------------------------------------------------- /franz/h/hpagsiz.h: -------------------------------------------------------------------------------- 1 | #define NBPG 512 2 | #define PGOFSET 511 3 | #define CLSIZE 2 4 | #define CLOFSET 1023 5 | #define PAGSIZ 512 6 | #define PAGRND ((PAGSIZ)-1) 7 | -------------------------------------------------------------------------------- /doc/ch61.n: -------------------------------------------------------------------------------- 1 | ." %W% %G% 2 | .Lc "Local functions" 61 3 | .pp 4 | This chapter describes functions which we found 5 | useful at Berkeley. 6 | Some of these functions may be useful at other sites 7 | -------------------------------------------------------------------------------- /doc/extrnames.awk: -------------------------------------------------------------------------------- 1 | BEGIN { print "(Doc)" } 2 | /^\.Lf/ { print "(" $2 " " substr(FILENAME,1,length(FILENAME)-2) ")" } 3 | /^\.Lx/ { print "(" $2 " " substr(FILENAME,1,length(FILENAME)-2) ")" } 4 | -------------------------------------------------------------------------------- /lisplib/cmuenv.l: -------------------------------------------------------------------------------- 1 | (setq rcs-cmuenv- 2 | "$Header: /usr/lib/lisp/cmuenv.l,v 1.1 83/01/29 18:33:54 jkf Exp $") 3 | 4 | (load 'cmumacs) 5 | (load 'cmufncs) 6 | (load 'cmutpl) 7 | (load 'cmufile) 8 | -------------------------------------------------------------------------------- /franz/h/68kframe.h: -------------------------------------------------------------------------------- 1 | /* 2 | * $Header: 68kframe.h,v 1.3 84/02/29 12:43:22 sklower Exp $ 3 | * $Locker: $ 4 | * machine stack frame 5 | */ 6 | struct machframe { 7 | struct machframe *fp; 8 | lispval (*pc)(); 9 | lispval ap[1]; 10 | }; 11 | -------------------------------------------------------------------------------- /franz/h/tahoeframe.h: -------------------------------------------------------------------------------- 1 | /* not used - just to look at I guess */ 2 | 3 | #define FRAMOFFSET (-8) /* FP points to frame + 8 */ 4 | 5 | struct machframe 6 | { 7 | lispval (*pc)(); 8 | short mask; 9 | short removed; 10 | struct machframe *fp; 11 | lispval *arg[2]; 12 | }; 13 | -------------------------------------------------------------------------------- /franz/68k/hack.s: -------------------------------------------------------------------------------- 1 | | /* Copyright (c) 1982, Regents, University of California */ 2 | .text 3 | .globl _stack 4 | _stack: 5 | movl sp@,a0 6 | jmp a0@ 7 | .globl _unstack 8 | _unstack: 9 | movl sp@+,a0 10 | movl sp@+,d0 11 | jmp a0@ 12 | .globl _sp 13 | _sp: 14 | movl sp@+,a0 15 | movl sp,d0 16 | jmp a0@ 17 | -------------------------------------------------------------------------------- /franz/tahoe/prunei.c: -------------------------------------------------------------------------------- 1 | #include "global.h" 2 | #include "structs.h" 3 | 4 | prunei(what) 5 | register lispval what; 6 | { 7 | extern struct types int_str; 8 | int gstart(); 9 | 10 | if(((long)what) > ((long) gstart)) { 11 | --(int_items->i); 12 | what->i = (long) int_str.next_free; 13 | int_str.next_free = (char *) what; 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /franz/68k/fixbits.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | fixbits(from,to) 3 | register char *from, *to; 4 | { 5 | register char save; 6 | 7 | while(from <= to) { 8 | save = from[3]; 9 | from[3] = from[0]; 10 | from[0] = save; 11 | save = from[2]; 12 | from[2] = from[1]; 13 | from[1] = save; 14 | from += 4; 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /franz/tahoe/fixpbig.e: -------------------------------------------------------------------------------- 1 | /callf $[0-9]*,_stack/d 2 | /callf $4,_unstack/s//movl (sp)+,r0/ 3 | /callf $4,_sp/s//moval (sp),r0/ 4 | /callf $4,_nargs/s//movl -2(fp),r0\ 5 | cvtwl r0,r0\ 6 | subl2 $4,r0\ 7 | shrl $2,r0,r0/ 8 | /\*_np\([ , ]\)/s//(r6)\1/g 9 | /\*_lbot\([ , ]\)/s//(r7)\1/g 10 | /_np\([ , ]\)/s//r6\1/g 11 | /_lbot\([ , ]\)/s//r7\1/g 12 | /\*_np$/s//(r6)/g 13 | /\*_lbot$/s//(r7)/g 14 | /_np$/s//r6/g 15 | /_lbot$/s//r7/g 16 | -------------------------------------------------------------------------------- /franz/68k/inewint.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | 3 | extern int Fixzero[]; 4 | int *inewint(n) 5 | { 6 | register int *ip; 7 | int *newint(); 8 | if(n < 1024 && n >= -1024) return (Fixzero+n); 9 | ip = newint(); 10 | *ip = n; 11 | return(ip); 12 | } 13 | blzero(where,howmuch) 14 | register char *where; 15 | { 16 | register char *p; 17 | for(p = where + howmuch; p > where; ) *--p = 0; 18 | } 19 | -------------------------------------------------------------------------------- /lisplib/autorun/68k: -------------------------------------------------------------------------------- 1 | "start:movl sp@,d2 2 | lea sp@(4),a3 3 | movl d2,d1 4 | asll #2,d1 5 | lea a3@(4,d1:l),a4 6 | movl #flag+0x8000,a3@- 7 | movl #lisp+0x8000,a3@- 8 | movl a3,sp 9 | pea a4@ 10 | pea a3@ 11 | movl #lisp+0x8000,sp@- 12 | jsr execve 13 | execve: pea 0x3b:w 14 | trap #0 15 | addw #12,a7 16 | pea 0:w 17 | jsr _exit 18 | _exit: pea 1:w 19 | trap #0 20 | flag: .asciz \"-f\" 21 | lisp: .asciz \"/usr/ucb/lisp\" 22 | .even 23 | " 24 | -------------------------------------------------------------------------------- /franz/tahoe/inewint.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | 3 | extern int Fixzero[]; 4 | 5 | int *inewint(n) 6 | { 7 | register int *ip; 8 | int *newint(); 9 | if(n < 1024 && n >= -1024) return (Fixzero+n); 10 | ip = newint(); 11 | *ip = n; 12 | return(ip); 13 | } 14 | blzero(where,howmuch) 15 | register char *where; 16 | { 17 | register char *p; 18 | for(p = where + howmuch; p > where; ) *--p = 0; 19 | } 20 | -------------------------------------------------------------------------------- /lisplib/autorun/sun4.2: -------------------------------------------------------------------------------- 1 | "start:movl sp@,d2 2 | lea sp@(4),a3 3 | movl d2,d1 4 | asll #2,d1 5 | lea a3@(4,d1:l),a4 6 | movl #flag+0x8000,a3@- 7 | movl #lisp+0x8000,a3@- 8 | movl a3,sp 9 | pea a4@ 10 | pea a3@ 11 | movl #lisp+0x8000,sp@- 12 | jsr execve 13 | execve: pea 0x3b:w 14 | trap #0 15 | addw #12,a7 16 | pea 0:w 17 | jsr _exit 18 | _exit: pea 1:w 19 | trap #0 20 | flag: .asciz \"-f\" 21 | lisp: .asciz \"/usr/ucb/lisp\" 22 | .even 23 | " 24 | -------------------------------------------------------------------------------- /franz/h/vaxframe.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 14:02:34 1983 by jkf]- 2 | * vaxframe.h $Locker: $ 3 | * vax calling frame definition 4 | * 5 | * $Header: vaxframe.h,v 1.3 84/02/29 15:06:57 sklower Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | struct machframe { 11 | lispval (*handler)(); 12 | long mask; 13 | lispval *ap; 14 | struct machframe *fp; 15 | lispval (*pc)(); 16 | lispval *r6; 17 | lispval *r7; 18 | }; 19 | -------------------------------------------------------------------------------- /franz/h/gc.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 13:56:06 1983 by jkf]- 2 | * gc.h $Locker: $ 3 | * garbage collector metering definitions 4 | * 5 | * $Header: gc.h,v 1.1 83/01/29 14:06:15 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | struct gchead 11 | { int version; /* version number of this dump file */ 12 | int lowdata; /* low address of sharable lisp data */ 13 | int dummy,dummy2,dummy3; /* to be used later */ 14 | }; 15 | 16 | -------------------------------------------------------------------------------- /franz/h/chkrtab.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 13:53:19 1983 by jkf]- 2 | * chkrtab.h $Locker: $ 3 | * check if read table valid 4 | * 5 | * $Header: /na/franz/franz/h/chkrtab.h,v 1.1 83/01/29 14:05:24 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | #define chkrtab(p); \ 11 | if(p!=lastrtab){ if(TYPE(p)!=ARRAY && TYPE(p->ar.data)!=INT) rtaberr();\ 12 | else {lastrtab=p;ctable=(unsigned char*)p->ar.data;}} 13 | extern lispval lastrtab; 14 | -------------------------------------------------------------------------------- /franz/tahoe/retfrom.s: -------------------------------------------------------------------------------- 1 | # this file is here because some necessary register moves were 2 | # being optimized away. 3 | .text 4 | LL0: .align 1 5 | .globl _Iretfromfr 6 | .set L136,0x1000 7 | .text 8 | _Iretfromfr:.word L136 9 | movl 4(fp),r12 10 | pushl 8(r12) 11 | callf $8,_xpopnames 12 | movl r12,r0 13 | subl3 $24,r12,sp 14 | movl (sp),r8 15 | movl 4(sp),r9 16 | movl 8(sp),r10 17 | movl 12(sp),r11 18 | movl 16(sp),r12 19 | movl 20(sp),r13 20 | movl 24(sp),r7 21 | movl 28(sp),r6 22 | jmp *40(sp) 23 | 24 | -------------------------------------------------------------------------------- /franz/tahoe/callg.c: -------------------------------------------------------------------------------- 1 | /* 2 | * callg_ - call with 'general' argument list for CCI `tahoe' 3 | * 4 | * by P. S. Housel 04/30/86 5 | * 6 | */ 7 | 8 | callg_(funct, arglist) 9 | register int (*funct)(); /* r12 */ 10 | register int *arglist; /* r11 */ 11 | { 12 | register int *argptr, n; /* r10, r9 */ 13 | 14 | n = (*arglist + 1) * 4; 15 | 16 | argptr = arglist + *arglist; 17 | 18 | while(argptr > arglist) 19 | {asm("pushl (r10)"); 20 | argptr--; 21 | } 22 | 23 | asm(" calls r9,(r12)"); 24 | } 25 | -------------------------------------------------------------------------------- /pearl/ltags: -------------------------------------------------------------------------------- 1 | /^\(de / { print $2 " " FILENAME " /^" $0 "$/" } 2 | /^\(df / { print $2 " " FILENAME " /^" $0 "$/" } 3 | /^\(dm / { print $2 " " FILENAME " /^" $0 "$/" } 4 | /^\(drm / { print $2 " " FILENAME " /^" $0 "$/" } 5 | /^\(dsm / { print $2 " " FILENAME " /^" $0 "$/" } 6 | /^\(def/ { print $2 " " FILENAME " /^" $0 "$/" } 7 | /^\(putd / { print $2 " " FILENAME " /^" $0 "$/" } 8 | /^\(setsyntax / { print $2 " " FILENAME " /^" $0 "$/" } 9 | /^\(setq / { print $2 " " FILENAME " /^" $0 "$/" } 10 | /^\(aliasdef / { print $2 " " FILENAME " /^" $0 "$/" } 11 | -------------------------------------------------------------------------------- /franz/h/gtabs.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 13:57:36 1983 by jkf]- 2 | * gtabs.h $Locker: $ 3 | * global lispval table 4 | * 5 | * $Header: /na/franz/franz/h/gtabs.h,v 1.1 83/01/29 14:06:37 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | /* these are the tables of global lispvals known to the interpreter */ 11 | /* and compiler. They are not used by the garbage collector. */ 12 | #define GFTABLEN 200 13 | #define GCTABLEN 8 14 | extern lispval gftab[GFTABLEN]; 15 | extern lispval gctab[GCTABLEN]; 16 | -------------------------------------------------------------------------------- /pearl/pearlsmall.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; pearlsmall.l ;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; This file loads the two halves of PEARL when it is compiled in 3 | ; two pieces on a machine with small memory and/or tempfile space. 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ; Copyright (c) 1983 , The Regents of the University of California. 6 | ; All rights reserved. 7 | ; Authors: Joseph Faletti and Michael Deering. 8 | 9 | (eval-when (load) 10 | (fasl 'pearlbase.o) 11 | (fasl 'pearlbulk.o)) 12 | 13 | ; vi: set lisp: 14 | -------------------------------------------------------------------------------- /franz/68k/callg.s: -------------------------------------------------------------------------------- 1 | | /* Copyright (c) 1982, Regents, University of California */ 2 | .text 3 | .globl _callg_ 4 | _callg_: 5 | link a6,#0 6 | movl a6@(12),a0 7 | movl sp,a1 8 | movl a0@+,d0 9 | asll #2,d0 10 | subl d0,a1 11 | tstb a1@ 12 | movl a1,sp 13 | .L13: 14 | subql #4,d0 15 | blt .L14 16 | movl a0@+,a1@+ 17 | bra .L13 18 | .L14: 19 | movl a6@(8),a0 20 | jsr a0@ 21 | unlk a6 22 | rts 23 | -------------------------------------------------------------------------------- /scriptcat: -------------------------------------------------------------------------------- 1 | #!/bin/csh 2 | # shell script which is given arguments 3 | # sourcedir destdir file1 file2 ... filen 4 | # it generates a shell command to create those files based on 5 | # the text that follows the command. 6 | # the code will come from sourcedir/filei, it will go to 7 | # destdir/filei when extracted 8 | # 9 | set sourcedir=$argv[1] 10 | shift argv 11 | set destdir=$argv[1] 12 | unset time 13 | while ($#argv > 1) 14 | shift argv 15 | echo "cat > " $destdir/$argv[1] " << 'EndOfFile'" 16 | cat $sourcedir/$argv[1] 17 | echo EndOfFile 18 | end 19 | -------------------------------------------------------------------------------- /lisplib/manual/ch61.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | CHAPTER 61 9 | 10 | 11 | Local 12 | 13 | 14 | 15 | 16 | This chapter describes functions which we found useful 17 | at Berkeley. Some of these functions may be useful at other 18 | sites 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 9 61 | 62 | 9Local 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /pearl/pearllib.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; pearllib.l ;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; This file loads the two halves of PEARL from /usr/lib/lisp when it 3 | ; was compiled in two pieces on a machine with small memory 4 | ; and/or tempfile space. It is renamed "pearl.o" in /usr/lib/lisp. 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ; Copyright (c) 1983 , The Regents of the University of California. 7 | ; All rights reserved. 8 | ; Authors: Joseph Faletti and Michael Deering. 9 | 10 | (eval-when (load) 11 | (fasl '/usr/lib/lisp/pearlbase.o) 12 | (fasl '/usr/lib/lisp/pearlbulk.o)) 13 | 14 | ; vi: set lisp: 15 | -------------------------------------------------------------------------------- /lisplib/version.l: -------------------------------------------------------------------------------- 1 | ;; version.l 2 | ;; -[ Wed May 22 09:30:58 PDT 1985 by sklower]- 3 | ;; 4 | ;; This file is edited after every modification is made to the 5 | ;; lisp system. 6 | ;; Variables defined: 7 | ;; this-lisp-version-built: a symbols whose pname is the date when 8 | ;; the lisp system was build. People who care about such things 9 | ;; can have their .lisprc file print it out at startup 10 | ;; franz-minor-version-number. This is printed after the opus number 11 | ;; upon startup. It is incremented after each fix or feature addition 12 | ;; 13 | 14 | (setq this-lisp-version-built (status ctime) 15 | franz-minor-version-number ".92") 16 | -------------------------------------------------------------------------------- /franz/tahoe/myfrexp.c: -------------------------------------------------------------------------------- 1 | /* file: myfrexp.c 2 | ** functions: myfrexp() 3 | ** origins: 68k.c 4 | ** comments: this looks like a lame way out to me but *I* certainly don't 5 | ** want to write a version of this routine for any processor. 6 | */ 7 | 8 | #include "global.h" 9 | 10 | myfrexp() 11 | {error("myfrexp called", FALSE); 12 | } 13 | 14 | 15 | /* 16 | ** Comment from bigmath.c: 17 | ** 18 | ** myfrexp (value, exp, hi, lo) 19 | ** double value; 20 | ** int *exp, *hi, *lo; 21 | ** 22 | ** myfrexp returns three values, exp, hi, lo, 23 | ** Such that value = 2**exp*tmp, where tmp = (hi*2**-23+lo*2**-53) 24 | ** is uniquely determined subect to .5< abs(tmp) <= 1.0 25 | ** 26 | */ 27 | -------------------------------------------------------------------------------- /lisplib/autorun/unisoft: -------------------------------------------------------------------------------- 1 | ; $Header: unisoft 1.2 83/07/25 11:39:17 layer Exp $ 2 | 3 | " 4 | OFFSET = 0xOFF 5 | start: movl a7@(4),a0 6 | clrl a0@(-4) 7 | movl a7,a0 8 | subql #0x8,a7 9 | movl a0@,a7@ 10 | addql #0x4,a0 11 | movl a0,a7@(4) 12 | LL0: tstl a0@+ 13 | bnes LL0 14 | movl a7@(4),a1 15 | cmpl a1@,a0 16 | blts LL1 17 | subql #0x4,a0 18 | LL1: movl a0,a7@(8) 19 | movl a0,a1 20 | movl #OFFSET+file,a2 21 | movl a2,sp@(4) | setup new argv[0] 22 | movl a2,a0 | file to execute 23 | movl #OFFSET+flag,a2 24 | movl a2,sp@(8) | setup new argv[1] 25 | lea sp@(4),a2 26 | movl a2,d1 27 | movw #0x3B,d0 28 | trap #0x0 29 | file: .asciz \"/usr/ucb/lisp\" 30 | flag: .asciz \"-f\" 31 | .even 32 | " 33 | -------------------------------------------------------------------------------- /liszt/lversion.l: -------------------------------------------------------------------------------- 1 | ;; lversion.l 2 | ;; -[Tue Nov 22 08:56:16 1983 by jkf]- 3 | ;; 4 | ;; this defines this symbols: 5 | ;; this-liszt-version-built: ctime string which tells when this liszt 6 | ;; was built. 7 | ;; compiler-name: the banner printed out when liszt starts up 8 | 9 | ;; this file is not sccsed because it only contains version number 10 | ;; information. 11 | 12 | (setq this-liszt-version-built (status ctime)) 13 | 14 | (setq compiler-name 15 | (concat "Liszt " 16 | #.(cond ((status feature for-vax) "vax") 17 | ((status feature for-tahoe) "CCI tahoe") 18 | ((status feature for-68k) "68000") 19 | (t "(unknown machine)")) 20 | " version 8.39a")) 21 | -------------------------------------------------------------------------------- /lisplib/jkfmacs.l: -------------------------------------------------------------------------------- 1 | (setq SCCS-jkfmacs "%Z%%M% %I% %G%") 2 | 3 | ;------ jkfmacs :: common and useful macros 4 | ; 5 | ;; as of Franz opus 38.36 all the macros in this file all available in 6 | ;; the standard lisp system, so there is no reason to load this file. 7 | ;; 8 | 9 | (msg "message from jkfmacs: " N 10 | "All the macros in this file are now available in the default franz." N 11 | "Thus you should not be loading jkfmacs." N 12 | "One warning: the order of the arguments is different in the version " N 13 | "of the push macro in the default franz. it is now (push val stack) " N 14 | "You should check your code " N 15 | "Also, there isn't an 'unpush' macro any more " N) 16 | -------------------------------------------------------------------------------- /franz/vax/crt0.s: -------------------------------------------------------------------------------- 1 | # C runtime startoff 2 | # $Header: /na/franz/franz/vax/RCS/crt0.s,v 1.1 83/03/27 18:39:57 jkf Exp $ 3 | 4 | .set exit,1 5 | .globl _exit 6 | .globl start 7 | .globl _main 8 | .globl _environ 9 | 10 | start: 11 | .word 0x0000 12 | subl2 $8,sp 13 | movl 8(sp),(sp) # argc 14 | movab 12(sp),r0 15 | movl r0,4(sp) # argv 16 | L1: 17 | tstl (r0)+ # null args term ? 18 | bneq L1 19 | cmpl r0,*4(sp) # end of 'env' or 'argv' ? 20 | blss L2 21 | tstl -(r0) # envp's are in list 22 | L2: 23 | movl r0,8(sp) # env 24 | # movl r0,_environ # indir is 0 if no env ; not 0 if env 25 | calls $3,_main 26 | pushl r0 27 | calls $1,_exit 28 | chmk $exit 29 | .data 30 | _environ: .space 4 31 | -------------------------------------------------------------------------------- /franz/vax/fixpbig.e: -------------------------------------------------------------------------------- 1 | /calls $[0-9]*,_stack/d 2 | /calls $0,_unstack/s//movl (sp)+,r0/ 3 | /calls $0,_sp/s//movl sp,r0/ 4 | /calls $1,_inewint/s//movl (sp)+,r5\ 5 | jsb _qnewint/ 6 | /calls $0,_newdot/s//jsb _qnewdot/ 7 | /calls $0,_nargs/s//movl (ap),r0/ 8 | /calls $1,_popname/s//jsb _qpopname/ 9 | /calls $5,_exarith/s//jsb _qexarith/ 10 | /calls $1,_prunei/s//jsb _qprunei/ 11 | /calls $1,_pruneb/s//jsb _qpruneb/ 12 | /calls $0,_qretfromfr/s//jsb _qretfromfr/ 13 | /calls $[123],_Pushframe/s//jsb _qpushframe/ 14 | /\*_np\([ , ]\)/s//(r6)\1/g 15 | /\*_lbot\([ , ]\)/s//(r7)\1/g 16 | /_np\([ , ]\)/s//r6\1/g 17 | /_lbot\([ , ]\)/s//r7\1/g 18 | /\*_np$/s//(r6)/g 19 | /\*_lbot$/s//(r7)/g 20 | /_np$/s//r6/g 21 | /_lbot$/s//r7/g 22 | -------------------------------------------------------------------------------- /lisplib/autorun/vax: -------------------------------------------------------------------------------- 1 | ; $Header: vaxsoft 1.1 83/07/25 11:35:52 layer Exp $ 2 | 3 | ".set exit,1 4 | .word 0x0000 5 | subl2 $8,sp 6 | movl 8(sp),(sp) # argc 7 | movab 12(sp),r0 8 | movl r0,4(sp) # argv 9 | QL1: 10 | tstl (r0)+ # null args term ? 11 | bneq QL1 12 | cmpl r0,*4(sp) # end of 'env' or 'argv' ? 13 | blss QL2 14 | tstl -(r0) # envp's are in list 15 | QL2: 16 | movab dr,8(sp) 17 | movab ln,4(sp) 18 | movab 4(sp),r1 19 | movl sp,r2 20 | pushl r0 #stack environment 21 | pushl r1 22 | pushab ln 23 | calls $3,_execve 24 | chmk $exit 25 | ln: 26 | " 27 | ".asciz \"/usr/ucb/lisp\" 28 | dr: 29 | .asciz \"-f\" 30 | .set exece,59 31 | _execve: 32 | .word 0x0000 33 | chmk $exece 34 | chmk $exit 35 | ret 36 | " 37 | -------------------------------------------------------------------------------- /lisplib/autorun/tahoe: -------------------------------------------------------------------------------- 1 | ".set exit,1 2 | .word 0x0000 3 | movab -8(sp),sp 4 | movl 8(sp),(sp) # argc 5 | movab 12(sp),r0 6 | movl r0,4(sp) # argv 7 | brb QL3 8 | QL1: 9 | addl2 $4,r0 10 | QL3: 11 | tstl (r0) # null args term ? 12 | bneq QL1 13 | addl2 $4,r0 14 | cmpl r0,*4(sp) # end of 'env' or 'argv' ? 15 | blss QL2 16 | subl2 $4,r0 17 | tstl (r0) # envp's are in list 18 | QL2: 19 | movab dr,8(sp) 20 | movab ln,4(sp) 21 | movab 4(sp),r1 22 | movab (sp),r2 23 | pushl r0 #stack environment 24 | pushl r1 25 | pushab ln 26 | callf $16,_execve 27 | kcall $exit 28 | ln: 29 | " 30 | ".asciz \"/usr/ucb/lisp\" 31 | dr: 32 | .asciz \"-f\" 33 | .set exece,59 34 | _execve: 35 | .word 0x0000 36 | kcall $exece 37 | kcall $exit 38 | ret 39 | " 40 | -------------------------------------------------------------------------------- /franz/rlc.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: rlc.c,v 1.5 87/12/14 17:19:20 sklower Exp $"; 4 | #endif 5 | 6 | /* -[Sat Jan 29 13:32:26 1983 by jkf]- 7 | * rlc.c $Locker: $ 8 | * relocator for data space 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | #define TRUE 1 14 | #include "h/global.h" 15 | #if vax_4_2 | vax_4_3 | tahoe_4_3 16 | #define brk(p) syscall(17,p) 17 | #endif 18 | extern char holend[], end[]; 19 | extern int usehole; 20 | extern char *curhbeg; 21 | 22 | rlc() 23 | { 24 | char *cp, *dp; 25 | 26 | brk(end); 27 | dp = holend; 28 | cp = dp - HOLE; 29 | while (dp < end) 30 | *dp++ = *cp++; 31 | curhbeg = holend - HOLE; /* set up the hole */ 32 | usehole = TRUE; 33 | } 34 | -------------------------------------------------------------------------------- /franz/h/ltypes.h: -------------------------------------------------------------------------------- 1 | /* -[Fri Mar 4 12:11:36 1983 by jkf]- 2 | * ltypes.h $Locker: $ 3 | * lisp data type defs 4 | * 5 | * $Header: ltypes.h,v 1.2 83/03/04 12:30:22 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | /* type flags */ 11 | 12 | #define UNBO -1 13 | #define STRNG 0 14 | #define ATOM 1 15 | #define INT 2 16 | #define DTPR 3 17 | #define DOUB 4 18 | #define BCD 5 19 | #define PORT 6 20 | #define ARRAY 7 21 | #define OTHER 8 22 | #define SDOT 9 23 | #define VALUE 10 24 | 25 | #define HUNK2 11 /* The hunks */ 26 | #define HUNK4 12 27 | #define HUNK8 13 28 | #define HUNK16 14 29 | #define HUNK32 15 30 | #define HUNK64 16 31 | #define HUNK128 17 32 | 33 | #define VECTOR 18 34 | #define VECTORI 19 35 | 36 | -------------------------------------------------------------------------------- /franz/68k/exarith.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | struct vl { long high; long low; }; 3 | 4 | /* 5 | * $Header $ 6 | * exarith(mul1,mul2,add,hi,lo) 7 | * 8 | * (hi,lo) gets 64 bit product + sum of mul1*mul2+add; 9 | * routine returns non-zero if product is bigger than 30 bits 10 | */ 11 | 12 | long exarith(mul1,mul2,add,hi,lo) 13 | long *hi, *lo; 14 | register long add; 15 | { 16 | struct vl work; 17 | register long rlo; 18 | 19 | emul(mul1,mul2,add,&work); 20 | add = work.high; 21 | add <<= 2; 22 | if((rlo = work.low) < 0) add += 2; 23 | if(rlo & 0x40000000) add += 1; 24 | *lo = rlo &0x3fffffff; 25 | (*hi = add); 26 | if((add==0) || (add!=-1)) return(add); 27 | *lo = rlo; 28 | return(0); 29 | } 30 | -------------------------------------------------------------------------------- /utils/Makefile: -------------------------------------------------------------------------------- 1 | # $Header: /usr/src/local/franz/utils/RCS/Makefile,v 1.3 88/10/14 14:25:41 sklower Exp $ 2 | # $Locker: $ 3 | 4 | LibDir = /usr/lib/lisp 5 | AllSrc = Makefile append.c tackon.c divide.c 6 | 7 | AllObj = ${LibDir}/append ${LibDir}/tackon ${LibDir}/divide 8 | 9 | all: ${LibDir}/append ${LibDir}/tackon ${LibDir}/divide 10 | 11 | ${LibDir}/append: append.c 12 | cc -O -o ${LibDir}/append -I../franz/h append.c 13 | 14 | ${LibDir}/tackon: tackon.c 15 | cc -O -o ${LibDir}/tackon -I../franz/h tackon.c 16 | 17 | ${LibDir}/divide: divide.c 18 | cc -O -o ${LibDir}/divide -I../franz/h divide.c 19 | 20 | copysource: ${AllSrc} 21 | (tar cf - ${AllSrc} | (cd ${CopyTo} ; tar xf -)) 22 | 23 | 24 | scriptcatall: ${AllSrc} 25 | @../scriptcat . utils ${AllSrc} 26 | 27 | 28 | clean: 29 | rm ${AllObj} 30 | -------------------------------------------------------------------------------- /franz/tahoe/crt0.s: -------------------------------------------------------------------------------- 1 | # @(#)crt0.s 4.1 (Berkeley) 12/21/80 2 | # C runtime startoff 3 | # TAHOE 3/83 4 | 5 | .set exit,1 6 | .globl _exit 7 | .globl start 8 | .globl _main 9 | .globl _environ 10 | 11 | # 12 | # C language startup routine 13 | 14 | start: 15 | .word 0x0000 16 | movab -8(sp),sp 17 | movl 8(sp),(sp) # argc 18 | movab 12(sp),r0 19 | movl r0,4(sp) # argv 20 | jmp L3 21 | L1: 22 | addl2 $4,r0 23 | L3: 24 | tstl (r0) # null args term ? 25 | jneq L1 26 | addl2 $4,r0 27 | cmpl r0,*4(sp) # end of 'env' or 'argv' ? 28 | jlss L2 29 | subl2 $4,r0 # envp's are in list 30 | L2: 31 | movl r0,8(sp) # env 32 | movl r0,_environ # indir is 0 if no env ; not 0 if env 33 | callf $4*3+4,_main 34 | pushl r0 35 | callf $4*1+4,_exit 36 | kcall $exit 37 | # 38 | .data 39 | _environ: .space 4 40 | -------------------------------------------------------------------------------- /franz/h/catchfram.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 13:56:53 1983 by jkf]- 2 | * catchfram.h $Locker: $ 3 | * catch frame definition 4 | * 5 | * $Header: /na/franz/franz/h/catchfram.h,v 1.1 83/01/29 14:02:54 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | struct catchfr { /* catch and errset frame */ 11 | struct catchfr *link; /* link to next catchframe */ 12 | lispval flag; /* Do we print ? */ 13 | lispval labl; /* label caught at this point */ 14 | struct nament *svbnp; /* saved bnp */ 15 | lispval retenv[11]; /* reset environment - actually a savblock */ 16 | lispval rs[4]; /* regis 6-11 and 13 */ 17 | lispval (*retadr)(); /* address to continue execution */ 18 | }; 19 | 20 | struct savblock { 21 | lispval envir[10]; 22 | struct savblock *savlnk; 23 | }; 24 | -------------------------------------------------------------------------------- /franz/h/types.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 14:01:58 1983 by jkf]- 2 | * types.h $Locker: $ 3 | * Unix standard type definitions 4 | * 5 | * $Header: /na/franz/franz/h/types.h,v 1.1 83/01/29 14:07:57 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | typedef struct { int rrr[1]; } * physadr; 11 | typedef long daddr_t; 12 | typedef char * caddr_t; 13 | typedef unsigned short ino_t; 14 | typedef long time_t; 15 | typedef int label_t[10]; 16 | typedef short dev_t; 17 | typedef long off_t; 18 | # ifdef UNIXTS 19 | typedef unsigned short ushort; 20 | # endif 21 | /* major part of a device */ 22 | #define major(x) (int)(((unsigned)x>>8)&0377) 23 | 24 | /* minor part of a device */ 25 | #define minor(x) (int)(x&0377) 26 | 27 | /* make a device number */ 28 | #define makedev(x,y) (dev_t)(((x)<<8) | (y)) 29 | -------------------------------------------------------------------------------- /cvt.awk: -------------------------------------------------------------------------------- 1 | 2 | { if(begin != 1) 3 | { if($1 != "") flags[$1] = "on" 4 | if($2 != "") flags[$2] = "on" 5 | if($3 != "") flags[$3] = "on" 6 | if($4 != "") flags[$4] = "on" 7 | if($5 != "") flags[$5] = "on" 8 | skip = 0 9 | begin = 1 10 | next } } 11 | /#ifdef/||/#elseif/ { if (flags[$2] != "") skip = -1; else skip = 1 12 | print $0 13 | next } 14 | /#ifndef/ { if (flags[$2] != "") skip = 1; else skip = -1 15 | print $0 16 | next } 17 | /#else/ { skip = -skip; print $0; next} 18 | /#endif/ { skip = 0 ; print $0; next} 19 | { if(skip > 0) 20 | { if(substr($0,1,1) != "#") print "#" $0; else print $0; 21 | next }} 22 | { if(skip < 0) 23 | { if(substr($0,1,1) == "#") 24 | print substr($0,2,length($0)-1) 25 | else print $0 26 | next }} 27 | { print $0 } 28 | 29 | 30 | -------------------------------------------------------------------------------- /franz/68k/dodiv.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | 3 | struct sdot { long I; struct sdot *CDR; }; 4 | struct vl { long high; long low; }; 5 | 6 | long dodiv(top,bottom) 7 | long *top, *bottom; /* top least significant; bottom most */ 8 | { 9 | struct vl work; 10 | char error; 11 | long rem = 0, ediv(); 12 | register long *p = bottom; 13 | 14 | for(;p <= top;p++) 15 | { 16 | emul(0x40000000,rem,*p,&work); 17 | *p = ediv(&work,1000000000,&error); 18 | rem = work.high; 19 | } 20 | return(rem); 21 | } 22 | 23 | long dsneg(top,bottom) 24 | long *top, *bottom; 25 | { 26 | register long *p = top; 27 | register carry = 0; 28 | register digit; 29 | 30 | while(p >= bottom) 31 | { 32 | digit = carry - *p; 33 | /* carry = digit >> 30; is slow on 68K */ 34 | if(digit < 0) carry = -2; 35 | if(digit & 0x40000000) carry += 1; 36 | *p-- = digit & 0x3fffffff; 37 | } 38 | } 39 | 40 | 41 | -------------------------------------------------------------------------------- /franz/vax/hcrt0.s: -------------------------------------------------------------------------------- 1 | # C runtime startoff 2 | # $Header: /na/franz/franz/vax/RCS/hcrt0.s,v 1.1 83/03/27 18:40:07 jkf Exp $ 3 | 4 | .set exit,1 5 | .globl _exit 6 | .globl start 7 | .globl hstart 8 | .globl _main 9 | .globl _environ 10 | 11 | # 12 | # C language startup routine 13 | 14 | hstart: 15 | .word 0x0000 16 | movl $1,r1 17 | jbr L0 18 | start: 19 | .word 0x0000 20 | clrl r1 21 | L0: 22 | subl2 $8,sp 23 | movl 8(sp),(sp) # argc 24 | movab 12(sp),r0 25 | movl r0,4(sp) # argv 26 | L1: 27 | tstl (r0)+ # null args term ? 28 | bneq L1 29 | cmpl r0,*4(sp) # end of 'env' or 'argv' ? 30 | blss L2 31 | tstl -(r0) # envp's are in list 32 | L2: 33 | movl r0,8(sp) # env 34 | movl r0,r10 # indir is 0 if no env ; not 0 if env 35 | tstl r1 36 | beql L3 37 | calls $0,_rlc 38 | L3: 39 | movl r10,_environ 40 | calls $3,_main 41 | pushl r0 42 | calls $1,_exit 43 | chmk $exit 44 | # 45 | .data 46 | _environ: .space 4 47 | -------------------------------------------------------------------------------- /franz/tahoe/exarith.c: -------------------------------------------------------------------------------- 1 | /* 2 | * exarith(mul1,mul2,add,hi,lo) 3 | * 4 | * (hi,lo) gets 64 bit product + sum of mul1*mul2+add; 5 | * routine returns non-zero if product is bigger than 30 bits 6 | * 7 | * Copyright (c) 1982, Regents, University of California 8 | * 9 | * stolen from 68k by P. S. Housel 04/29/86, with minor mods 10 | * (replaced call to emul with asm("emul...")) 11 | */ 12 | 13 | struct vl 14 | {long high; 15 | long low; 16 | }; 17 | 18 | long exarith(mul1,mul2,add,hi,lo) 19 | long *hi, *lo; 20 | register long add; 21 | { 22 | register long rlo; 23 | struct vl work; 24 | 25 | asm(" emul 4(fp),8(fp),r12,-60(fp)"); 26 | 27 | add = work.high; 28 | add <<= 2; 29 | if((rlo = work.low) < 0) add += 2; 30 | if(rlo & 0x40000000) add += 1; 31 | *lo = rlo &0x3fffffff; 32 | (*hi = add); 33 | if((add==0) || (add!=-1)) return(add); 34 | *lo = rlo; 35 | return(0); 36 | } 37 | -------------------------------------------------------------------------------- /franz/Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # $Header: Makefile,v 1.12 87/12/17 12:56:59 root Exp $ 3 | # 4 | # Franz Lisp C coded kernel, Machine independent part. 5 | # 6 | # The directions for modifying this file are found in the machine 7 | # dependent Makefiles (subdirectories vax/ or 68k/) 8 | 9 | 10 | Includes = h/config.h h/global.h h/aout.h h/vaxframe.h \ 11 | h/catchfram.h h/dfuncs.h h/gtabs.h h/sigtab.h \ 12 | h/chars.h h/frame.h h/lfuncs.h h/structs.h \ 13 | h/chkrtab.h h/gc.h h/lispo.h h/types.h \ 14 | h/lconf.h h/ltypes.h h/68kframe.h h/hpagsiz.h\ 15 | h/duallispo.h h/dualaout.h h/tahoeframe.h 16 | 17 | AllSrc = Makefile ${Includes} 18 | 19 | clean: FRC 20 | rm -f *.o 21 | 22 | #--- copysource : copy source files to another directory 23 | # called via make CopyTo=/xx/yyy/zz copysource 24 | # 25 | copysource: ${AllSrc} 26 | (tar cf - ${AllSrc} | (cd ${CopyTo} ; tar xf -)) 27 | 28 | scriptcatall: ${AllSrc} 29 | @(cd .. ; scriptcat franz franz ${AllSrc}) 30 | 31 | FRC: 32 | -------------------------------------------------------------------------------- /franz/tahoe/hcrt0.s: -------------------------------------------------------------------------------- 1 | # @(#)crt0.s 4.1 (Berkeley) 12/21/80 2 | # C runtime startoff 3 | # TAHOE 3/83 4 | 5 | .set exit,1 6 | .globl _exit 7 | .globl start 8 | .globl hstart 9 | .globl _main 10 | .globl _environ 11 | 12 | # 13 | # C language startup routine 14 | 15 | hstart: 16 | .word 0x0000 17 | clrl r1 18 | jmp L0 19 | start: 20 | .word 0x0000 21 | movl $1,r1 22 | L0: 23 | movab -8(sp),sp 24 | movl 8(sp),(sp) # argc 25 | movab 12(sp),r0 26 | movl r0,4(sp) # argv 27 | jmp L3 28 | L1: 29 | addl2 $4,r0 30 | L3: 31 | tstl (r0) # null args term ? 32 | jneq L1 33 | addl2 $4,r0 34 | cmpl r0,*4(sp) # end of 'env' or 'argv' ? 35 | jlss L2 36 | subl2 $4,r0 # envp's are in list 37 | L2: 38 | movl r0,8(sp) # env 39 | movl r0,r10 40 | tstl r1 41 | jneq L4 42 | callf $4,_rlc 43 | L4: 44 | movl r10,_environ # indir is 0 if no env ; not 0 if env 45 | callf $4*3+4,_main 46 | pushl r0 47 | callf $4*1+4,_exit 48 | kcall $exit 49 | # 50 | .data 51 | _environ: .space 4 52 | -------------------------------------------------------------------------------- /franz/tahoe/fixmask.c: -------------------------------------------------------------------------------- 1 | /* 2 | ** file: fixmask.c 3 | ** new & improved version by P. S. Housel 04/27/86 4 | ** 5 | ** note: "changing register save masks" involves making sure r6 and r7 6 | ** are saved for use as "np" and "lbot" 7 | */ 8 | 9 | /* 10 | * fixmask.c 11 | * complete program to change register save masks on the CCI "tahoe" 12 | * 13 | * (c) copyright 1982, Regents of the University of California 14 | */ 15 | 16 | #include 17 | 18 | char mybuf[BUFSIZ]; 19 | int mask; 20 | 21 | main() 22 | { 23 | register savesize = 0; 24 | char *cp; 25 | 26 | while(fgets(mybuf,BUFSIZ,stdin) != NULL) 27 | { 28 | if(*mybuf=='#') 29 | if(strcmpn(mybuf,"#protect", 8)==0) 30 | { 31 | savesize = 1; 32 | } 33 | 34 | if(savesize && strcmpn(mybuf," .set L",7)==0) 35 | { 36 | for(cp=mybuf;*cp++!=',';) ; 37 | sscanf(cp, "0x%x", &mask); 38 | sprintf(cp,"0x%X\n", mask | 0x0C0); 39 | savesize = 0; 40 | } 41 | 42 | fputs(mybuf,stdout); 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /Notice: -------------------------------------------------------------------------------- 1 | Franz Lisp is distributed as a large shell script which, when run, will 2 | create all necessary directories and place files in those directories. 3 | Only source files are distributed thus this shell script should be able 4 | to pass through any networks unaltered. 5 | 6 | The shell script is broken up in to a set of files named: opusVV.SS 7 | where VV is the version number and SS is a sequence number (aa, ab, ...). 8 | Each file is less than 200,000 bytes. You can determine what the current 9 | names are by using the FTP 'list directory' command after you log in. 10 | 11 | After you retrieve all the files you should type 12 | cat opus* | sh 13 | and the distribution will be extracted in the current directory. 14 | You may then remove the opus* files. 15 | 16 | The file ReadMe in the current directory will then describe how to make 17 | the lisp system. 18 | 19 | The files are stored on the arpanet host ucb-c70. Log in as 'lispuser' 20 | with password 'xxxxx'. Please do not ftp an files other than the opus* files. 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /lisplib/fixit.ref: -------------------------------------------------------------------------------- 1 | 2 | u / u n / u f / u n f go up, i.e. more recent (n frames) (of function f) 3 | up / up n go up to next (nth) non-system function 4 | d / dn go down, i.e. less recent (opposite of u and up) 5 | ok / go continue after an error or debug loop 6 | redo / redo f resume computation from current frame (or at fn f) 7 | step restart in single-step mode 8 | return e return from call with value of e (default is nil) 9 | edit edit the current stack frame 10 | editf / editf f edit nearest fn on stack (or edit fn f) 11 | top / bot go to top (bottom) of stack 12 | p / pp show current stack frame (pretty print) 13 | where give current stack position 14 | help / h / ? print this table -- /usr/lisp/doc/fixit.ref 15 | help ... get the help for ... 16 | pop / ^d exit one level of debug (reset) 17 | 18 | bk / bk n / bk f / bk n f / backtrace (to nth frame) (of fn f) 19 | ..f function names only ..a include system functions 20 | ..v show variable bindings ..e show expressions in full 21 | ..c go no deeper than here *** combinations are allowed *** 22 | 23 | -------------------------------------------------------------------------------- /franz/vax/fixmask.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: fixmask.c,v 1.2 83/04/10 21:34:40 sklower Exp $"; 4 | #endif 5 | 6 | /* -[Sat Jan 29 12:42:54 1983 by jkf]- 7 | * fixmask.c $Locker: $ 8 | * complete program to change register save masks on the vax 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | 14 | #include 15 | char mybuf[BUFSIZ]; 16 | extern unsigned short mask[]; 17 | main(){ 18 | register savesize = 0; char *cp; 19 | while(fgets(mybuf,BUFSIZ,stdin)!=NULL) { 20 | if(*mybuf=='#') { 21 | if(strcmpn(mybuf,"#save ",6)==0){ 22 | savesize = mybuf[6]-'0'; 23 | } else if (strcmpn(mybuf,"#protect ",9)==0){ 24 | savesize = '0'-1-mybuf[9]; 25 | } 26 | } 27 | if(savesize && strcmpn(mybuf," .set L",7)==0) { 28 | for(cp=mybuf;*cp++!=',';); 29 | sprintf(cp,"0x%X\n",mask[savesize + 10]); 30 | savesize = 0; 31 | } 32 | fputs(mybuf,stdout); 33 | } 34 | } 35 | unsigned short mask[] = { 36 | 0,0,0,0xfc0,0xfc0,0xfc0,0xec0,0xcc0,0x8c0,0x0c0,0, 37 | 0x800,0xc00,0xe00,0xf00,0xf80,0xfc0,0,0,0,0}; 38 | -------------------------------------------------------------------------------- /franz/tahoe/dodiv.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | 3 | struct sdot 4 | {long I; 5 | struct sdot *CDR; 6 | }; 7 | struct vl 8 | {long high; 9 | long low; 10 | }; 11 | 12 | long dodiv(top,bottom) 13 | long *top, *bottom; /* top least significant; bottom most */ 14 | { 15 | struct vl work; 16 | char error; 17 | register long *p = bottom; /* r12 */ 18 | register long rem = 0; /* r11 */ 19 | 20 | for(;p <= top;p++) 21 | { 22 | /* emul(0x40000000,rem,*p,&work); */ 23 | /* *p = ediv(&work,1000000000,&error); */ 24 | /* rem = work.high; */ 25 | 26 | asm("emul $0x40000000,r11,(r12),r0"); 27 | asm("ediv $1000000000,r0,(r12),r11"); 28 | } 29 | return(rem); 30 | } 31 | 32 | long dsneg(top,bottom) 33 | long *top, *bottom; 34 | { 35 | register long *p = top; 36 | register carry = 0; 37 | register digit; 38 | 39 | while(p >= bottom) 40 | { 41 | digit = carry - *p; 42 | /* carry = digit >> 30; is slow on 68K */ 43 | if(digit < 0) carry = -2; 44 | if(digit & 0x40000000) carry += 1; 45 | *p-- = digit & 0x3fffffff; 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /franz/h/dualaout.h: -------------------------------------------------------------------------------- 1 | /* %M% %I% %E% */ 2 | /* 3 | * Header prepended to each a.out file. 4 | */ 5 | struct exec { 6 | long a_magic; /* magic number */ 7 | unsigned long a_text; /* size of text segment */ 8 | unsigned long a_data; /* size of initialized data */ 9 | unsigned long a_bss; /* size of uninitialized data */ 10 | unsigned long a_syms; /* size of symbol table */ 11 | unsigned long a_trsize; /* size of text relocation */ 12 | unsigned long a_drsize; /* size of data relocation */ 13 | unsigned long a_entry; /* entry point */ 14 | }; 15 | 16 | #define OMAGIC 0407 /* old impure format */ 17 | #define NMAGIC 0410 /* read-only text */ 18 | #define ZMAGIC 0413 /* demand load format */ 19 | 20 | /* 21 | * Macros which take exec structures as arguments and tell whether 22 | * the file has a reasonable magic number or offsets to text|symbols|strings. 23 | */ 24 | #define N_BADMAG(x) \ 25 | (((x).a_magic)!=OMAGIC && ((x).a_magic)!=NMAGIC && ((x).a_magic)!=ZMAGIC) 26 | 27 | #define N_TXTOFF(x) \ 28 | ((x).a_magic==ZMAGIC ? 1024 : sizeof (struct exec)) 29 | #define N_SYMOFF(x) \ 30 | (N_TXTOFF(x) + (x).a_text+(x).a_data + (x).a_trsize+(x).a_drsize) 31 | #include 32 | -------------------------------------------------------------------------------- /franz/68k/first8.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "config.h" 3 | char code[256]; 4 | #define FIRST 3 5 | #define FOLLOW 2 6 | #define ZERO 6 7 | #define next() (((c = getc(si))==EOF)? exit(0):0) 8 | #define copy() putc(c,so) 9 | #define type() code[(unsigned char)c] 10 | #if os_unix_ts 11 | #define index strchr 12 | #endif 13 | 14 | init() { 15 | doit(FIRST,"ABCDEFGHIJKLMNOPQRSTUVWXYZ_"); 16 | doit(FIRST,"0abcdefghijklmnopqrstuvwxyz_"); 17 | doit(FOLLOW,"123456789"); 18 | } 19 | doit(act,list) 20 | register unsigned char *list; 21 | { 22 | while(*list) {code[*list++]=act;} 23 | } 24 | main( ) 25 | { 26 | register FILE *si = stdin, *so = stdout; 27 | register c, count; 28 | 29 | init(); 30 | copying: 31 | do { next(); copy();} while(type()!=FIRST); 32 | hexnum: 33 | if(c=='0') { 34 | next(); 35 | if(c=='X'||c=='x') { 36 | do { copy(); next();} 37 | while (index("0123456789abcdefABCDEF",c&0x7f)>0); 38 | } 39 | ungetc(c,si); goto copying; 40 | } 41 | counting: 42 | for(count = 0; count < 7; count++) { 43 | next(); 44 | copy(); 45 | if(!(type()&FOLLOW)) goto copying; 46 | } 47 | squelch: 48 | do { next(); } while (type()&FOLLOW); 49 | copy(); 50 | goto copying; 51 | } 52 | -------------------------------------------------------------------------------- /franz/subbig.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: subbig.c,v 1.2 83/09/12 14:17:31 sklower Exp $"; 4 | #endif 5 | 6 | /* -[Sat Jan 29 13:36:05 1983 by jkf]- 7 | * subbig.c $Locker: $ 8 | * bignum subtraction 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | #include "global.h" 14 | 15 | /* 16 | * subbig -- subtract one bignum from another. 17 | * 18 | * What this does is it negates each coefficient of a copy of the bignum 19 | * which is just pushed on the stack for convenience. This may give rise 20 | * to a bignum which is not in canonical form, but is nonetheless a repre 21 | * sentation of a bignum. Addbig then adds it to a bignum, and produces 22 | * a result in canonical form. 23 | */ 24 | lispval 25 | subbig(pos,neg) 26 | lispval pos, neg; 27 | { 28 | register lispval work; 29 | lispval adbig(); 30 | register long *mysp = sp() - 2; 31 | register long *ersatz = mysp; 32 | Keepxs(); 33 | 34 | for(work = neg; work!=0; work = work->s.CDR) { 35 | stack((long)(mysp -= 2)); 36 | stack(-work->i); 37 | } 38 | mysp[3] = 0; 39 | work = (adbig(pos,(lispval)ersatz)); 40 | Freexs(); 41 | return(work); 42 | } 43 | -------------------------------------------------------------------------------- /franz/68k/emul.s: -------------------------------------------------------------------------------- 1 | | /* Copyright (c) 1982, Regents, University of California */ 2 | | 3 | | $Header: emul.s,v 1.2 83/11/26 12:13:45 sklower Exp $ 4 | | $Locker: $ 5 | | 6 | .text 7 | .globl _emul 8 | _emul: 9 | link a6,#-_F1 10 | moveml #_S1,a6@(-_F1) 11 | movl a6@(20),a5 12 | | A1 = 24 13 | clrb a6@(-9) 14 | clrb a6@(-13) 15 | clrl d7 16 | tstl a6@(8) 17 | bge .L13 18 | eorb #1,a6@(-9) 19 | negl a6@(8) 20 | .L13: 21 | tstl a6@(12) 22 | bge .L14 23 | eorb #1,a6@(-9) 24 | negl a6@(12) 25 | .L14: 26 | movw a6@(10),d1 27 | mulu a6@(14),d1 28 | movl d1,a6@(-4) 29 | movw a6@(8),d1 30 | mulu a6@(12),d1 31 | movl d1,a6@(-8) 32 | movw a6@(8),d1 33 | mulu a6@(14),d1 34 | addl d1,a6@(-6) 35 | bcc .L16 36 | addqw #1,a6@(-8) 37 | .L16: 38 | movw a6@(10),d1 39 | mulu a6@(12),d1 40 | addl d1,a6@(-6) 41 | bcc .L17 42 | addqw #1,a6@(-8) 43 | .L17: 44 | tstb a6@(-9) 45 | beq .L18 46 | negl a6@(-4) 47 | negxl a6@(-8) 48 | .L18: 49 | tstl a6@(16) 50 | bge .L20 51 | moveq #-1,d7 52 | .L20: 53 | movl a6@(-8),d1 54 | movl a6@(16),d0 55 | addl a6@(-4),d0 56 | addxl d1,d7 57 | movl d0,a5@(4) 58 | movl d7,a5@ 59 | .L12: moveml a6@(-_F1),#8320 60 | unlk a6 61 | rts 62 | _F1 = 24 63 | _S1 = 8320 64 | | M1 = 0 65 | -------------------------------------------------------------------------------- /franz/vax/totxtfile.c: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | * 4 | * This program changes a unix textfile to a VMS text file. 5 | * 6 | * $Locker: $ 7 | * 8 | */ 9 | #include 10 | 11 | static char *rcsid = "$Header: /na/franz/franz/vax/RCS/totxtfile.c,v 1.1 83/04/11 00:31:07 sklower Exp $"; 12 | 13 | main(argc,argv) 14 | char *argv[]; 15 | { 16 | int fd; 17 | register FILE *f, *in; 18 | register c; 19 | /* 20 | * Open the input file 21 | */ 22 | if(argc==3) { 23 | if(NULL==(in = fopen(argv[1],"r"))) { 24 | fprintf(stderr, 25 | "Couldn't open %s for reading\n",argv[1]); 26 | exit(2); 27 | } 28 | argc--; argv++; 29 | } else { 30 | in = fdopen(0,"r"); 31 | } 32 | if(argc!=2) { 33 | fprintf(stderr,"Usage: totxtfile \n"); 34 | exit(1); 35 | } 36 | /* 37 | * Open the .txt file 38 | */ 39 | if ((fd = creat(argv[1],0777,"txt")) < 0) { 40 | fprintf(stderr,"Couldn't open %s for writing\n",argv[1]); 41 | exit(3); 42 | } 43 | f = fdopen(fd,"w"); 44 | /* 45 | * Do the copy 46 | */ 47 | for(;;) { 48 | c = getc(in); 49 | if(c==EOF) break; 50 | putc(c,f); 51 | } 52 | /* 53 | * Close the file 54 | */ 55 | fclose(f); 56 | /* 57 | * Done 58 | */ 59 | exit(0); 60 | } 61 | -------------------------------------------------------------------------------- /franz/68k/calqhat.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | struct vl { long high; long low; }; 3 | calqhat(uj,v1) 4 | register long *uj, *v1; 5 | { 6 | struct vl work1, work2; 7 | register handy, handy2; 8 | register qhat, rhat; 9 | char err; 10 | if(*v1==*uj) { 11 | /* set qhat to b-1 12 | * rhat is easily calculated since if we substite b-1 13 | * for qhat in the formula below, one gets (u[j+1] + v[1]) 14 | */ 15 | qhat = 0x3fffffff; 16 | rhat = uj[1] + *v1; 17 | } else { 18 | /* work1 = u[j]b + u[j+1]; */ 19 | handy2 = uj[1]; 20 | handy = *uj; 21 | if(handy & 1) handy2 |= 0x40000000; 22 | if(handy & 2) handy2 |= 0x80000000; 23 | handy >>= 2; 24 | work1.low = handy2; work1.high = handy; 25 | qhat = ediv(&work1,*v1,&err); 26 | /* rhat = work1 - qhat*v[1]; */ 27 | rhat = work1.high; 28 | } 29 | again: 30 | /* check if v[2]*qhat > rhat*b+u[j+2] */ 31 | emul(qhat,v1[1],0,&work1); 32 | /* work2 = rhat*b+u[j+2]; */ 33 | { handy2 = uj[2]; handy = rhat; 34 | if(handy & 1) handy2 |= 0x40000000; 35 | if(handy & 2) handy2 |= 0x80000000; 36 | handy >>= 2; work2.low = handy2; work2.high = handy; } 37 | vlsub(&work1,&work2); 38 | if(work1.high <= 0) return(qhat); 39 | qhat--; rhat += *v1; 40 | goto again; 41 | } 42 | -------------------------------------------------------------------------------- /franz/vax/rawlisp.unx: -------------------------------------------------------------------------------- 1 | $! 2 | $! Command file to link a "rawlisp" image 3 | $! 4 | $ link/exe=rawlisp/sym=rawlisp/map=rawlisp/full/cross sys$input:/opt 5 | ! 6 | ! The 1st cluster gets all the lowcore data 7 | ! 8 | cluster=0lowcore,0,,[-]low.o 9 | ! 10 | ! The 2nd cluster gets everything else 11 | ! 12 | cluster=lisp,,,[]bigmath.o,- 13 | [-]alloc.o,- 14 | [-]data.o,- 15 | [-]divbig.o,- 16 | [-]error.o,- 17 | [-]eval.o,- 18 | [-]eval2.o,- 19 | [-]evalf.o,- 20 | [-]fasl.o,- 21 | [-]fex1.o,- 22 | [-]fex2.o,- 23 | [-]fex3.o,- 24 | [-]fex4.o,- 25 | [-]fexr.o,- 26 | [-]ffasl.o,- 27 | [-]fpipe.o,- 28 | [-]frame.o,- 29 | [-]inits.o,- 30 | [-]io.o,- 31 | [-]lam1.o,- 32 | [-]lam2.o,- 33 | [-]lam3.o,- 34 | [-]lam4.o,- 35 | [-]lam5.o,- 36 | [-]lam6.o,- 37 | [-]lam7.o,- 38 | [-]lam8.o,- 39 | [-]lam9.o,- 40 | [-]lamgc.o,- 41 | [-]lamp.o,- 42 | [-]lamr.o,- 43 | [-]lisp.o,- 44 | [-]lowaux.o,- 45 | [-]pbignum.o,- 46 | []qfuncl.o,- 47 | [-]subbig.o,- 48 | [-]sysat.o,- 49 | [-]trace.o,- 50 | []vax.o,- 51 | []prealloc.o,- 52 | lib:fastexecp.obj,- 53 | lib:libtrmlib/library,lib:libm/library,lib:libc/library 54 | iosegment=250,NOP0BUFS 55 | $ ! 56 | $ ! Done: COPY the rawlisp.exe image to rawlisp. (for Make to be happy) 57 | $ ! 58 | $ write sys$Output "Link Complete" 59 | $ copy/log rawlisp.exe rawlisp. 60 | -------------------------------------------------------------------------------- /pearl/pearlbase.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; pearlbase.l ;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; This file is the first half of PEARL for compiling in two steps. 3 | ; After it is compiled, it can be loaded into a liszt that is 4 | ; compiling pearlbulk.l 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ; Copyright (c) 1983 , The Regents of the University of California. 7 | ; All rights reserved. 8 | ; Authors: Joseph Faletti and Michael Deering. 9 | 10 | (eval-when (compile) 11 | ; To cut down on the number of garbage collects during compilation. 12 | (allocate 'list 800) 13 | (allocate 'symbol 200) 14 | (declare (special defmacro-for-compiling)) 15 | (setq defmacro-for-compiling t)) 16 | 17 | (declare (macros t)) 18 | (declare (localf enforcetype buildvalue 19 | insidescopy insidepatternize insidevarreplace 20 | followpath convertpreds revassq 21 | recursetoinsidestandardfetch gethashvalue insertbyfocus 22 | removebyfocus 23 | prefix addhistory read-in-startprl-file read-in-initprl-file)) 24 | 25 | (include ucisubset.l) 26 | ; Version numbers are in here. 27 | (include franz.l) 28 | (include lowlevel.l) 29 | (include db.l) 30 | (include vars.l) 31 | (include symord.l) 32 | (include hook.l) 33 | 34 | 35 | ; vi: set lisp: 36 | -------------------------------------------------------------------------------- /franz/vax/rawhlisp.unx: -------------------------------------------------------------------------------- 1 | 2 | $! 3 | $! Command file to link a "rawlisp" image 4 | $! 5 | $ link/exe=rawhlisp/sym=rawhlisp/map=rawhlisp/full/cross sys$input:/opt 6 | ! 7 | ! The 1st cluster gets all the lowcore data 8 | ! 9 | cluster=0lowcore,0,,[-]low.o 10 | ! 11 | ! The 2nd cluster gets everything else 12 | ! 13 | cluster=lisp,,,[]bigmath.o,- 14 | [-]alloc.o,- 15 | [-]data.o,- 16 | [-]divbig.o,- 17 | [-]error.o,- 18 | [-]eval.o,- 19 | [-]eval2.o,- 20 | [-]evalf.o,- 21 | [-]fasl.o,- 22 | [-]fex1.o,- 23 | [-]fex2.o,- 24 | [-]fex3.o,- 25 | [-]fex4.o,- 26 | [-]fexr.o,- 27 | [-]ffasl.o,- 28 | [-]fpipe.o,- 29 | [-]frame.o,- 30 | [-]inits.o,- 31 | [-]io.o,- 32 | [-]lam1.o,- 33 | [-]lam2.o,- 34 | [-]lam3.o,- 35 | [-]lam4.o,- 36 | [-]lam5.o,- 37 | [-]lam6.o,- 38 | [-]lam7.o,- 39 | [-]lam8.o,- 40 | [-]lam9.o,- 41 | [-]lamgc.o,- 42 | [-]lamp.o,- 43 | [-]lamr.o,- 44 | [-]lisp.o,- 45 | [-]pbignum.o,- 46 | []qfuncl.o,- 47 | [-]subbig.o,- 48 | [-]sysat.o,- 49 | [-]trace.o,- 50 | []vax.o,- 51 | []prealloc.o,- 52 | []hole.obj,- 53 | lib:fastexecp.obj,- 54 | lib:libtrmlib/library,lib:libm/library,lib:libc/library 55 | iosegment=250,NOP0BUFS 56 | $ ! 57 | $ ! Done: COPY the rawlisp.exe image to rawlisp. (for Make to be happy) 58 | $ ! 59 | $ write sys$Output "Link Complete" 60 | $ copy/log rawhlisp.exe rawhlisp. 61 | -------------------------------------------------------------------------------- /franz/h/structs.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 14:00:31 1983 by jkf]- 2 | * structs.h $Locker: $ 3 | * random structure definitions 4 | * 5 | * $Header: /na/franz/franz/h/structs.h,v 1.1 83/01/29 14:07:48 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | /* 11 | * this file contains auxiliary structure definitions which are used by 12 | * just a few files. 13 | */ 14 | 15 | /* transfer table structures. */ 16 | 17 | #define TRENTS 510 18 | 19 | struct trent 20 | { 21 | lispval (*fcn)(); /* function to call */ 22 | lispval name; /* symbol which is the function to call */ 23 | }; 24 | 25 | struct trtab 26 | { 27 | struct trtab *nxtt; /* pointer to next transfer table */ 28 | struct trent trentrs[TRENTS]; /* entries */ 29 | int sentinal; /* must be zero */ 30 | }; 31 | 32 | 33 | 34 | struct heads { 35 | struct heads *link; 36 | char *pntr; 37 | }; 38 | 39 | 40 | struct types 41 | { 42 | char *next_free; 43 | int space_left, 44 | space, 45 | type, 46 | type_len; /* note type_len is in units of int */ 47 | lispval *items, 48 | *pages, 49 | *type_name; 50 | struct heads 51 | *first; 52 | char *next_pure_free; 53 | 54 | }; 55 | 56 | struct str_x 57 | { 58 | char *next_free; 59 | int space_left; 60 | }; 61 | -------------------------------------------------------------------------------- /lisplib/autorun/mc500: -------------------------------------------------------------------------------- 1 | " 2 | | 3 | | Lisp startup program. 4 | | insert two new parameters on the argv[] list and re-exec lisp 5 | | 6 | .globl exece 7 | start: 8 | movl sp@, d1 | get argc (# of parameters on stack) 9 | lea sp@(4),a3 | save the address of argv[] 10 | asll #2,d1 | multiply argc by 4 to get # of bytes of argv ptrs on stack 11 | lea a3@(4,d1:l),a4 | save the address of arge[] (it's after all of the argv's) 12 | movl #flag,a3@- | insert (push) the address of the flag string on to top of argv stack 13 | movl #lisp,a3@- | insert (push) the address of the lisp string on to top of argv stack 14 | movl a3,sp | set the stack to point to the new stack head. 15 | | 16 | | Set up a call to exece 17 | pea a4@ | push the address of arge on the stack 18 | pea a3@ | push the address of argv on the stack 19 | movl #lisp,sp@- | push the name of the program on the stack 20 | jsr exece | now call exece, you've got the right parameters 21 | exece: 22 | moveq #0x3b,d0 23 | movl a7@(4),d1 24 | movl a7@(8),a0 25 | movl a7@(12),a1 26 | trap #0 27 | movl #0,d0 28 | movl d0,d1 29 | trap #0 | exit if exec fails 30 | | 31 | | call exit on a exec failure without losing the return code. 32 | | we should NEVER return from _exit 33 | | 34 | flag: .asciz \"-f\" 35 | lisp: .asciz \"/usr/ucb/lisp\" 36 | .even 37 | " 38 | -------------------------------------------------------------------------------- /franz/tahoe/calqhat.s: -------------------------------------------------------------------------------- 1 | .align 1 2 | .globl _calqhat 3 | _calqhat: 4 | .word 0xffc 5 | movl 4(fp),r11 # &u[j] into r11 6 | movl 8(fp),r10 # &v[1] into r10 7 | cmpl (r10),(r11) # v[1] == u[j] ?? 8 | beql L102 9 | # calculate qhat and rhat simultaneously, 10 | # qhat in r0 11 | # rhat in r1 12 | emul (r11),$0x40000000,4(r11),r4 # u[j]b+u[j+1] into r4,r5 13 | ediv (r10),r4,r0,r1 # qhat = ((u[j]b+u[j+1])/v[1]) into r0 14 | # (u[j]b+u[j+1] -qhat*v[1]) into r1 15 | # called rhat 16 | L101: 17 | # check if v[2]*qhat > rhat*b+u[j+2] 18 | emul r0,4(r10),$0,r2 # qhat*v[2] into r3,r2 19 | emul r1,$0x40000000,8(r11),r8 #rhat*b + u[j+2] into r9,r8 20 | # give up if r3,r2 <= r9,r8, otherwise iterate 21 | addl2 $0,r2 # explicitly clear carry. 22 | subl2 r8,r2 # perform r3,r2 - r9,r8 23 | sbwc r9,r3 24 | bleq L103 # give up if negative or equal 25 | decl r0 # otherwise, qhat = qhat - 1 26 | addl2 (r10),r1 # since dec'ed qhat, inc rhat by v[1] 27 | jbr L101 28 | L102: 29 | # get here if v[1]==u[j] 30 | # set qhat to b-1 31 | # rhat is easily calculated since if we substitute b-1 for qhat in 32 | # the formula, then it simplifies to (u[j+1] + v[1]) 33 | # 34 | addl3 4(r11),(r10),r1 # rhat = u[j+1] + v[1] 35 | movl $0x3fffffff,r0 # qhat = b-1 36 | jbr L101 37 | 38 | L103: 39 | ret 40 | 41 | -------------------------------------------------------------------------------- /pearl/inits.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; inits.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; Expressions which set the values of special variables and create 3 | ; nilsym and nilstruct and which use PEARL functions and so must 4 | ; be done AFTER everything is loaded. 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ; Copyright (c) 1983 , The Regents of the University of California. 7 | ; All rights reserved. 8 | ; Authors: Joseph Faletti and Michael Deering. 9 | 10 | (progn 11 | ; A very special cell. 12 | (setq *any*conscell* (cons '*any* (punbound))) 13 | ; Define the default symbol. 14 | (or (boundp (symatom 'nilsym)) 15 | (symbol nilsym)) 16 | ; Define the default empty structure. 17 | (or (boundp (defatom 'nilstruct)) 18 | (create base nilstruct)) 19 | ; Values that should not take part in hashing. 20 | ; Used to include ",(eval (defatom 'nilstruct)) ,(eval (symatom 'nilsym))". 21 | (setq *unhashablevalues* `(nil ,(punbound) ,(unbound))) 22 | (putprop 'history '(history) 'alias) 23 | (putprop 'h '(history 22) 'alias) 24 | (defprop quote "'" printmacro) 25 | (defprop pearlequals "=" printmacro) 26 | (defprop *var* "?" printmacro) 27 | (defprop *global* "?" printmacro) 28 | (setdbsize 7.) 29 | (builddb *maindb*) 30 | (setq *db* *maindb*) 31 | ) 32 | 33 | ; vi: set lisp: 34 | -------------------------------------------------------------------------------- /franz/68k/dsmult.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | /* 3 | * $Header $ 4 | * 5 | * dsmult(top,bot,mul) -- 6 | * multiply an array of longs on the stack, by mul. 7 | * the element top through bot (inclusive) get changed. 8 | * if you expect a carry out of the most significant, 9 | * it is up to you to provide a space for it to overflow. 10 | */ 11 | 12 | struct vl { long high; long low; }; 13 | dsmult(top,bot,mul) 14 | long *top, *bot, mul; 15 | { 16 | register long *p; 17 | struct vl work; 18 | long add = 0; 19 | 20 | for(p = top; p >= bot; p--) { 21 | emul(*p,mul,add,&work); /* *p has 30 bits of info, mul has 32 22 | yielding a 62 bit product. */ 23 | *p = work.low & 0x3fffffff; /* the stack gets the low 30 bits */ 24 | add = work.high; /* we want add to get the next 32 bits. 25 | on a 68k you might better be able to 26 | do this by shifts and tests on the 27 | carry but I don't know how to do this 28 | from C, and the code generated here 29 | will not be much worse. Far less 30 | bad than shifting work.low to the 31 | right 30 bits just to get the top 2. 32 | */ 33 | add <<= 2; 34 | if(work.low < 0) add += 2; 35 | if(work.low & 0x40000000) add += 1; 36 | } 37 | p[1] = work.low; /* on the final store want all 32 bits. */ 38 | } 39 | -------------------------------------------------------------------------------- /franz/pbignum.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: pbignum.c,v 1.3 83/09/12 14:17:59 sklower Exp $"; 4 | #endif 5 | 6 | /* -[Sat Jan 29 13:30:47 1983 by jkf]- 7 | * pbignum.c $Locker: $ 8 | * print a bignum 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | #include "global.h" 14 | 15 | pbignum(current, useport) 16 | register lispval current; 17 | register FILE *useport; 18 | { 19 | long *top, *bot, *work, negflag = 0; 20 | char *alloca(); 21 | register int *digitp; 22 | Keepxs(); 23 | 24 | /* copy bignum onto stack */ 25 | top = (sp()) - 1; 26 | do { 27 | stack(current->s.I); 28 | } while(current = current->s.CDR); 29 | 30 | bot = sp(); 31 | if (top==bot) { 32 | fprintf(useport,"%d",*bot); 33 | Freexs(); 34 | return; 35 | } 36 | 37 | /* save space for printed digits*/ 38 | work = (int *)alloca((top-bot)*2*sizeof(int)); 39 | if( *bot < 0) { 40 | negflag = 1; 41 | dsneg(top,bot); 42 | } 43 | 44 | /* figure out nine digits at a time by destructive division*/ 45 | for(digitp = work; bot <= top; digitp++) { 46 | *digitp = dodiv(top,bot); 47 | if(*bot==0) bot += 1; 48 | } 49 | 50 | /* print them out */ 51 | 52 | if(negflag) putc('-',useport); 53 | fprintf(useport,"%d",*--digitp); 54 | while ( digitp > work) fprintf(useport,"%.09d",*--digitp); 55 | Freexs(); 56 | } 57 | -------------------------------------------------------------------------------- /franz/tahoe/dsmult.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | /* 3 | * dsmult(top,bot,mul) -- 4 | * multiply an array of longs on the stack, by mul. 5 | * the element top through bot (inclusive) get changed. 6 | * if you expect a carry out of the most significant, 7 | * it is up to you to provide a space for it to overflow. 8 | */ 9 | 10 | struct vl 11 | {long high; 12 | long low; 13 | }; 14 | 15 | dsmult(top,bot,mul) 16 | long *top, *bot, mul; 17 | { 18 | register long *p; 19 | struct vl work; 20 | long add = 0; 21 | 22 | for(p = top; p >= bot; p--) { 23 | asm("emul (r12),12(fp),-64(fp),-60(fp)"); 24 | /* *p has 30 bits of info, mul has 32 yielding a 62 bit product. */ 25 | *p = work.low & 0x3fffffff; /* the stack gets the low 30 bits */ 26 | add = work.high; /* we want add to get the next 32 bits. 27 | on a 68k you might better be able to 28 | do this by shifts and tests on the 29 | carry but I don't know how to do this 30 | from C, and the code generated here 31 | will not be much worse. Far less 32 | bad than shifting work.low to the 33 | right 30 bits just to get the top 2. 34 | */ 35 | add <<= 2; 36 | if(work.low < 0) add += 2; 37 | if(work.low & 0x40000000) add += 1; 38 | } 39 | p[1] = work.low; /* on the final store want all 32 bits. */ 40 | } 41 | -------------------------------------------------------------------------------- /franz/68k/adbig.c: -------------------------------------------------------------------------------- 1 | /* 2 | * $Header: adbig.c,v 1.2 83/11/26 12:12:37 sklower Exp $ 3 | * $Locker: $ 4 | * 5 | * Copyright (c) 1982, Regents, University of California 6 | * 7 | */ 8 | #include "global.h" 9 | 10 | struct s_dot { long I; struct s_dot *CDR; }; 11 | struct vl { long high; long low; }; 12 | 13 | struct s_dot *adbig(a,b) 14 | struct s_dot *a, *b; 15 | { 16 | int la = 1, lb = 1; 17 | long *sa, *sb, *sc, *base, *alloca(); 18 | struct s_dot *export(); 19 | register struct s_dot *p; 20 | register int *q, *r, *s; 21 | register carry = 0; 22 | Keepxs(); 23 | 24 | /* compute lengths */ 25 | 26 | for(p = a; p->CDR; p = p->CDR) la++; 27 | for(p = b; p->CDR; p = p->CDR) lb++; 28 | if(lb > la) la = lb; 29 | 30 | /* allocate storage areas on the stack */ 31 | 32 | base = alloca((3*la+1)*sizeof(long)); 33 | sc = base + la +1; 34 | sb = sc + la; 35 | sa = sb + la; 36 | q = sa; 37 | 38 | /* copy s_dots onto stack */ 39 | p = a; 40 | do { *--q = p->I; p = p->CDR; } while (p); 41 | while(q > sb) *--q = 0; 42 | p = b; 43 | do { *--q = p->I; p = p->CDR; } while (p); 44 | while(q > sc) *--q = 0; 45 | 46 | /* perform the addition */ 47 | for(q = sa, r = sb, s = sc; q > sb;) 48 | { 49 | carry += *--q + *--r; 50 | *--s = carry & 0x3fffffff; 51 | carry >>= 30; 52 | } 53 | *--s = carry; 54 | 55 | p = export(sc,base); 56 | Freexs(); 57 | return(p); 58 | } 59 | -------------------------------------------------------------------------------- /franz/lamp.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: lamp.c,v 1.3 83/12/09 16:51:36 sklower Exp $"; 4 | #endif 5 | 6 | /* -[Tue Mar 22 15:17:09 1983 by jkf]- 7 | * lamp.c $Locker: $ 8 | * interface with unix profiling 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | #include "global.h" 14 | 15 | #ifdef PROF 16 | 17 | #define PBUFSZ 500000 18 | short pbuf[PBUFSZ]; 19 | 20 | /* data space for fasl to put counters */ 21 | int mcnts[NMCOUNT]; 22 | int mcntp = (int) mcnts; 23 | int doprof = TRUE; 24 | 25 | lispval 26 | Lmonitor() 27 | { 28 | extern etext, countbase; 29 | 30 | if (np==lbot) { monitor((int(*)())0); countbase = 0; } 31 | else if (TYPE(lbot->val)==INT) 32 | { monitor((int (*)())2, (int (*)())lbot->val->i, pbuf, 33 | PBUFSZ*(sizeof(short)), 7000); 34 | countbase = ((int)pbuf) +12; 35 | } 36 | else { 37 | monitor((int (*)())2, (int (*)())sbrk(0), pbuf, 38 | PBUFSZ*(sizeof(short)), 7000); 39 | countbase = ((int)pbuf) + 12; } 40 | return(tatom); 41 | } 42 | 43 | 44 | #else 45 | 46 | /* if prof is not defined, create a dummy Lmonitor */ 47 | 48 | short pbuf[8]; 49 | 50 | /* data space for fasl to put counters */ 51 | int mcnts[1]; 52 | int mcntp = (int) mcnts; 53 | int doprof = FALSE; 54 | 55 | Lmonitor() 56 | { 57 | error("Profiling not enabled",FALSE); 58 | } 59 | 60 | 61 | #endif 62 | -------------------------------------------------------------------------------- /liszt/Makefile: -------------------------------------------------------------------------------- 1 | #$Header: Makefile,v 1.12 83/09/12 15:26:36 layer Exp $ 2 | # 3 | #makefile for misc things -- lxref and tags 4 | 5 | DESTDIR = 6 | ObjDir = /usr/ucb 7 | Liszt = ${ObjDir}/liszt 8 | XTR = /na/lbc/bin/extract 9 | 10 | CTESrc = chead.l cmacros.l const.l 11 | 12 | Src = array.l datab.l decl.l expr.l fixnum.l funa.l funb.l func.l io.l \ 13 | vector.l instr.l tlev.l util.l lversion.l 14 | 15 | LxrefSrc = lxref.l 16 | 17 | AllSrc = Makefile ChangeLog cmake.l ${CTESrc} ${Src} ${LxrefSrc} ltags tags 18 | 19 | .DEFAULT:lxref 20 | 21 | xtra: ${DotSSrc} 22 | 23 | doc: 24 | ${XTR} -clE "(load 'const.l)(load 'chead.l)" $(CTESrc) $(Src) > doc 25 | 26 | doc.n: 27 | ${XTR} -cnlE "(load 'const.l)(load 'chead.l)" $(CTESrc) $(Src) > doc.n 28 | 29 | index: 30 | ${XTR} -cli\ 31 | -E "(progn (chdir'vax)(load'../cmacros.l)(load'../chead.l)(chdir'..))"\ 32 | $(CTESrc) $(Src) > index 33 | 34 | index.n: 35 | ${XTR} -cnli -T "Liszt Index" -p 8\ 36 | -E "(progn (chdir'vax)(load'lisprc.l)(load'../cmacros.l)(load'../chead.l)(chdir'..))"\ 37 | $(CTESrc) $(Src) > index.n 38 | 39 | lxref: lxref.l 40 | ${Liszt} -xrq -o lxref lxref.l 41 | 42 | install: lxref 43 | mv lxref ${DESTDIR}${ObjDir}/lxref 44 | 45 | scriptcatall: ${DistSrc} 46 | @../scriptcat . liszt ${AllSrc} 47 | 48 | copysource: ${AllSrc} 49 | (tar cf - ${AllSrc} | (cd ${CopyTo} ; tar xf -)) 50 | 51 | copyobjects: ${AllObj} 52 | (tar cf - ${AllObj} | (cd ${CopyTo} ; tar xf -)) 53 | -------------------------------------------------------------------------------- /franz/tahoe/adbig.c: -------------------------------------------------------------------------------- 1 | /* 2 | * 3 | * Copyright (c) 1982, Regents, University of California 4 | * 5 | * stolen from 68k port by P. S. Housel 05/03/86 6 | */ 7 | #include "global.h" 8 | 9 | struct s_dot 10 | { 11 | long I; 12 | struct s_dot *CDR; 13 | }; 14 | struct vl 15 | { 16 | long high; 17 | long low; 18 | }; 19 | 20 | 21 | struct s_dot *adbig(a,b) 22 | struct s_dot *a, *b; 23 | { 24 | int la = 1, lb = 1; 25 | long *sa, *sb, *sc, *base, *alloca(); 26 | struct s_dot *export(); 27 | register struct s_dot *p; 28 | register int *q, *r, *s; 29 | register carry = 0; 30 | Keepxs(); 31 | 32 | /* compute lengths */ 33 | 34 | for(p = a; p->CDR; p = p->CDR) la++; 35 | for(p = b; p->CDR; p = p->CDR) lb++; 36 | if(lb > la) la = lb; 37 | 38 | /* allocate storage areas on the stack */ 39 | 40 | base = alloca((3*la+1)*sizeof(long)); 41 | sc = base + la +1; 42 | sb = sc + la; 43 | sa = sb + la; 44 | q = sa; 45 | 46 | /* copy s_dots onto stack */ 47 | p = a; 48 | do { *--q = p->I; p = p->CDR; } while (p); 49 | while(q > sb) *--q = 0; 50 | p = b; 51 | do { *--q = p->I; p = p->CDR; } while (p); 52 | while(q > sc) *--q = 0; 53 | 54 | /* perform the addition */ 55 | for(q = sa, r = sb, s = sc; q > sb;) 56 | { 57 | carry += *--q + *--r; 58 | *--s = carry & 0x3fffffff; 59 | carry >>= 30; 60 | } 61 | *--s = carry; 62 | 63 | p = export(sc,base); 64 | Freexs(); 65 | return(p); 66 | } 67 | -------------------------------------------------------------------------------- /liszt/const.l: -------------------------------------------------------------------------------- 1 | 2 | ;;; ---- c o n s t header file for inclusion 3 | 4 | ; 5 | ;$Header: const.l,v 1.4 87/12/15 16:58:19 sklower Exp $ 6 | ; 7 | 8 | (putprop 'const t 'loaded) ; flag that this file has been loaded 9 | 10 | ;--- parameters: these must be evaluated at compile time so readmacros will 11 | ; work 12 | (eval-when (compile eval) 13 | (setq np-sym "_np" 14 | lbot-sym "_lbot" 15 | bnp-sym "_bnp" 16 | ch-newline (ascii #\lf)) 17 | #+(or for-vax for-tahoe) 18 | (setq np-reg 'r6 19 | lbot-reg 'r7 20 | bind-reg 'r8 21 | np-plus '(+ r6) 22 | np-minus '(- r6) 23 | bnp-reg 'r5 24 | fixnum-reg 'r5 25 | olbot-reg 'r10 26 | nil-reg "*** this should never be used ***" 27 | comment-char "#" 28 | Cstack "-(sp)" 29 | unCstack "(sp)+" 30 | Nilatom "$0") 31 | #+for-68k 32 | (setq bnp-reg 'a1 33 | np-reg 'a2 34 | lbot-reg 'd3 ; only for hacked version of 68k lisp 35 | bind-reg 'a3 36 | olbot-reg 'a4 37 | fixnum-reg 'd2 38 | nil-reg 'd7 39 | np-plus '(+ a2) 40 | np-minus '(- a2) 41 | Nilatom "#_nilatom" 42 | comment-char "|" 43 | Cstack "sp@-" 44 | unCstack "sp@+")) 45 | 46 | ;--- evaluation frame parameters. These must correspond to what is 47 | ; in h/frame.h in the C system 48 | ; 49 | (eval-when (compile load eval) 50 | (setq C_GO 1 C_RET 2 C_THROW 3 C_RESET 4) 51 | (setq F_PROG 1 F_CATCH 2 F_RESET 3)) 52 | 53 | ; offsets in frame 54 | (setq OF_olderrp 12) ; 12 bytes from base of error frame 55 | -------------------------------------------------------------------------------- /ReadMe.tahoe: -------------------------------------------------------------------------------- 1 | This is the distribution of Franz Lisp Opus 38.92 for the CCI "tahoe" 2 | machine. It should be configurable as a VAX or 68000 version, but this 3 | has not yet been tested. 4 | Before the system can be compiled, a change is necessary to /lib/c2, 5 | the C-compiler's optimizer phase. Without this change, the optimizer dumps 6 | core when run through a pipe: 7 | 8 | :::::::::::::::::::: 9 | *** c20.c Wed Jan 14 09:55:09 1987 10 | --- c20.c.new Wed Jan 14 09:55:52 1987 11 | *************** 12 | *** 29,48 **** 13 | struct node * 14 | alloc(an) 15 | { 16 | ! register int n; 17 | ! register char *p; 18 | ! 19 | ! n = an; 20 | ! n+=sizeof(char *)-1; 21 | ! n &= ~(sizeof(char *)-1); 22 | ! if (lasta+n >= lastr) { 23 | ! if (sbrk(2000) == -1) 24 | ! error("Optimizer: out of space\n"); 25 | ! lastr += 2000; 26 | ! } 27 | ! p = lasta; 28 | ! lasta += n; 29 | ! return((struct node *)p); 30 | } 31 | 32 | main(argc, argv) 33 | --- 29,35 ---- 34 | struct node * 35 | alloc(an) 36 | { 37 | ! return((struct node *)malloc(an)); 38 | } 39 | 40 | main(argc, argv) 41 | :::::::::::::::::::: 42 | 43 | Another special condsideration is the WCS version in use. If bignum 44 | math with negative numbers (try "(quotient 9999999999999999999 -9)") gives 45 | incorrect results, then you are using an outdated WCS and should attempt to 46 | obtain a newer version from CCI. 47 | 48 | Please send any other porting bugs to: 49 | Peter S. Housel 50 | housel@ei.ecn.purdue.edu -or- ...!ihnp4!pur-ee!housel 51 | 52 | -------------------------------------------------------------------------------- /franz/tahoe/dmlad.s: -------------------------------------------------------------------------------- 1 | 2 | .globl _dmlad 3 | /* 4 | routine for destructive multiplication and addition to a bignum by 5 | two fixnums. 6 | 7 | from C, the invocation is dmlad(sdot,mul,add); 8 | where sdot is the address of the first special cell of the bignum 9 | mul is the multiplier, add is the fixnum to be added (The latter 10 | being passed by value, as is the usual case. 11 | 12 | 13 | Register assignments: 14 | 15 | r11 = current sdot 16 | r10 = carry 17 | r9 = previous sdot, for relinking. 18 | r8 = temporary kluge variable 19 | */ 20 | 21 | _dmlad: .word 0x0f00 22 | movl 4(fp),r11 #initialize cell pointer 23 | movl 12(fp),r10 #initialize carry 24 | loop: emul 8(fp),(r11),r10,r0 #r0 gets cell->car times mul + carry 25 | 26 | ediv $0x40000000,r0,r10,r8 #cell->car gets prod % 2**30 27 | movl r8,(r11) 28 | #carry gets quotient 29 | /* extzv $0,$30,r0,(r11) 30 | extv $30,$32,r0,r10 31 | */ 32 | movl r11,r9 #save last cell for fixup at end. 33 | movl 4(r11),r11 #move to next cell 34 | bneq loop #done indicated by 0 for next sdot 35 | tstl r10 #if carry zero no need to allocate 36 | beql done #new bigit 37 | mcoml r10,r3 #test to see if neg 1. 38 | bneq alloc #if not must allocate new cell. 39 | tstl (r9) #make sure product isn't -2**30 40 | beql alloc 41 | movl r0,(r9) #save old lower half of product. 42 | brb done 43 | alloc: callf $4,_newdot #otherwise allocate new bigit 44 | movl r10,(r0) #store carry 45 | movl r0,4(r9) #save new link cell 46 | done: movl 4(fp),r0 47 | ret 48 | -------------------------------------------------------------------------------- /franz/h/dfuncs.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 13:54:30 1983 by jkf]- 2 | * dfuncs.h $Locker: $ 3 | * external function declaration 4 | * 5 | * $Header: dfuncs.h,v 1.2 84/02/29 17:09:10 sklower Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | char *brk(); 11 | char *getsp(); 12 | char *pinewstr(); 13 | char *inewstr(); 14 | char *mkmsg(); 15 | char *newstr(); 16 | char *rstore(); 17 | char *sbrk(); 18 | char *xsbrk(); 19 | char *ysbrk(); 20 | int csizeof(); 21 | int finterp(); 22 | lispval Iget(); 23 | lispval Imkrtab(); 24 | lispval Iputprop(); 25 | lispval Lfuncal(); 26 | lispval Lnegp(); 27 | lispval Lsub(); 28 | lispval alloc(); 29 | lispval copval(); 30 | lispval csegment(); 31 | lispval error(); 32 | lispval errorh(); 33 | lispval errorh1(); 34 | lispval errorh2(); 35 | lispval eval(); 36 | lispval gc(); 37 | lispval getatom(); 38 | lispval inewval(); 39 | lispval linterp(); 40 | lispval matom(); 41 | lispval mfun(); 42 | lispval mstr(); 43 | lispval newarray(); 44 | lispval newdot(); 45 | lispval newdoub(); 46 | lispval newfunct(); 47 | lispval newint(); 48 | lispval newsdot(); 49 | lispval newval(); 50 | lispval newhunk(); 51 | lispval pnewdot(); 52 | lispval pnewdb(); 53 | lispval pnewhunk(); 54 | lispval pnewint(); 55 | lispval pnewsdot(); 56 | lispval pnewval(); 57 | lispval popnames(); 58 | lispval r(); 59 | lispval ratomr(); 60 | lispval readr(); 61 | lispval readrx(); 62 | lispval readry(); 63 | lispval typred(); 64 | lispval unprot(); 65 | lispval verify(); 66 | struct atom * newatom(); 67 | -------------------------------------------------------------------------------- /pearl/alias.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; alias.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; Aliases for various functions -- some for history's sake, some 3 | ; for abbreviation's sake 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ; Copyright (c) 1983 , The Regents of the University of California. 6 | ; All rights reserved. 7 | ; Authors: Joseph Faletti and Michael Deering. 8 | 9 | ; For history: 10 | ;(aliasdef 'powercopy 'copy 'subr) 11 | (aliasdef 'minform 'valform 'subr) 12 | (aliasdef 'minprint 'valprint 'subr) 13 | (aliasdef 'listform 'fullform 'subr) 14 | (aliasdef 'shortform 'valform 'subr) 15 | (aliasdef 'listprint 'fullprint 'subr) 16 | (aliasdef 'shortprint 'valprint 'subr) 17 | (aliasdef 'insert-db 'insertdb 'subr) 18 | (aliasdef 'next-item 'nextitem 'subr) 19 | (aliasdef 'remove-db 'removedb 'subr) 20 | (aliasdef 'expanded-fetch 'expandedfetch 'subr) 21 | (aliasdef 'symbol-e 'symbole 'subr) 22 | (aliasdef 'combine-skels 'combineskels 'subr) 23 | (aliasdef 'quasi-quote 'quasiquote 'subr) 24 | (aliasdef 'define-set 'ordinal 'fsubr) 25 | (aliasdef 'usersave 'savefresh 'subr) 26 | (aliasdef 'user-save 'usersave 'subr) 27 | (aliasdef 'pearl-rep-loop 'pearlreploop 'subr) 28 | 29 | ; Abbreviations: 30 | (aliasdef 'cr 'create 'fsubr) 31 | (aliasdef 'dbcr 'dbcreate 'macro) 32 | (aliasdef 'ppath 'path 'macro) 33 | (aliasdef 'vp 'valprint 'subr) 34 | (aliasdef 'fp 'fullprint 'subr) 35 | (aliasdef 'ap 'abbrevprint 'subr) 36 | (aliasdef 'dp 'debugprint 'subr) 37 | (aliasdef 'pdb 'printdb 'subr) 38 | 39 | ; vi: set lisp: 40 | -------------------------------------------------------------------------------- /franz/68k/ediv.s: -------------------------------------------------------------------------------- 1 | | /* Copyright (c) 1982, Regents, University of California */ 2 | .text 3 | .globl _ediv 4 | _ediv: 5 | link a6,#-.F1 6 | tstb sp@(-132) 7 | moveml #.S1,a6@(-.F1) 8 | movl a6@(8),a5 9 | movl a5@,d7 10 | movl a5@(4),d6 11 | moveq #0,d5 12 | moveq #0,d4 13 | movl a6@(0xc),d3 14 | clrb a6@(0xfffffffd) 15 | clrb a6@(0xfffffffb) 16 | movl d7,a6@(0xfffffff4) 17 | jge .L13 18 | eorb #1,a6@(0xfffffffd) 19 | negl d6 20 | negxl d7 21 | .L13: 22 | tstl d3 23 | jge .L16 24 | eorb #1,a6@(0xfffffffd) 25 | negl d3 26 | .L16: 27 | tstl d3 28 | jne .L17 29 | clrl a5@ 30 | movl a6@(0x10),a0 31 | movb #1,a0@ 32 | movl d6,d0 33 | jra .L12 34 | .L17: 35 | movw #0x20,a6@(0xfffffffe) 36 | jra .L20 37 | .L20001: 38 | lsll #1,d3 39 | addqw #1,a6@(0xfffffffe) 40 | addql #1,d5 41 | .L20: 42 | cmpl #0x40000000,d3 43 | jcs .L20001 44 | cmpl d3,d7 45 | jcs .L24 46 | subl d3,d7 47 | addql #1,d4 48 | jra .L24 49 | .L20003: 50 | lsll #1,d6 51 | roxll #1,d7 52 | asll #1,d4 53 | cmpl d3,d7 54 | jcs .L26 55 | subl d3,d7 56 | addql #1,d4 57 | .L26: 58 | tstl d4 59 | jge .L22 60 | movl a6@(0x10),a0 61 | movb #1,a0@ 62 | .L22: 63 | subqw #1,a6@(0xfffffffe) 64 | .L24: 65 | tstw a6@(0xfffffffe) 66 | jne .L20003 67 | lsrl d5,d7 68 | tstl a6@(0xfffffff4) 69 | jge .L28 70 | negl d7 71 | .L28: 72 | movl d7,a5@ 73 | andl #0x7fffffff,d4 74 | tstb a6@(0xfffffffd) 75 | jeq .L29 76 | negl d4 77 | .L29: 78 | movl d4,d0 79 | .L12: 80 | moveml a6@(-.F1),#0x20f8 81 | unlk a6 82 | rts 83 | .F1 = 36 84 | .S1 = 0x20f8 85 | | end 86 | .data 87 | -------------------------------------------------------------------------------- /liszt/cmake.l: -------------------------------------------------------------------------------- 1 | ; file which loads in all the object files and dumps them 2 | 3 | ; $Header: cmake.l,v 1.7 87/12/15 16:57:01 sklower Exp $ 4 | 5 | ; -[Sat Aug 13 18:03:38 1983 by layer]- 6 | 7 | ;--- genl :: generate liszt 8 | ; args are unevalated. first arg is the name of the liszt to build 9 | ; other args [optional]: slow - build interpreted. 10 | ; 11 | (defun genl fexpr (args) 12 | (let ((dumpname (car args)) 13 | (slowp (memq 'slow (cdr args)))) 14 | (load 'fcninfo) ; in /usr/lib/lisp (not normally in lisp) 15 | (if slowp then (load '../cmacros.l)) 16 | (mapc '(lambda (name) 17 | (if slowp 18 | then ; lisp source is in .. 19 | (load (concat "../" name ".l")) 20 | else ; objects are in . 21 | (load name))) 22 | '(decl array vector datab expr io funa funb func tlev 23 | instr fixnum util lversion)) 24 | (allocate 'list 400) 25 | (allocate 'fixnum 10) 26 | (allocate 'symbol 50) 27 | (sstatus translink on) 28 | (if slowp then (setq displace-macros t)) 29 | (sstatus nofeature for-vax) ; remove memory of what it was compiled for 30 | (sstatus nofeature for-tahoe) 31 | (sstatus nofeature for-68k) 32 | ;indicate type of compiler (np and lbot in global registers) 33 | (setq $global-reg$ (not (status feature no-global-reg))) 34 | (putprop 'chead nil 'version) ; so the compiler can compile itself 35 | (setq ER%tpl 'break-err-handler) ; in case we are using another tpl 36 | ; this is a temporary measure 37 | (apply 'dumplisp (list dumpname)))) 38 | -------------------------------------------------------------------------------- /pearl/pearlbulk.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; pearlbulk.l ;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; This file is the second half of PEARL for compiling in two pieces. 3 | ; It loads "pearlbase.o" and then "includes" the rest of PEARL. 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ; Copyright (c) 1983 , The Regents of the University of California. 6 | ; All rights reserved. 7 | ; Authors: Joseph Faletti and Michael Deering. 8 | 9 | (eval-when (compile) 10 | ; To cut down on the number of garbage collects during compilation. 11 | (allocate 'list 800) 12 | (allocate 'symbol 200) 13 | (allocate 'fixnum 10) 14 | (fasl 'pearlbase) 15 | (load 'franz.l) 16 | (declare (special defmacro-for-compiling)) 17 | (setq defmacro-for-compiling t)) 18 | 19 | (declare (macros t)) 20 | (declare (localf enforcetype buildvalue 21 | insidescopy insidepatternize insidevarreplace 22 | followpath convertpreds revassq 23 | recursetoinsidestandardfetch gethashvalue insertbyfocus 24 | removebyfocus 25 | prefix addhistory read-in-startprl-file read-in-initprl-file)) 26 | 27 | (include create.l) 28 | (include scopy.l) 29 | (include path.l) 30 | (include print.l) 31 | (include hash.l) 32 | (include match.l) 33 | (include history.l) 34 | (include toplevel.l) 35 | 36 | ; This is a version of the usual library file fix.l 37 | ; with "print"s changed to "pearlfixprintfn". 38 | ; It should only be left out after changing the toplevel stuff to 39 | ; not call the fixit debugger. 40 | (include fix.l) 41 | 42 | (include alias.l) 43 | (include inits.l) 44 | 45 | ; vi: set lisp: 46 | -------------------------------------------------------------------------------- /franz/tahoe/pushframe.s: -------------------------------------------------------------------------------- 1 | /* 2 | * pushframe : stack a frame 3 | * mess with the standard calls/callf call frame to put things in 4 | * the proper order. On entry to _Pushframe we have: 5 | * On entry to Pushframe: On exit: 6 | * ______________ ______________ 7 | * | second arg | | second arg | 8 | * +------------+ +------------+ 9 | * | first arg | | first arg | 10 | * +------------+ +------------+ 11 | * | 'class' arg| | 'class' arg| 12 | * +------------+ +------------+ 13 | * | saved fp | <<= fp | return addr| 14 | * +------------+ +------------+ 15 | * |mask|removed| | old _errp | 16 | * +------------+ +------------+ 17 | * |return addr.| <<= sp | saved _bnp | 18 | * +------------+ +------------+ 19 | * | saved _np | 20 | * +------------+ 21 | * | saved lbot | <<= d0 22 | * +------------+ 23 | * | saved r13 | 24 | * | ... | 25 | * | saved r8 | <<= sp 26 | * +------------+ 27 | */ 28 | .text 29 | .globl _Pushframe 30 | .globl _qpushframe 31 | 32 | _qpushframe: 33 | _Pushframe: 34 | .word 0x0 35 | movl (fp),fp # give user his fp back 36 | movl (sp),r0 # put program counter in temporary 37 | moval 12(sp),sp # remove pc, 'mask', 'removed', and fp 38 | pushl r0 # stack the return address 39 | pushl _errp 40 | pushl _bnp 41 | pushl r6 # save _np 42 | pushl r7 # save _lbot 43 | moval (sp),r0 # return addr of lbot on stack to caller 44 | moval -24(sp),sp 45 | storer $0x3f00,(sp) # save r13(fp), r12,r11,r10,r9,r8 46 | clrl _retval # set retval to C_INITIAL 47 | jmp *40(sp) # return to caller 48 | -------------------------------------------------------------------------------- /franz/68k/mulbig.c: -------------------------------------------------------------------------------- 1 | /* 2 | * $Header: mulbig.c,v 1.2 83/11/26 12:13:29 sklower Exp $ 3 | * $Locker: $ 4 | * 5 | * Copyright (c) 1982, Regents, University of California 6 | * 7 | */ 8 | 9 | #include "global.h" 10 | 11 | struct s_dot { long I; struct s_dot *CDR; }; 12 | struct vl { long high; long low; }; 13 | 14 | struct s_dot *mulbig(a,b) 15 | struct s_dot *a, *b; 16 | { 17 | int la = 1, lb = 1; 18 | long *sa, *sb, *sc, *base, *alloca(); 19 | struct s_dot *export(); 20 | register struct s_dot *p; 21 | register int *q, *r, *s; 22 | long carry = 0, test; 23 | struct vl work; 24 | Keepxs(); 25 | 26 | /* compute lengths */ 27 | 28 | for(p = a; p->CDR; p = p->CDR) la++; 29 | for(p = b; p->CDR; p = p->CDR) lb++; 30 | 31 | /* allocate storage areas on the stack */ 32 | 33 | base = alloca((la + la + lb + lb + 1)*sizeof(long)); 34 | sc = base + la + lb + 1; 35 | sb = sc + lb; 36 | sa = sb + la; 37 | q = sa; 38 | 39 | /* copy s_dots onto stack */ 40 | p = a; 41 | do { *--q = p->I; p = p->CDR; } while (p); 42 | p = b; 43 | do { *--q = p->I; p = p->CDR; } while (p); 44 | while(q > base) *--q = 0; /* initialize target */ 45 | 46 | /* perform the multiplication */ 47 | for(q = sb; q > sc; *--s = carry) 48 | for((r = sa, s = (q--) - lb, carry = 0); r > sb;) 49 | { 50 | carry += *--s; 51 | emul(*q,*--r,carry,&work); 52 | test = work.low; 53 | carry = work.high << 2; 54 | if(test < 0) carry += 2; 55 | if(test & 0x40000000) carry +=1; 56 | *s = test & 0x3fffffff; 57 | } 58 | 59 | p = export(sc,base); 60 | Freexs(); 61 | return(p); 62 | } 63 | -------------------------------------------------------------------------------- /liszt/68k/Makefile2: -------------------------------------------------------------------------------- 1 | #make .s files 2 | 3 | Liszt = ./nliszt 4 | Flg = -Sqa 5 | X = ./ 6 | 7 | DotSSrc = $(X)array.s $(X)cmacros.s $(X)datab.s $(X)decl.s\ 8 | $(X)expr.s $(X)fixnum.s $(X)funa.s $(X)funb.s $(X)func.s $(X)io.s\ 9 | $(X)lversion.s $(X)tlev.s $(X)util.s $(X)vector.s $(X)instr.s 10 | 11 | .DEFAULT:xtra 12 | 13 | xtra: ${DotSSrc} 14 | 15 | scriptcatxtra: 16 | @../../scriptcat . liszt/68k ${DotSSrc} 17 | 18 | $(X)array.s: ../array.l 19 | ${Liszt} ${Flg} ../array.l -o $(X)array.s 20 | 21 | $(X)instr.s: ../instr.l 22 | ${Liszt} ${Flg} ../instr.l -o $(X)instr.s 23 | 24 | $(X)vector.s: ../vector.l 25 | ${Liszt} ${Flg} ../vector.l -o $(X)vector.s 26 | 27 | $(X)datab.s: ../datab.l 28 | ${Liszt} ${Flg} ../datab.l -o $(X)datab.s 29 | 30 | $(X)decl.s: ../decl.l 31 | ${Liszt} ${Flg} ../decl.l -o $(X)decl.s 32 | 33 | $(X)expr.s: ../expr.l 34 | ${Liszt} ${Flg} ../expr.l -o $(X)expr.s 35 | 36 | $(X)fixnum.s: ../fixnum.l 37 | ${Liszt} ${Flg} ../fixnum.l -o $(X)fixnum.s 38 | 39 | $(X)funa.s: ../funa.l 40 | ${Liszt} ${Flg} ../funa.l -o $(X)funa.s 41 | 42 | $(X)funb.s: ../funb.l 43 | ${Liszt} ${Flg} ../funb.l -o $(X)funb.s 44 | 45 | $(X)func.s: ../func.l 46 | ${Liszt} ${Flg} ../func.l -o $(X)func.s 47 | 48 | $(X)io.s: ../io.l 49 | ${Liszt} ${Flg} ../io.l -o $(X)io.s 50 | 51 | $(X)tlev.s: ../tlev.l 52 | ${Liszt} ${Flg} ../tlev.l -o $(X)tlev.s 53 | 54 | $(X)util.s: ../util.l 55 | ${Liszt} ${Flg} ../util.l -o $(X)util.s 56 | 57 | $(X)lversion.s: ../lversion.l 58 | ${Liszt} ${Flg} ../lversion.l -o $(X)lversion.s 59 | 60 | $(X)cmacros.s: ../cmacros.l 61 | ${Liszt} ${Flg} ../cmacros.l -o $(X)cmacros.s 62 | -------------------------------------------------------------------------------- /pearl/pearl.1: -------------------------------------------------------------------------------- 1 | .TH PEARL 1 "29 March 1983" 2 | .UC 4 3 | .SH NAME 4 | pearl \- P\s-2EARL\s0 AI programming language 5 | .SH SYNOPSIS 6 | .B pearl 7 | .SH DESCRIPTION 8 | .I Pearl 9 | is an AI programming language built on top of F\s-2RANZ\s0\ L\s-2ISP\s0. 10 | P\s-2EARL\s0 (Package for Efficient Access to Representations in Lisp) 11 | was developed with space and time efficiencies in mind. 12 | In addition to providing the usual AI facilities such as slot-filler 13 | objects, demons and associative data bases, 14 | P\s-2EARL\s0 introduces stronger typing on slots, 15 | user-assisted hashing mechanisms, 16 | and a forest of data bases. 17 | .LP 18 | There are too many functions to list here; one should refer to the 19 | reports listed below. 20 | .SH AUTHORS 21 | P\s-2EARL\s0 was implemented at Berkeley by Joseph Faletti and Michael Deering 22 | under the direction of Robert Wilensky. 23 | P\s-2EARL\s0 was originally implemented under UCILisp on a DEC 2040, moved 24 | without modification to a PDP 10 under TOPS 10, and then (with 25 | significant modification) to a VAX 11/780 under F\s-2RANZ\s0\ L\s-2ISP\s0. 26 | .SH SEE ALSO 27 | Deering, M., Faletti, J., and Wilensky, R. 1981. 28 | P\s-2EARL\s0: An Efficient Language for Artificial Intelligence Programming. 29 | In the 30 | .I 31 | Proceedings of the Seventh International Joint Conference on Artificial Intelligence. 32 | .R 33 | Vancouver, British Columbia. August, 1981. 34 | .br 35 | .sp 1 36 | Deering, M., Faletti, J., and Wilensky, R. 1982. 37 | .I 38 | The P\s-2EARL\s0 Users Manual. 39 | .R 40 | Berkeley Electronic Research Laboratory Memorandum No. 41 | UCB/ERL/M82/19. March, 1982. 42 | -------------------------------------------------------------------------------- /franz/68k/nargs.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | #define ADDQ 5 3 | #define ADD 13 4 | #define IMMED 074 5 | /* These structures are here for looks, only */ 6 | struct add { short op:4, reg:3, mode:3, ea:6; } x; 7 | struct addq { short op:4, data:3, size:3, ea:6; } y; 8 | nargs(arg) 9 | long arg; /* this is only here for address calculation */ 10 | { 11 | register long *a5; 12 | register handy; 13 | register char reg, mode, ea; 14 | #define size mode 15 | #define data reg 16 | 17 | a5 = (&arg) - 2; /* this points to old a6 */ 18 | a5 = (long *) *a5; /* a5 now = my parents a6 */ 19 | a5 = (long *) a5[1]; /* pick up return address into a5 */ 20 | 21 | handy = * (short *)a5; 22 | ea = handy & 077; handy >>= 6; 23 | mode = handy & 07; handy >>= 3; 24 | reg = handy & 07; handy >>= 3; 25 | /* op = handy & 017; */ 26 | switch(handy & 017) { 27 | case ADD: 28 | if(reg!=7) 29 | return(0); /* this instruction doesn't adjust the sp */ 30 | if(ea!=IMMED) 31 | return(0); /* too hard to decode adjustment */ 32 | handy = (long) (1 + (short *) a5); 33 | if(mode==03) { /* addw #n,a7 */ 34 | handy = *(short *)handy; 35 | return(handy >> 2); 36 | } 37 | if(mode==07) { /* addl #n,a7 */ 38 | handy = *(long *)handy; 39 | return(handy >> 2); 40 | } 41 | else return(0); /* this was doing something to d7 */ 42 | case ADDQ: 43 | if(ea!=017) 44 | return(0); /* this doesn't adjust a7 */ 45 | if(size!=02) 46 | return(0); /* should complain -- we are doing 47 | addq[bw] something,a7 */ 48 | switch(data) { 49 | case 0: return(2); 50 | case 4: return(1); 51 | } 52 | } 53 | return(0); 54 | } 55 | -------------------------------------------------------------------------------- /franz/68k/dmlad.s: -------------------------------------------------------------------------------- 1 | | /* Copyright (c) 1982, Regents, University of California */ 2 | .data 3 | .text 4 | .globl _dmlad 5 | _dmlad: 6 | link a6,#-.F1 7 | tstb sp@(-132) 8 | moveml #.S1,a6@(-.F1) 9 | movl a6@(12),d7 10 | movl a6@(16),d6 11 | |l 8 12 | movl a6@(8),a5 13 | |e 8 14 | .L15: 15 | |l 12 16 | pea a6@(0xfffffff8) 17 | movl d6,sp@- 18 | movl d7,sp@- 19 | movl a5@,sp@- 20 | jsr _emul 21 | addl #16,sp 22 | |e 12 23 | |l 13 24 | movl a6@(0xfffffff8),d6 25 | |e 13 26 | |l 14 27 | asll #2,d6 28 | |e 14 29 | |l 15 30 | tstl a6@(0xfffffffc) 31 | bge .L17 32 | |e 15 33 | |l 15 34 | addql #2,d6 35 | |e 15 36 | .L17: 37 | |l 16 38 | movl a6@(0xfffffffc),d0 39 | asll #1,d0 40 | tstl d0 41 | bge .L18 42 | |e 16 43 | |l 16 44 | addql #1,d6 45 | |e 16 46 | .L18: 47 | |l 17 48 | movl a6@(0xfffffffc),d0 49 | andl #0x3fffffff,d0 50 | movl d0,a5@ 51 | |e 17 52 | |l 18 53 | tstl a5@(4) 54 | bne .L19 55 | |e 18 56 | bra .L14 57 | .L19: 58 | |l 19 59 | movl a5@(4),a5 60 | |e 19 61 | .L13: 62 | bra .L15 63 | .L14: 64 | |l 21 65 | tstl d6 66 | beq .L20 67 | |e 21 68 | |l 24 69 | cmpl #0xffffffff,d6 70 | bne .L22 71 | |e 24 72 | |l 25 73 | orl #0xc0000000,a5@ 74 | |e 25 75 | bra .L23 76 | .L22: 77 | |l 27 78 | jsr _newdot 79 | movl d0,a5@(4) 80 | movl a5@(4),a5 81 | |e 27 82 | |l 28 83 | movl d6,a5@ 84 | |e 28 85 | |l 29 86 | clrl a5@(4) 87 | |e 29 88 | .L23: 89 | .L20: 90 | |l 32 91 | movl a6@(8),d0 92 | |e 32 93 | bra .L12 94 | bra .L12 95 | .L12: moveml a6@(-.F1),#0x20c0 96 | unlk a6 97 | rts 98 | .F1 = 20 99 | .S1 = 0x20c0 100 | | end 101 | .data 102 | -------------------------------------------------------------------------------- /franz/tahoe/mulbig.c: -------------------------------------------------------------------------------- 1 | /* 2 | * 3 | * Copyright (c) 1982, Regents, University of California 4 | * 5 | */ 6 | 7 | #include "global.h" 8 | 9 | struct s_dot 10 | {long I; 11 | struct s_dot *CDR; 12 | }; 13 | struct vl 14 | {long high; 15 | long low; 16 | }; 17 | 18 | struct s_dot *mulbig(a,b) 19 | struct s_dot *a, *b; 20 | { 21 | int la = 1, lb = 1; 22 | long *sa, *sb, *sc, *base, *alloca(); 23 | struct s_dot *export(); 24 | register struct s_dot *p; 25 | register int *q, *r, *s; 26 | long carry = 0, test; 27 | struct vl work; 28 | Keepxs(); 29 | 30 | /* compute lengths */ 31 | 32 | for(p = a; p->CDR; p = p->CDR) la++; 33 | for(p = b; p->CDR; p = p->CDR) lb++; 34 | 35 | /* allocate storage areas on the stack */ 36 | 37 | base = alloca((la + la + lb + lb + 1)*sizeof(long)); 38 | sc = base + la + lb + 1; 39 | sb = sc + lb; 40 | sa = sb + la; 41 | q = sa; 42 | 43 | /* copy s_dots onto stack */ 44 | p = a; 45 | do { *--q = p->I; p = p->CDR; } while (p); 46 | p = b; 47 | do { *--q = p->I; p = p->CDR; } while (p); 48 | while(q > base) *--q = 0; /* initialize target */ 49 | 50 | /* perform the multiplication */ 51 | for(q = sb; q > sc; *--s = carry) 52 | for((r = sa, s = (q--) - lb, carry = 0); r > sb;) 53 | { 54 | carry += *--s; 55 | --r; 56 | asm("emul (r11),(r10),-80(fp),-92(fp)"); 57 | /* emul(*q,*--r,carry,&work); */ 58 | test = work.low; 59 | carry = work.high << 2; 60 | if(test < 0) carry += 2; 61 | if(test & 0x40000000) carry +=1; 62 | *s = test & 0x3fffffff; 63 | } 64 | 65 | p = export(sc,base); 66 | Freexs(); 67 | return(p); 68 | } 69 | -------------------------------------------------------------------------------- /franz/h/frame.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 13:55:13 1983 by jkf]- 2 | * frame.h $Locker: $ 3 | * non local goto frame definition 4 | * 5 | * $Header: frame.h,v 1.3 83/09/12 15:29:08 sklower Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | /* classes of frames: */ 11 | #define F_PROG 1 12 | #define F_CATCH 2 13 | #define F_RESET 3 14 | #define F_EVAL 4 15 | #define F_FUNCALL 5 16 | #define F_TO_FORT 6 17 | #define F_TO_LISP 7 18 | 19 | /* classes of things thrown up */ 20 | #define C_INITIAL 0 21 | #define C_GO 1 22 | #define C_RET 2 23 | #define C_THROW 3 24 | #define C_RESET 4 25 | #define C_FRETURN 5 26 | 27 | 28 | /* the evaluation frame sits on the C runtime stack. the global variable errp 29 | points to the newest frame. The base of the frame points in the middle 30 | of the frame, but in such a way that above the frame base the contents 31 | are the same for all implementation, and below it there are different 32 | saved registers for each machine. 33 | */ 34 | 35 | struct frame 36 | { 37 | struct argent *svlbot, *svnp; 38 | struct nament *svbnp; 39 | struct frame *olderrp; 40 | lispval retaddr; 41 | long class; 42 | lispval larg1; /* optional */ 43 | lispval larg2; /* optional */ 44 | }; 45 | 46 | extern struct frame *errp, *Pushframe(), *Ipushf(); 47 | 48 | /* stuff for IBM, RIDGE, DEC-VMS CC, maybe Bellmac-32 49 | * 50 | * The non obvious requirement is that any new function 51 | * requiring a Pushframe must declare 52 | * 53 | * pbuf pb; 54 | * 55 | * as well. 56 | */ 57 | 58 | #ifdef SPISFP 59 | #define Pushframe(a,b,c) Ipushf(a,b,c,&pb) 60 | #endif 61 | 62 | 63 | typedef struct pframe 64 | { 65 | long regs[16]; 66 | struct frame f; 67 | } pbuf; 68 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 1990 The Regents of the University of California. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. All advertising materials mentioning features or use of this software 15 | must display the following acknowledgement: 16 | 17 | This product includes software developed by the University of 18 | California, Berkeley and its contributors. 19 | 20 | 4. Neither the name of the University nor the names of its contributors 21 | may be used to endorse or promote products derived from this software 22 | without specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 25 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 26 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 27 | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 28 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 29 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 30 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 31 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 33 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 34 | SUCH DAMAGE. 35 | -------------------------------------------------------------------------------- /lisplib/structini.l: -------------------------------------------------------------------------------- 1 | ;;;-*-lisp-*- 2 | (setq rcs-strictini- 3 | "$Header: /usr/lib/lisp/structini.l,v 1.1 83/01/29 18:40:11 jkf Exp $") 4 | 5 | #+franz 6 | (declare (macros t)) 7 | 8 | (defmacro defstruct ((name . opts) . slots) 9 | (let ((dp (cadr (assq ':default-pointer opts))) 10 | (conc-name (cadr (assq ':conc-name opts))) 11 | (cons-name (implode (append '(m a k e -) (explodec name))))) 12 | #Q (fset-carefully cons-name '(macro . initial_defstruct-cons)) 13 | #M (putprop cons-name 'initial_defstruct-cons 'macro) 14 | #F (putd cons-name '(macro (x) (initial_defstruct-cons x))) 15 | (do ((i 0 (1+ i)) 16 | (l slots (cdr l)) 17 | (foo nil (cons (list slot init) foo)) 18 | (chars (explodec conc-name)) 19 | (slot) (acsor) (init)) 20 | ((null l) 21 | (putprop cons-name foo 'initial_defstruct-inits) 22 | `',name) 23 | (cond ((atom (car l)) 24 | (setq slot (car l)) 25 | (setq init nil)) 26 | (t (setq slot (caar l)) 27 | (setq init (cadar l)))) 28 | (setq acsor (implode (append chars (explodec slot)))) 29 | (putprop acsor dp 'initial_defstruct-dp) 30 | #Q (fset-carefully acsor '(macro . initial_defstruct-ref)) 31 | #M (putprop acsor 'initial_defstruct-ref 'macro) 32 | #F (putd acsor '(macro (x) (initial_defstruct-ref x))) 33 | (putprop acsor i 'initial_defstruct-i)))) 34 | 35 | (defun initial_defstruct-ref (form) 36 | (let ((i (get (car form) 'initial_defstruct-i)) 37 | (p (if (null (cdr form)) 38 | (get (car form) 'initial_defstruct-dp) 39 | (cadr form)))) 40 | #-Multics `(nth ,i ,p) 41 | #+Multics `(car ,(do ((i i (1- i)) 42 | (x p `(cdr ,x))) 43 | ((zerop i) x))) 44 | )) 45 | 46 | (defun initial_defstruct-cons (form) 47 | (do ((inits (get (car form) 'initial_defstruct-inits) 48 | (cdr inits)) 49 | (gen (gensym)) 50 | (x nil (cons (or (get form (caar inits)) 51 | (cadar inits)) 52 | x))) 53 | ((null inits) 54 | `(list . ,x)))) 55 | 56 | -------------------------------------------------------------------------------- /franz/h/chars.h: -------------------------------------------------------------------------------- 1 | /* -[Sat Jan 29 13:52:05 1983 by jkf]- 2 | * chars.h $Locker: $ 3 | * lexical table 4 | * 5 | * $Header: /na/franz/franz/h/chars.h,v 1.1 83/01/29 14:03:08 jkf Exp $ 6 | * 7 | * (c) copyright 1982, Regents of the University of California 8 | */ 9 | 10 | /* the format of the entries are: ab..xxxx */ 11 | /* */ 12 | /* where a is set iff the atom containing the symbol must be quoted */ 13 | /* where b is set iff the character separates atoms normally */ 14 | /* where xxxx is a number unique to the class of symbol */ 15 | 16 | #define CNUM 0000 17 | #define CSIGN 0001 18 | #define CCHAR 0002 19 | #define CLPARA 0003 20 | #define CRPARA 0004 21 | #define CPERD 0005 22 | #define CLBRCK 0006 23 | #define CRBRCK 0007 24 | #define CSQ 0011 25 | #define CDQ 0012 26 | #define CERR 0013 27 | #define CSEP 0014 28 | #define CSPL 0015 29 | #define CMAC 0016 30 | #define CESC 0017 31 | #define CSCA 0020 32 | #define CSD 0021 33 | #define CSMAC 0022 34 | #define CSSPL 0023 35 | #define CINF 0024 36 | #define CSINF 0025 37 | 38 | #define VNUM 0000 39 | #define VMINUS 0001 40 | #define VSIGN 0001 41 | #define VCHAR 0002 42 | #define VLPARA (CLPARA|QALWAYS|SEPMASK) 43 | #define VRPARA (CRPARA|QALWAYS|SEPMASK) 44 | #define VPERD (CPERD|QWNUNIQ) 45 | #define VLBRCK (CLBRCK|QALWAYS|SEPMASK) 46 | #define VRBRCK (CRBRCK|QALWAYS|SEPMASK) 47 | #define VSQ (CSQ|QALWAYS|SEPMASK) 48 | #define VDQ (CDQ|QALWAYS) 49 | #define VERR (CERR|QALWAYS|SEPMASK) 50 | #define VSEP (CSEP|QALWAYS|SEPMASK) 51 | #define VSPL (CSPL|QALWAYS|SEPMASK) 52 | #define VMAC (CMAC|QALWAYS|SEPMASK) 53 | #define VESC (CESC|QALWAYS) 54 | #define VSCA (CSCA|SEPMASK) 55 | #define VSD (CSD|QALWAYS) 56 | #define VSMAC (CSMAC|QWNUNIQ) 57 | #define VSSPL (CSSPL|QWNUNIQ) 58 | #define VINF 0024 59 | #define VSINF (CSINF|QWNUNIQ) 60 | 61 | 62 | #define QUTMASK 0300 63 | #define SEPMASK 0040 64 | #define QALWAYS 0300 65 | #define QWNUNIQ 0100 66 | #define QWNFRST 0200 67 | 68 | #define synclass(p) (p & 037) 69 | 70 | #define TSCA 1 71 | #define TLPARA 2 72 | #define TRPARA 3 73 | #define TPERD 4 74 | #define TEOF 5 75 | #define TSPL 6 76 | #define TMAC 7 77 | #define TSQ 8 78 | #define TLBKT 9 79 | #define TINF 10 80 | -------------------------------------------------------------------------------- /lisplib/ucido.l: -------------------------------------------------------------------------------- 1 | (setq SCCS-ucido "@(#)ucido.l 1.3 6/29/81") 2 | ; 3 | ; ucilisp do loop, this is a seperate file due to conflicts with 4 | ; the franz lisp do function. To use this, one needs 5 | ; to load this file in at run time. (And have calls to 6 | ; do be close compiled in compiled code). 7 | ; 8 | ; NOTE: do is a macro and must be declared before calls to it 9 | ; in code to be compiled! 10 | ; 11 | ; to compile this file: liszt ucido.l 12 | ; 13 | (declare (macros t)) 14 | 15 | (eval-when (compile) 16 | (load 'ucifnc)) 17 | 18 | (defun do macro (l) 19 | ((lambda (dotype alist) 20 | (cond ((eq dotype 'while) 21 | (dowhile (car alist) (cdr alist))) 22 | ((eq dotype 'until) 23 | (dowhile (list 'not (car alist)) 24 | (cdr alist))) 25 | ((eq dotype 'for) 26 | (dofor (car alist) 27 | (cadr alist) 28 | (caddr alist) 29 | (cdddr alist))) 30 | (t `((lambda () 31 | ,@alist))))) 32 | (cadr l) 33 | (cddr l))) 34 | 35 | (defun dowhile (expr alist) 36 | `(prog (returnvar) 37 | loop 38 | (cond (,expr 39 | (setq returnvar ((lambda () 40 | ,@alist))) 41 | (go loop)) 42 | (t (return returnvar))))) 43 | 44 | (defun dofor (var fortype varlist stmlist) 45 | (selectq fortype 46 | (in `(prog (returnvar l1 l2) 47 | (setq l2 ',varlist) 48 | loop 49 | (setq l1 (car l2)) 50 | (setq l2 (cdr l2)) 51 | (cond ((null l1) 52 | (return returnvar))) 53 | (setq returnvar 54 | ((lambda (,var) 55 | ,@stmlist) 56 | (l1))) 57 | (go loop))) 58 | (on `(prog (returnvar l1 l2) 59 | (setq l2 ',varlist) 60 | loop 61 | (cond ((null l2) 62 | (return returnvar))) 63 | (setq returnvar 64 | ((lambda (,var) 65 | ,@stmlist) 66 | (l2))) 67 | (setq l2 (cdr l2)) 68 | (go loop))) 69 | (rpt `(prog (returnvar ,var) 70 | (setq ,var 1) 71 | loop 72 | (cond ((not (> ,var ,varlist)) 73 | (setq returnvar ((lambda () 74 | ,@stmlist))) 75 | (setq ,var (1+ ,var)) 76 | (go loop)) 77 | (t (return returnvar))))) 78 | nil)) 79 | -------------------------------------------------------------------------------- /pearl/pearl.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; pearl.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; This file is the file that should be handed to Liszt for compiling. 3 | ; It "includes" all of the files that need to be used to make 4 | ; a complete PEARL object file. 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ; Copyright (c) 1983 , The Regents of the University of California. 7 | ; All rights reserved. 8 | ; Authors: Joseph Faletti and Michael Deering. 9 | 10 | ; After compiling this file with the -r option, 11 | ; run it, 12 | ; and then run the function 13 | ; (savepearl) to save a version in the current directory 14 | ; under the name "pearl" 15 | ; or 16 | ; (savepearl ) to save a version under that name 17 | ; This will then give you a (very large) runnable version of 18 | ; Franz plus PEARL. 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | (eval-when (compile) 22 | ; To cut down on the number of garbage collects during compilation. 23 | (allocate 'list 800) 24 | (allocate 'symbol 200) 25 | (declare (special defmacro-for-compiling)) 26 | (setq defmacro-for-compiling t)) 27 | 28 | (declare (macros t)) 29 | (declare (localf enforcetype buildvalue 30 | insidescopy insidepatternize insidevarreplace 31 | followpath convertpreds revassq 32 | recursetoinsidestandardfetch gethashvalue insertbyfocus 33 | removebyfocus 34 | prefix addhistory read-in-startprl-file read-in-initprl-file)) 35 | 36 | (include ucisubset.l) 37 | ; Version numbers are in here. 38 | (include franz.l) 39 | (include lowlevel.l) 40 | (include db.l) 41 | (include vars.l) 42 | (include symord.l) 43 | (include hook.l) 44 | (include create.l) 45 | (include scopy.l) 46 | (include path.l) 47 | (include print.l) 48 | (include hash.l) 49 | (include match.l) 50 | (include history.l) 51 | (include toplevel.l) 52 | 53 | ; This is a version of the usual library file fix.l 54 | ; with "print"s changed to "pearlfixprintfn". 55 | ; It should only be left out after changing the toplevel stuff to 56 | ; not call the fixit debugger. 57 | (include fix.l) 58 | 59 | (include alias.l) 60 | (include inits.l) 61 | 62 | ; vi: set lisp: 63 | -------------------------------------------------------------------------------- /franz/68k/mlsb.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1982, Regents, University of California */ 2 | 3 | struct vl { long high; long low; }; 4 | long 5 | mlsb(utop,ubot,vtop,nqhat) 6 | register long *utop, *ubot, *vtop; 7 | register nqhat; 8 | { 9 | register handy, carry; 10 | struct vl work; 11 | 12 | for(carry = 0; utop >= ubot; utop--) { 13 | emul(nqhat,*--vtop,carry+*utop,&work); 14 | carry = work.high; 15 | handy = work.low; 16 | *utop = handy & 0x3fffffff; 17 | carry <<= 2; 18 | if(handy & 0x80000000) carry += 2; 19 | if(handy & 0x40000000) carry += 1; 20 | } 21 | return(carry); 22 | } 23 | long 24 | adback(utop,ubot,vtop) 25 | register long *utop, *ubot, *vtop; 26 | { 27 | register handy, carry; 28 | carry = 0; 29 | for(; utop >= ubot; utop--) { 30 | carry += *--vtop; 31 | carry += *utop; 32 | *utop = carry & 0x3fffffff; 33 | /* next junk is faster version of carry >>= 30; */ 34 | handy = carry; 35 | carry = 0; 36 | if(handy & 0x80000000) carry -= 2; 37 | if(handy & 0x40000000) carry += 1; 38 | } 39 | return(carry); 40 | } 41 | long dsdiv(top,bot,div) 42 | register long *top, *bot; 43 | register long div; 44 | { 45 | struct vl work; char err; 46 | register long handy, carry = 0; 47 | for(carry = 0;bot <= top; bot++) { 48 | handy = *bot; 49 | if(carry & 1) handy |= 0x40000000; 50 | if(carry & 2) handy |= 0x80000000; 51 | carry >>= 2; 52 | work.low = handy; 53 | work.high = carry; 54 | *bot = ediv(&work,div,&err); 55 | carry = work.high; 56 | } 57 | return(carry); 58 | } 59 | dsadd1(top,bot) 60 | long *top, *bot; 61 | { 62 | register long *p, work, carry = 0; 63 | 64 | /* 65 | * this assumes canonical inputs 66 | */ 67 | for(p = top; p >= bot; p--) { 68 | work = *p + carry; 69 | *p = work & 0x3fffffff; 70 | carry = 0; 71 | if (work & 0x40000000) carry += 1; 72 | if (work & 0x80000000) carry -= 2; 73 | } 74 | p[1] = work; 75 | } 76 | long 77 | dsrsh(top,bot,ncnt,mask1) 78 | long *top, *bot; 79 | long ncnt, mask1; 80 | { 81 | register long *p = bot; 82 | register r = -ncnt, l = 30+ncnt, carry = 0, work, save; 83 | long mask = -1 ^ mask1; 84 | 85 | while(p <= top) { 86 | save = work = *p; save &= mask; work >>= r; 87 | carry <<= l; work |= carry; *p++ = work; 88 | carry = save; 89 | } 90 | return(carry); 91 | } 92 | -------------------------------------------------------------------------------- /utils/append.c: -------------------------------------------------------------------------------- 1 | static char *rcsid = 2 | "$Header: append.c,v 1.2 84/01/22 04:07:25 sklower Exp $"; 3 | 4 | /* 5 | * append: append a tail to a list of roots or prepend a head to a list 6 | * of tails. 7 | * use: 8 | * append tail root1 root2 ... rootn 9 | * result: 10 | * root1tail root2tail ... rootntail 11 | * or 12 | * append -p root tail1 tail2 ... tailn 13 | * result: 14 | * roottail1 roottail2 ... roottailn 15 | * 16 | * or 17 | * append -s xtail root1xoldt root2xoldt ... 18 | * result: 19 | * root1xtail root2xtail ... 20 | * that is, each root is tested for the presence of 'x', the first character 21 | * in the tail. If it is present, then all characters beyond it are thrown 22 | * away before merging. This is useful for things like 23 | * append -s .c foo.o bar.o baz.o =>> foo.c bar.c baz.c 24 | * 25 | * Useful in Makefiles due to the lack of such facilities in make. 26 | * 27 | */ 28 | #include 29 | #include "lconf.h" 30 | #include "config.h" 31 | #if os_unix_ts || os_masscomp 32 | #define rindex strrchr 33 | #endif 34 | 35 | char buffer[2000]; /* nice and big */ 36 | char *rindex(); 37 | 38 | main(argc,argv) 39 | char **argv; 40 | { 41 | int i, base; 42 | int prepend = 0, 43 | append = 0, 44 | strip = 0; 45 | char stripchar; 46 | char *chp; 47 | 48 | if(argc <= 2) 49 | { 50 | fprintf(stderr,"use: append tail root1 root2 ... rootn\n"); 51 | exit(1); 52 | } 53 | if(argv[1][0] == '-') 54 | { 55 | switch(argv[1][1]) 56 | { 57 | case 'p' : prepend = 1; 58 | break; 59 | case 's' : strip = 1; 60 | append = 1; 61 | stripchar = argv[2][0]; /* first char of tail */ 62 | break; 63 | default: fprintf(stderr,"append: illegal switch %s\n",argv[1]); 64 | exit(1); 65 | } 66 | base = 2; 67 | } 68 | else { 69 | append = 1; 70 | base = 1; 71 | } 72 | 73 | for(i = base +1; i < argc ; i++) 74 | { 75 | if(append) 76 | { 77 | strcpy(buffer,argv[i]); 78 | if(strip && (chp = rindex(buffer,stripchar))) 79 | { 80 | *chp = '\0'; 81 | } 82 | strcat(buffer,argv[base]); 83 | } 84 | else { 85 | strcpy(buffer,argv[base]); 86 | strcat(buffer,argv[i]); 87 | } 88 | printf("%s ",buffer); 89 | } 90 | printf("\n"); 91 | exit(0); 92 | } 93 | 94 | -------------------------------------------------------------------------------- /franz/tahoe/mlsb.c: -------------------------------------------------------------------------------- 1 | /* file: mlsb.c 2 | ** functions: mlsb(), adback(), dsdiv(), dsadd1(), dsrsh() 3 | /* Copyright (c) 1982, Regents, University of California */ 4 | 5 | struct vl /* very long? */ 6 | {long high; 7 | long low; 8 | }; 9 | 10 | long mlsb(utop,ubot,vtop,nqhat) 11 | long *utop; register long *ubot, *vtop; 12 | register nqhat; 13 | { 14 | register handy, carry; 15 | struct vl work; 16 | 17 | for(carry = 0; utop >= ubot; utop--) { 18 | 19 | --vtop; 20 | asm("addl3 r8,*4(fp),r0"); 21 | asm("emul r10,(r11),r0,-60(fp)"); 22 | 23 | carry = work.high; 24 | handy = work.low; 25 | *utop = handy & 0x3fffffff; 26 | carry <<= 2; 27 | if(handy & 0x80000000) carry += 2; 28 | if(handy & 0x40000000) carry += 1; 29 | } 30 | return(carry); 31 | } 32 | 33 | long adback(utop,ubot,vtop) 34 | register long *utop, *ubot, *vtop; 35 | { 36 | register handy, carry; 37 | carry = 0; 38 | for(; utop >= ubot; utop--) { 39 | carry += *--vtop; 40 | carry += *utop; 41 | *utop = carry & 0x3fffffff; 42 | /* next junk is faster version of carry >>= 30; */ 43 | handy = carry; 44 | carry = 0; 45 | if(handy & 0x80000000) carry -= 2; 46 | if(handy & 0x40000000) carry += 1; 47 | } 48 | return(carry); 49 | } 50 | 51 | long dsdiv(top,bot,div) 52 | register long *top, *bot; 53 | register long div; 54 | { 55 | struct vl work; char err; 56 | register long handy, carry = 0; 57 | for(carry = 0;bot <= top; bot++) { 58 | handy = *bot; 59 | if(carry & 1) handy |= 0x40000000; 60 | if(carry & 2) handy |= 0x80000000; 61 | carry >>= 2; 62 | work.low = handy; 63 | work.high = carry; 64 | /* *bot = ediv(&work,div,&err); */ 65 | /* carry = work.high; */ 66 | asm("ediv r10,-60(fp),(r11),r8"); 67 | } 68 | return(carry); 69 | } 70 | 71 | dsadd1(top,bot) 72 | long *top, *bot; 73 | { 74 | register long *p, work, carry = 0; 75 | 76 | /* 77 | * this assumes canonical inputs 78 | */ 79 | for(p = top; p >= bot; p--) { 80 | work = *p + carry; 81 | *p = work & 0x3fffffff; 82 | carry = 0; 83 | if (work & 0x40000000) carry += 1; 84 | if (work & 0x80000000) carry -= 2; 85 | } 86 | p[1] = work; 87 | } 88 | 89 | long dsrsh(top,bot,ncnt,mask1) 90 | long *top, *bot; 91 | long ncnt, mask1; 92 | { 93 | register long *p = bot; 94 | register r = -ncnt, l = 30+ncnt, carry = 0, work, save; 95 | long mask = -1 ^ mask1; 96 | 97 | while(p <= top) { 98 | save = work = *p; save &= mask; work >>= r; 99 | carry <<= l; work |= carry; *p++ = work; 100 | carry = save; 101 | } 102 | return(carry); 103 | } 104 | -------------------------------------------------------------------------------- /pearl/ptags: -------------------------------------------------------------------------------- 1 | /^\(de / { print $2 " " FILENAME " /^" $0 "$/" } 2 | /^\(df / { print $2 " " FILENAME " /^" $0 "$/" } 3 | /^\(dm / { print $2 " " FILENAME " /^" $0 "$/" } 4 | /^\(drm / { print $2 " " FILENAME " /^" $0 "$/" } 5 | /^\(dsm / { print $2 " " FILENAME " /^" $0 "$/" } 6 | /^\(def/ { print $2 " " FILENAME " /^" $0 "$/" } 7 | /^\(putd / { print $2 " " FILENAME " /^" $0 "$/" } 8 | /^\(setsyntax / { print $2 " " FILENAME " /^" $0 "$/" } 9 | /^\(setq / { print $2 " " FILENAME " /^" $0 "$/" } 10 | /^\(aliasdef / { print $2 " " FILENAME " /^" $0 "$/" } 11 | /^\(create base / { print $3 " " FILENAME " /^" $0 "$/" } 12 | /^\(create individual / { print $4 " " FILENAME " /^" $0 "$/" } 13 | /^\(create pattern / { print $4 " " FILENAME " /^" $0 "$/" } 14 | /^\(create expanded / { print $4 " " FILENAME " /^" $0 "$/" } 15 | /^\(create function / { print $3 " " FILENAME " /^" $0 "$/" } 16 | /^\(dbcreate base / { print $3 " " FILENAME " /^" $0 "$/" } 17 | /^\(dbcreate individual / { print $4 " " FILENAME " /^" $0 "$/" } 18 | /^\(dbcreate pattern / { print $4 " " FILENAME " /^" $0 "$/" } 19 | /^\(dbcreate expanded / { print $4 " " FILENAME " /^" $0 "$/" } 20 | /^\(dbcreate function / { print $3 " " FILENAME " /^" $0 "$/" } 21 | /^\(cr base / { print $3 " " FILENAME " /^" $0 "$/" } 22 | /^\(cr ind / { print $4 " " FILENAME " /^" $0 "$/" } 23 | /^\(cr pat / { print $4 " " FILENAME " /^" $0 "$/" } 24 | /^\(cr exp / { print $4 " " FILENAME " /^" $0 "$/" } 25 | /^\(cr fn / { print $3 " " FILENAME " /^" $0 "$/" } 26 | /^\(dbcr base / { print $3 " " FILENAME " /^" $0 "$/" } 27 | /^\(dbcr ind / { print $4 " " FILENAME " /^" $0 "$/" } 28 | /^\(dbcr pat / { print $4 " " FILENAME " /^" $0 "$/" } 29 | /^\(dbcr exp / { print $4 " " FILENAME " /^" $0 "$/" } 30 | /^\(dbcr fn / { print $3 " " FILENAME " /^" $0 "$/" } 31 | /^\(cb / { print $2 " " FILENAME " /^" $0 "$/" } 32 | /^\(ci / { print $3 " " FILENAME " /^" $0 "$/" } 33 | /^\(cp / { print $3 " " FILENAME " /^" $0 "$/" } 34 | /^\(ce / { print $3 " " FILENAME " /^" $0 "$/" } 35 | /^\(cf / { print $2 " " FILENAME " /^" $0 "$/" } 36 | /^\(base / { print $2 " " FILENAME " /^" $0 "$/" } 37 | /^\(ind / { print $3 " " FILENAME " /^" $0 "$/" } 38 | /^\(pat / { print $3 " " FILENAME " /^" $0 "$/" } 39 | /^\(exp / { print $3 " " FILENAME " /^" $0 "$/" } 40 | /^\(fn / { print $2 " " FILENAME " /^" $0 "$/" } 41 | /^\(individual / { print $3 " " FILENAME " /^" $0 "$/" } 42 | /^\(pattern / { print $3 " " FILENAME " /^" $0 "$/" } 43 | /^\(expanded / { print $3 " " FILENAME " /^" $0 "$/" } 44 | /^\(pfunction / { print $2 " " FILENAME " /^" $0 "$/" } 45 | /^\(ordinal / { print $2 " " FILENAME " /^" $0 "$/" } 46 | -------------------------------------------------------------------------------- /lisplib/syscall.l: -------------------------------------------------------------------------------- 1 | (setq rcs-syscall- 2 | "$Header: /usr/lib/lisp/RCS/syscall.l,v 1.2 83/01/30 11:52:43 jkf Exp $") 3 | 4 | ; 5 | ; syscall 6 | ; 7 | ; This file contains macro definitions of some of the Unix system calls. 8 | ; The documentation for these system calls can be found in the Unix 9 | ; manual. 10 | ; 11 | ; It is believed that all of these system calls can be executed by the 12 | ; Unix emulator Eunice under VMS. 13 | ; 14 | ; Unix system calls which return values in registers other than r0 cannot 15 | ; be called in this way. An example of this is fork, for which there is 16 | ; a seperate lisp function. 17 | 18 | (declare (macros t)) 19 | 20 | (defmacro sys_access (name mode) 21 | `(syscall 33 ,name ,mode)) 22 | 23 | (defmacro sys_alarm (secs) 24 | `(syscall 27 ,secs)) 25 | 26 | (defmacro sys_brk (addr) 27 | `(syscall 17 ,addr)) 28 | 29 | (defmacro sys_chdir (dir) 30 | `(syscall 12 ,dir)) 31 | 32 | (defmacro sys_chmod (name mode) 33 | `(syscall 15 ,name ,mode)) 34 | 35 | (defmacro sys_chown (name ownerid groupid) 36 | `(syscall 16 name ownerid groupid)) 37 | 38 | (defmacro sys_close (filedes) 39 | `(syscall 6 ,filedes)) 40 | 41 | (defmacro sys_creat (name mode) 42 | `(syscall 8 ,name ,mode)) 43 | 44 | (defmacro sys_exit (status) 45 | `(syscall 1 ,status)) 46 | 47 | (defmacro sys_getpid nil 48 | `(syscall 20)) 49 | 50 | (defmacro sys_getuid nil 51 | `(syscall 24)) 52 | 53 | (defmacro sys_getgid nil 54 | `(syscall 47)) 55 | 56 | ; sys_kill - need to get value into r0 57 | (defmacro sys_kill (pid) 58 | `(syscall 37 ,pid)) 59 | 60 | 61 | (defmacro sys_link (name newname) 62 | `(syscall 9 ,name ,newname)) 63 | 64 | (defmacro sys_nice (value) 65 | `(syscall 34 ,value)) 66 | 67 | ; sys_lseek this may not be correct the explanation is given for a pdp-11 68 | ; where certain values must be stored in two words. 69 | ; also need to get value into r0 70 | 71 | (defmacro sys_open (name how) 72 | `(syscall 5 ,name ,how)) 73 | 74 | (defmacro sys_pause nil 75 | `(syscall 29)) 76 | 77 | (defmacro sys_setuid (uid) 78 | `(syscall 23 ,uid)) 79 | 80 | 81 | (defmacro sys_setgid (gid) 82 | `(syscall 46 ,gid)) 83 | 84 | (defmacro sys_sync nil 85 | `(syscall 36)) 86 | 87 | (defmacro sys_time nil 88 | `(syscall 13)) 89 | 90 | (defmacro sys_umask (complementmode) 91 | `(syscall 60 ,complementmode)) 92 | 93 | (defmacro sys_unlink (name) 94 | `(syscall 10 ,name)) 95 | 96 | (defmacro sys_wait nil 97 | `(syscall 7)) 98 | 99 | (defmacro sys_ioctl (portnumber arg) 100 | `(syscall 54 ,portnumber ,arg)) 101 | 102 | 103 | (putprop 'syscall t 'version) ; flag that this file has been loaded 104 | -------------------------------------------------------------------------------- /pearl/Makefile: -------------------------------------------------------------------------------- 1 | 2 | # Makefile for pearl 3 | 4 | # Read the ReadMe file for more info. 5 | # This makefile creates these things: 6 | # pearl - the executable PEARL, loaded into a lisp. 7 | # pearl.o - the object version of PEARL's functions for fasl'ing 8 | # into another lisp file at compile time. 9 | # tags - tags file for PEARL source. 10 | # 11 | 12 | # If LibDir is changed, you must also change the pathnames in pearllib.l 13 | LibDir = /usr/lib/lisp 14 | CopyTo = /dev/null 15 | ManDir = /usr/man/man1 16 | ObjDir = /usr/ucb 17 | Liszt = ${ObjDir}/liszt 18 | CdTo = .. 19 | 20 | Src = alias.l create.l db.l fix.l franz.l hash.l history.l hook.l \ 21 | inits.l lowlevel.l match.l path.l pearl.l \ 22 | pearlbase.l pearlbulk.l pearllib.l pearlsmall.l \ 23 | print.l scopy.l symord.l \ 24 | toplevel.l ucisubset.l vars.l 25 | 26 | AllSrc = Makefile ChangeLog ReadMe implement.ms ltags \ 27 | manual.ms pearl.1 ptags template update.ms ${Src} 28 | 29 | .l.o: 30 | ${Liszt} $< 31 | 32 | # Make "pearl.o" and "pearl" from scratch. 33 | # NOTE: At installations where memory is less than 2.5Mb, 34 | # "make pearl" normally makes "small" which builds PEARL in two steps. 35 | # If your installation has more memory, "pearl" can be changed to 36 | # make "big" instead. In this case, "install" below should also be 37 | # changed to make "biginstall" instead of "smallinstall". 38 | pearl: small 39 | echo "(savepearl)" | pearl.o 40 | @echo pearl done 41 | 42 | pearlbase.o: pearlbase.l 43 | 44 | pearlbulk.o: pearlbase.o pearlbulk.l 45 | 46 | small: pearlbase.o pearlbulk.o 47 | ${Liszt} -r pearlsmall.l -o pearl.o 48 | 49 | big: 50 | ${Liszt} -r pearl.l 51 | 52 | # Install the executable pearl in ObjDir and the 53 | # fasl'able pearl.o for compiling code using PEARL in LibDir. 54 | # NOTE: "install" can be changed to use "biginstall" on big enough machines. 55 | install: smallinstall 56 | 57 | smallinstall: small 58 | echo "(savepearl)" | pearl.o 59 | mv pearlbase.o ${LibDir}/pearlbase.o 60 | mv pearlbulk.o ${LibDir}/pearlbulk.o 61 | ${Liszt} -r pearllib.l -o pearl.o 62 | mv pearl.o ${LibDir}/pearl.o 63 | mv pearl ${ObjDir}/pearl 64 | cp pearl.1 ${ManDir}/pearl.1 65 | @echo pearl done 66 | 67 | biginstall: big 68 | echo "(savepearl)" | pearl.o 69 | mv pearl.o ${LibDir}/pearl.o 70 | mv pearl ${ObjDir}/pearl 71 | cp pearl.1 ${ManDir}/pearl.1 72 | @echo pearl done 73 | 74 | tags: /dev/tty ${Src} 75 | -rm -f tags 76 | awk -f ltags ${Src} | sort > tags 77 | 78 | # For distribution purposes. 79 | copysource: ${AllSrc} 80 | (tar cf - ${AllSrc} | (cd ${CopyTo} ; tar xf -)) 81 | 82 | scriptcatall: ${AllSrc} 83 | @(cd ${CdTo} ; scriptcat pearl pearl ${AllSrc}) 84 | 85 | clean: 86 | -rm -f pearl pearl.o 87 | 88 | -------------------------------------------------------------------------------- /franz/lisp.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: lisp.c,v 1.3 83/11/26 12:00:58 sklower Exp $"; 4 | #endif 5 | 6 | /* -[Sat Jan 29 13:24:33 1983 by jkf]- 7 | * lisp.c $Locker: $ 8 | * main program 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | #include "global.h" 14 | #include "frame.h" 15 | 16 | /* main *****************************************************************/ 17 | /* Execution of the lisp system begins here. This is the top level */ 18 | /* executor which is an infinite loop. The structure is similar to */ 19 | /* error. */ 20 | 21 | extern lispval reborn; 22 | extern int rlevel; 23 | static int virgin = 0; 24 | int Xargc; 25 | char **Xargv; 26 | extern char **environ; 27 | 28 | main(argc,argv,arge) 29 | char **argv,**arge; 30 | { 31 | lispval matom(), Lapply(); 32 | extern struct frame *errp; 33 | extern int holbeg,holend,usehole; 34 | extern int *curhbeg; 35 | pbuf pb; 36 | 37 | environ = arge; 38 | #if sun_4_2 || sun_4_2beta 39 | setlinebuf(stdout); 40 | #else 41 | {extern char _sobuf[]; setbuf(stdout,_sobuf);} 42 | #endif 43 | Xargc = argc; 44 | Xargv = argv; 45 | virgin = 0; 46 | errp = (struct frame *)0; 47 | initial(); 48 | 49 | errp = Pushframe(F_RESET,nil,nil); 50 | switch(retval) 51 | { 52 | case C_RESET: break; /* what to do? */ 53 | case C_INITIAL: break; /* first time */ 54 | } 55 | 56 | for(EVER) { 57 | lbot = np = orgnp; 58 | rlevel = 0; 59 | depth = 0; 60 | clearerr(piport = stdin); 61 | clearerr(poport = stdout); 62 | np++->val = matom("top-level"); 63 | np++->val = nil; 64 | Lapply(); 65 | } 66 | } 67 | 68 | lispval 69 | Ntpl() 70 | { 71 | lispval Lread(),Istsrch(); 72 | 73 | if (virgin == 0) { 74 | fputs((char *)Istsrch(matom("version"))->d.cdr->d.cdr->d.cdr,poport); 75 | virgin = 1; 76 | } 77 | lbot = np; 78 | np++->val = P(stdin); 79 | np++->val = eofa; 80 | while (TRUE) 81 | { 82 | fputs("\n-> ",stdout); 83 | dmpport(stdout); 84 | vtemp = Lread(); 85 | if(vtemp == eofa) exit(0); 86 | printr(eval(vtemp),stdout); 87 | } 88 | } 89 | 90 | /* franzexit :: give up the ghost 91 | * this function is called whenever one decides to kill this process. 92 | * We clean up a bit then call then standard exit routine. C code 93 | * in franz should never call exit() directly. 94 | */ 95 | franzexit(code) 96 | { 97 | extern int fvirgin; 98 | extern char *stabf; 99 | if(!fvirgin) unlink(stabf); /* give up any /tmp symbol tables */ 100 | exit(code); 101 | /* is this something special?? _cleanup(); 102 | * proflush(); 103 | * _exit(code); 104 | */ 105 | 106 | } 107 | -------------------------------------------------------------------------------- /liszt/array.l: -------------------------------------------------------------------------------- 1 | (include-if (null (get 'chead 'version)) "../chead.l") 2 | (Liszt-file array 3 | "$Header: array.l,v 1.7 83/08/28 17:12:39 layer Exp $") 4 | 5 | ;;; ---- a r r a y array referencing 6 | ;;; 7 | ;;; -[Sat Aug 6 23:59:45 1983 by layer]- 8 | 9 | 10 | ;--- d-handlearrayref :: general array handler 11 | ; this function is called from d-exp when the car is an array (declare macarray) 12 | ; In the current array scheme, stores look like array references with one 13 | ; extra argument. Thus we must determine if we are accessing or storing in 14 | ; the array. 15 | ; Note that we must turn g-loc to reg and g-cc to nil since, even though 16 | ; d-supercxr handles g-loc and g-cc, d-superrplacx does not and we cannot 17 | ; know ahead of time which one we will use. If this seems important, 18 | ; we can beef up d-superrplacx 19 | ; 20 | (defun d-handlearrayref nil 21 | (let ((spec (get (car v-form) g-arrayspecs)) 22 | expr 23 | (g-loc 'reg) g-cc) 24 | 25 | (makecomment '(array ref)) 26 | (if (eq (1+ (length (cdr spec))) (length (cdr v-form))) 27 | then (d-dostore spec (cadr v-form) (cddr v-form)) 28 | else (setq expr (d-arrayindexcomp (cdr v-form) (cdr spec))) 29 | 30 | (let ((v-form `(cxr ,expr (getdata (getd ',(car v-form)))))) 31 | (d-supercxr (car spec) nil))))) 32 | 33 | 34 | ;--- d-dostore :: store value in array. 35 | ; spec - array descriptor from declare, e.g. (foo t 12 3 4) 36 | ; value - expression to calculate value to be stored. 37 | ; indexes - list of expressions which are the actual indicies. 38 | ; 39 | (defun d-dostore (spec value indexes) 40 | (let (expr gen) 41 | (makecomment '(doing store)) 42 | ; create an expression for doing index calculation. 43 | (setq expr (d-arrayindexcomp indexes (cdr spec)) 44 | gen (gensym)) 45 | 46 | ; calculate value to store and stack it. 47 | (d-pushargs (ncons value)) 48 | (rplaca g-locs gen) ; name just stacked varib 49 | 50 | ; do the store operation. 51 | (let ((v-form `(rplacx ,expr (getdata (getd ',(car v-form))) 52 | ,gen))) 53 | (d-superrplacx (car spec))) 54 | 55 | ; move the value we stored into r0 56 | (d-move 'unstack 'reg) 57 | (setq g-locs (cdr g-locs)) 58 | (decr g-loccnt))) 59 | 60 | 61 | 62 | 63 | (defun d-arrayindexcomp (actual formal) 64 | (if (null (cdr actual)) 65 | then (car actual) ; always allow one arg 66 | elseif (eq (length actual) (length formal)) 67 | then (do ((ac actual (cdr ac)) 68 | (fo formal (cdr fo)) 69 | (res)) 70 | ((null ac) (cons '+ res)) 71 | (setq res (cons (if (null (cdr fo)) then (car ac) 72 | else `(* ,(car ac) ,(apply 'times (cdr fo)))) 73 | res))) 74 | else (comp-err "Wrong number of subscripts to array " actual))) 75 | -------------------------------------------------------------------------------- /franz/h/aout.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Header prepended to each a.out file. 3 | */ 4 | struct exec { 5 | long a_magic; /* magic number */ 6 | unsigned long a_text; /* size of text segment */ 7 | unsigned long a_data; /* size of initialized data */ 8 | unsigned long a_bss; /* size of uninitialized data */ 9 | unsigned long a_syms; /* size of symbol table */ 10 | unsigned long a_entry; /* entry point */ 11 | unsigned long a_trsize; /* size of text relocation */ 12 | unsigned long a_drsize; /* size of data relocation */ 13 | }; 14 | 15 | #define OMAGIC 0407 /* old impure format */ 16 | #define NMAGIC 0410 /* read-only text */ 17 | #define ZMAGIC 0413 /* demand load format */ 18 | 19 | /* 20 | * Macros which take exec structures as arguments and tell whether 21 | * the file has a reasonable magic number or offsets to text|symbols|strings. 22 | */ 23 | #define N_BADMAG(x) \ 24 | (((x).a_magic)!=OMAGIC && ((x).a_magic)!=NMAGIC && ((x).a_magic)!=ZMAGIC) 25 | 26 | #define N_TXTOFF(x) \ 27 | ((x).a_magic==ZMAGIC ? 1024 : sizeof (struct exec)) 28 | #define N_SYMOFF(x) \ 29 | (N_TXTOFF(x) + (x).a_text+(x).a_data + (x).a_trsize+(x).a_drsize) 30 | #define N_STROFF(x) \ 31 | (N_SYMOFF(x) + (x).a_syms) 32 | 33 | /* 34 | * Format of a relocation datum. 35 | */ 36 | struct relocation_info { 37 | int r_address; /* address which is relocated */ 38 | unsigned int r_symbolnum:24, /* local symbol ordinal */ 39 | r_pcrel:1, /* was relocated pc relative already */ 40 | r_length:2, /* 0=byte, 1=word, 2=long */ 41 | r_extern:1, /* does not include value of sym referenced */ 42 | :4; /* nothing, yet */ 43 | }; 44 | 45 | /* 46 | * Format of a symbol table entry; this file is included by 47 | * and should be used if you aren't interested the a.out header 48 | * or relocation information. 49 | */ 50 | struct nlist { 51 | union { 52 | char *n_name; /* for use when in-core */ 53 | long n_strx; /* index into file string table */ 54 | } n_un; 55 | unsigned char n_type; /* type flag, i.e. N_TEXT etc; see below */ 56 | char n_other; /* unused */ 57 | short n_desc; /* see */ 58 | unsigned long n_value; /* value of this symbol (or sdb offset) */ 59 | }; 60 | #define n_hash n_desc /* used internally by ld */ 61 | 62 | /* 63 | * Simple values for n_type. 64 | */ 65 | #define N_UNDF 0x0 /* undefined */ 66 | #define N_ABS 0x2 /* absolute */ 67 | #define N_TEXT 0x4 /* text */ 68 | #define N_DATA 0x6 /* data */ 69 | #define N_BSS 0x8 /* bss */ 70 | #define N_COMM 0x12 /* common (internal to ld) */ 71 | #define N_FN 0x1f /* file name symbol */ 72 | 73 | #define N_EXT 01 /* external bit, or'ed in */ 74 | #define N_TYPE 0x1e /* mask for all the type bits */ 75 | 76 | /* 77 | * Sdb entries have some of the N_STAB bits set. 78 | * These are given in 79 | */ 80 | #define N_STAB 0xe0 /* if any of these bits set, a SDB entry */ 81 | 82 | /* 83 | * Format for namelist values. 84 | */ 85 | #define N_FORMAT "%08x" 86 | -------------------------------------------------------------------------------- /franz/h/lispo.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Header prepended to each a.out file. 3 | */ 4 | struct exec { 5 | long a_magic; /* magic number */ 6 | unsigned long a_text; /* size of text segment */ 7 | unsigned long a_data; /* size of initialized data */ 8 | unsigned long a_bss; /* size of uninitialized data */ 9 | unsigned long a_syms; /* size of symbol table */ 10 | unsigned long a_entry; /* entry point */ 11 | unsigned long a_trsize; /* size of text relocation */ 12 | unsigned long a_drsize; /* size of data relocation */ 13 | }; 14 | 15 | #define OMAGIC 0407 /* old impure format */ 16 | #define NMAGIC 0410 /* read-only text */ 17 | #define ZMAGIC 0413 /* demand load format */ 18 | 19 | /* 20 | * Macros which take exec structures as arguments and tell whether 21 | * the file has a reasonable magic number or offsets to text|symbols|strings. 22 | */ 23 | #define N_BADMAG(x) \ 24 | (((x).a_magic)!=OMAGIC && ((x).a_magic)!=NMAGIC && ((x).a_magic)!=ZMAGIC) 25 | 26 | #define N_TXTOFF(x) \ 27 | ((x).a_magic==ZMAGIC ? 1024 : sizeof (struct exec)) 28 | #define N_SYMOFF(x) \ 29 | (N_TXTOFF(x) + (x).a_text+(x).a_data + (x).a_trsize+(x).a_drsize) 30 | #define N_STROFF(x) \ 31 | (N_SYMOFF(x) + (x).a_syms) 32 | 33 | /* 34 | * Format of a relocation datum. 35 | */ 36 | struct relocation_info { 37 | int r_address; /* address which is relocated */ 38 | unsigned int r_symbolnum:24, /* local symbol ordinal */ 39 | r_pcrel:1, /* was relocated pc relative already */ 40 | r_length:2, /* 0=byte, 1=word, 2=long */ 41 | r_extern:1, /* does not include value of sym referenced */ 42 | :4; /* nothing, yet */ 43 | }; 44 | 45 | /* 46 | * Format of a symbol table entry; this file is included by 47 | * and should be used if you aren't interested the a.out header 48 | * or relocation information. 49 | */ 50 | struct nlist { 51 | union { 52 | char *n_name; /* for use when in-core */ 53 | long n_strx; /* index into file string table */ 54 | } n_un; 55 | unsigned char n_type; /* type flag, i.e. N_TEXT etc; see below */ 56 | char n_other; /* unused */ 57 | short n_desc; /* see */ 58 | unsigned long n_value; /* value of this symbol (or sdb offset) */ 59 | }; 60 | #define n_hash n_desc /* used internally by ld */ 61 | 62 | /* 63 | * Simple values for n_type. 64 | */ 65 | #define N_UNDF 0x0 /* undefined */ 66 | #define N_ABS 0x2 /* absolute */ 67 | #define N_TEXT 0x4 /* text */ 68 | #define N_DATA 0x6 /* data */ 69 | #define N_BSS 0x8 /* bss */ 70 | #define N_COMM 0x12 /* common (internal to ld) */ 71 | #define N_FN 0x1f /* file name symbol */ 72 | 73 | #define N_EXT 01 /* external bit, or'ed in */ 74 | #define N_TYPE 0x1e /* mask for all the type bits */ 75 | 76 | /* 77 | * Sdb entries have some of the N_STAB bits set. 78 | * These are given in 79 | */ 80 | #define N_STAB 0xe0 /* if any of these bits set, a SDB entry */ 81 | 82 | /* 83 | * Format for namelist values. 84 | */ 85 | #define N_FORMAT "%08x" 86 | -------------------------------------------------------------------------------- /franz/fpipe.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: fpipe.c,v 1.3 85/05/22 07:53:41 sklower Exp $"; 4 | #endif 5 | 6 | 7 | /* -[Sat Jan 29 12:44:16 1983 by jkf]- 8 | * fpipe.c $Locker: $ 9 | * pipe creation 10 | * 11 | * (c) copyright 1982, Regents of the University of California 12 | */ 13 | 14 | 15 | #include "global.h" 16 | #include 17 | 18 | FILE *fpipe(info) 19 | FILE *info[2]; 20 | { 21 | register FILE *p; 22 | int fd[2]; 23 | 24 | if(0 > pipe(fd)) return( (FILE *) -1); 25 | 26 | if(NULL==(p = fdopen(fd[0],"r"))) { 27 | close(fd[0]); 28 | close(fd[1]); 29 | return( (FILE *) -1); 30 | } 31 | info[0] = p; 32 | if(NULL==(p = fdopen(fd[1],"w"))) { 33 | close(fd[0]); 34 | close(fd[1]); 35 | return( (FILE *) -1); 36 | } 37 | info[1] = p; 38 | 39 | return((FILE *) 2); /*indicate sucess*/ 40 | } 41 | /* Nioreset *************************************************************/ 42 | 43 | lispval 44 | Nioreset() { 45 | #ifndef RTPORTS 46 | register FILE *p; 47 | 48 | for(p = &_iob[3]; p < _iob + _NFILE; p++) { 49 | if(p->_flag & (_IOWRT | _IOREAD)) fclose(p); 50 | } 51 | #else RTPORTS 52 | lispval NiorUtil(); 53 | 54 | _fwalk(NiorUtil); 55 | #endif RTPORTS 56 | return(nil); 57 | } 58 | 59 | #ifdef RTPORTS 60 | FILE FILEdummy; 61 | 62 | static lispval 63 | NiorUtil(p) 64 | FILE *p; 65 | { 66 | lispval handy; 67 | if(p==stdin||p==stdout||p==stderr) 68 | return(0); 69 | fclose(p); 70 | handy = P(p); 71 | if(TYPE(handy)==PORT) { 72 | handy->p = &FILEdummy; 73 | } 74 | return(nil); 75 | } 76 | FILE **xports; 77 | 78 | #define LOTS (LBPG/(sizeof (FILE *))) 79 | lispval P(p) 80 | FILE *p; 81 | { 82 | register FILE **q; 83 | extern int fakettsize; 84 | 85 | if(xports==((FILE **) 0)) { 86 | /* this is gross. I don't want to change csegment -- kls */ 87 | xports = (FILE **) csegment(OTHER,LOTS,0); 88 | SETTYPE(xports,PORT,31); 89 | for(q = xports; q < xports + LOTS; q++) { 90 | *q = &FILEdummy; 91 | } 92 | } 93 | for(q = xports; q < xports + LOTS; q++) { 94 | if(*q==p) return ((lispval)q); 95 | if(*q==&FILEdummy) { 96 | *q = p; 97 | return ((lispval)q); 98 | } 99 | } 100 | /* Heavens above knows this could be disasterous in makevals() */ 101 | error("Ran out of Ports",FALSE); 102 | } 103 | 104 | #endif RTPORTS 105 | 106 | FILE * 107 | fstopen(base,count,flag) 108 | char *base; 109 | char *flag; 110 | { 111 | register FILE *p = fdopen(0,flag); 112 | 113 | p->_flag |= _IOSTRG; 114 | p->_cnt = count; 115 | p->_ptr = p->_base = base; 116 | p->_file = -1; 117 | return(p); 118 | } 119 | 120 | #ifdef SPISFP 121 | char * 122 | alloca(howmuch) 123 | register int howmuch; 124 | { 125 | howmuch += 3 ; 126 | howmuch >>= 2; 127 | xsp -= howmuch; 128 | if (xsp < xstack) { 129 | xsp += howmuch; 130 | xserr(); 131 | } 132 | return((char *) xsp); 133 | } 134 | #endif 135 | -------------------------------------------------------------------------------- /franz/h/duallispo.h: -------------------------------------------------------------------------------- 1 | /* a.out.h 1.1 82/08/26 */ 2 | /* 3 | * Header prepended to each a.out file. 4 | */ 5 | struct exec { 6 | long a_magic; /* magic number */ 7 | unsigned long a_text; /* size of text segment */ 8 | unsigned long a_data; /* size of initialized data */ 9 | unsigned long a_bss; /* size of uninitialized data */ 10 | unsigned long a_syms; /* size of symbol table */ 11 | unsigned long a_entry; /* entry point (WRONG) */ 12 | unsigned long a_trsize; /* size of text relocation */ 13 | unsigned long a_drsize; /* size of data relocation */ 14 | }; 15 | 16 | #define OMAGIC 0407 /* old impure format */ 17 | #define NMAGIC 0410 /* read-only text */ 18 | #define ZMAGIC 0413 /* demand load format */ 19 | 20 | /* 21 | * Macros which take exec structures as arguments and tell whether 22 | * the file has a reasonable magic number or offsets to text|symbols|strings. 23 | */ 24 | #define N_BADMAG(x) \ 25 | (((x).a_magic)!=OMAGIC && ((x).a_magic)!=NMAGIC && ((x).a_magic)!=ZMAGIC) 26 | 27 | #define N_TXTOFF(x) \ 28 | ((x).a_magic==ZMAGIC ? 1024 : sizeof (struct exec)) 29 | #define N_SYMOFF(x) \ 30 | (N_TXTOFF(x) + (x).a_text+(x).a_data + (x).a_trsize+(x).a_drsize) 31 | #define N_STROFF(x) \ 32 | (N_SYMOFF(x) + (x).a_syms) 33 | 34 | /* 35 | * Format of a relocation datum. 36 | */ 37 | struct relocation_info { 38 | int r_address; /* address which is relocated */ 39 | unsigned int r_symbolnum:24, /* local symbol ordinal */ 40 | r_pcrel:1, /* was relocated pc relative already */ 41 | r_length:2, /* 0=byte, 1=word, 2=long */ 42 | r_extern:1, /* does not include value of sym referenced */ 43 | :4; /* nothing, yet */ 44 | }; 45 | 46 | /* 47 | * Format of a symbol table entry; this file is included by 48 | * and should be used if you aren't interested the a.out header 49 | * or relocation information. 50 | */ 51 | struct nlist { 52 | union { 53 | char *n_name; /* for use when in-core */ 54 | long n_strx; /* index into file string table */ 55 | } n_un; 56 | unsigned char n_type; /* type flag, i.e. N_TEXT etc; see below */ 57 | char n_other; /* unused */ 58 | short n_desc; /* see */ 59 | unsigned long n_value; /* value of this symbol (or sdb offset) */ 60 | }; 61 | #define n_hash n_desc /* used internally by ld */ 62 | 63 | /* 64 | * Simple values for n_type. 65 | */ 66 | #define N_UNDF 0x0 /* undefined */ 67 | #define N_ABS 0x2 /* absolute */ 68 | #define N_TEXT 0x4 /* text */ 69 | #define N_DATA 0x6 /* data */ 70 | #define N_BSS 0x8 /* bss */ 71 | #define N_COMM 0x12 /* common (internal to ld) */ 72 | #define N_FN 0x1f /* file name symbol */ 73 | 74 | #define N_EXT 01 /* external bit, or'ed in */ 75 | #define N_TYPE 0x1e /* mask for all the type bits */ 76 | 77 | /* 78 | * Sdb entries have some of the N_STAB bits set. 79 | * These are given in 80 | */ 81 | #define N_STAB 0xe0 /* if any of these bits set, a SDB entry */ 82 | 83 | /* 84 | * Format for namelist values. 85 | */ 86 | #define N_FORMAT "%08x" 87 | -------------------------------------------------------------------------------- /utils/tackon.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "lconf.h" 3 | #include "config.h" 4 | #if ! os_unisoft 5 | #include 6 | #include 7 | /* 8 | * $Header: /na/franz/utils/RCS/tackon.c,v 1.4 83/08/22 19:01:17 sklower Exp $ 9 | * 10 | * $Locker: $ 11 | * 12 | * This program tacks on extra symbols into the symbol table. 13 | * someone should write one for system 5. 14 | * 15 | */ 16 | 17 | FILE *map; 18 | int aout; 19 | #define NEWSIZ 100000 20 | char newstrb[NEWSIZ]; 21 | 22 | #endif 23 | main(argc, argv) 24 | int argc; 25 | char *argv[]; 26 | { 27 | #if ! os_unisoft 28 | char sym[50], svalue[50]; 29 | char *strb,*newstr,*malloc(); 30 | char *curstr; 31 | int value; 32 | int cnt; 33 | int strsiz; 34 | int strcnt; 35 | int size; 36 | int header_location; 37 | struct nlist a; 38 | struct exec e; 39 | 40 | argc--, argv++; 41 | if (argc == 0 || argc > 2) { 42 | usage: 43 | fprintf(stderr, "usage: tackon map [ a.out ]\n"); 44 | exit(1); 45 | } 46 | map = fopen(argv[0], "r"); 47 | if (map == NULL) { 48 | perror(argv[0]); 49 | exit(1); 50 | } 51 | aout = open(argc == 2 ? argv[1] : "a.out", 2); 52 | if ((aout < 0) && (argc == 2)) { 53 | char Name[256]; 54 | 55 | strcpy(Name,argv[1]); 56 | strcat(Name,".exe"); 57 | aout = open(Name,2); 58 | } 59 | if (aout < 0) { 60 | printf(" No object file to tackon or text busy\n"); 61 | exit(1); 62 | } 63 | header_location = 0; 64 | read(aout,&e, sizeof(e)); 65 | if (N_BADMAG(e)) { 66 | header_location = 512; 67 | lseek(aout,512,0); 68 | read(aout,&e,sizeof(e)); 69 | if (N_BADMAG(e)) { 70 | printf("tackon: bad magic number\n"); 71 | exit(0); 72 | } 73 | } 74 | /* read current string table into buffer */ 75 | lseek(aout, N_STROFF(e), 0); /* seek to string table beginning */ 76 | read(aout,&strsiz,4); /* read in string table size */ 77 | strb = malloc(strsiz); 78 | read(aout,strb,strsiz); /* read in string table */ 79 | lseek(aout, N_STROFF(e), 0); /* now write at end of symbols */ 80 | cnt = 0; 81 | strcnt = 4 + strsiz; 82 | curstr = newstrb; /* point to new string buffer */ 83 | for (;;) { 84 | if (fgets(sym, 50, map) == NULL) 85 | break; 86 | sym[size=strlen(sym)-1] = 0; 87 | if (fgets(svalue, 50, map) == NULL) { 88 | fprintf(stderr, "missing value\n"); 89 | break; 90 | } 91 | strcpy(curstr,sym); 92 | sscanf(svalue, "%x", &a.n_value); 93 | a.n_un.n_strx = strcnt; 94 | a.n_type = N_EXT|N_TEXT; 95 | write(aout, &a, sizeof (a)); 96 | curstr += size+1; 97 | strcnt += size+1; 98 | cnt++; 99 | if( curstr >= &newstrb[NEWSIZ]) 100 | { 101 | printf(" Tackon; string buffer overflow \n"); 102 | exit(1); 103 | } 104 | } 105 | write(aout, &strcnt, 4); /* new character count */ 106 | write(aout, strb, strsiz); /* write out old string table */ 107 | write(aout, newstrb, strcnt - ( 4 + strsiz)); 108 | lseek(aout, header_location, 0); 109 | e.a_syms += cnt*sizeof(struct nlist); 110 | lseek(aout, header_location, 0); 111 | write(aout, &e, sizeof (e)); 112 | exit(0); 113 | #endif 114 | } 115 | -------------------------------------------------------------------------------- /franz/fexr.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: /na/franz/franz/RCS/fexr.c,v 1.1 83/01/29 12:48:43 jkf Exp $"; 4 | #endif 5 | 6 | /* -[Sat Jan 29 12:41:19 1983 by jkf]- 7 | * fexr.c $Locker: $ 8 | * nlambda functions 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | 14 | #include "global.h" 15 | 16 | /* Ngcafter *************************************************************/ 17 | /* */ 18 | /* Default garbage collector routine which does nothing. */ 19 | 20 | lispval 21 | Ngcafter() 22 | { 23 | return(nil); 24 | } 25 | 26 | /* Nopval *************************************************************/ 27 | /* */ 28 | /* Routine which allows system registers and options to be examined */ 29 | /* and modified. Calls copval, the routine which is called by c code */ 30 | /* to do the same thing from inside the system. */ 31 | 32 | lispval 33 | Nopval() 34 | { 35 | lispval quant; 36 | 37 | if( TYPE(lbot->val) != DTPR ) 38 | return(error("BAD CALL TO OPVAL",TRUE)); 39 | quant = eval(lbot->val->d.car); /* evaluate name of sys variable */ 40 | while( TYPE(quant) != ATOM ) 41 | quant = error("FIRST ARG TO OPVAL MUST BE AN ATOM",TRUE); 42 | 43 | if( (vtemp=lbot->val->d.cdr) != nil && TYPE(lbot->val->d.cdr) != DTPR ) 44 | return(error("BAD ARG LIST FOR OPVAL",TRUE)); 45 | return(copval( 46 | quant, 47 | vtemp==nil ? (lispval)CNIL : eval(vtemp->d.car) 48 | )); 49 | } 50 | /* copval *************************************************************/ 51 | /* This routine keeps track of system quantities, and is called from */ 52 | /* C code. If the second argument is CNIL, no change is made in the */ 53 | /* quantity. */ 54 | /* Since this routine may call newdot() if the second argument is not */ 55 | /* CNIL, the arguments should be protected somehow in that case. */ 56 | 57 | lispval 58 | copval(option,value) 59 | lispval option, value; 60 | { 61 | struct dtpr fake; 62 | lispval rval; 63 | 64 | if( option->a.plist == nil && value != (lispval) CNIL) 65 | { 66 | protect(option); protect(value); 67 | option->a.plist = newdot(); 68 | option->a.plist->d.car = sysa; 69 | option->a.plist->d.cdr = newdot(); 70 | option->a.plist->d.cdr->d.car = value; 71 | unprot(); unprot(); 72 | return(nil); 73 | } 74 | 75 | 76 | if( option->a.plist == nil ) return(nil); 77 | 78 | fake.cdr = option->a.plist; 79 | option = (lispval) (&fake); 80 | 81 | while( option->d.cdr != nil ) /* can't be nil first time through */ 82 | { 83 | option = option->d.cdr; 84 | if( option->d.car == sysa ) 85 | { 86 | rval = option->d.cdr->d.car; 87 | if( value != (lispval)CNIL ) 88 | option->d.cdr->d.car = value; 89 | return(rval); 90 | } 91 | option = option->d.cdr; 92 | } 93 | 94 | if( value != (lispval)CNIL ) 95 | { 96 | protect(option); protect(value); 97 | option->d.cdr = newdot(); 98 | option->d.cdr->d.car = sysa; 99 | option->d.cdr->d.cdr = newdot(); 100 | option->d.cdr->d.cdr->d.car = value; 101 | unprot(); unprot(); 102 | } 103 | 104 | 105 | return(nil); 106 | } 107 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Franz Lisp: A Classic Lisp Implementation from UC Berkeley 2 | 3 | ## What Is Franz Lisp? 4 | 5 | Franz Lisp was a Lisp implementation developed at the University of California, 6 | Berkeley by students of Richard Fateman. They developed Franz Lisp for porting 7 | Macsyma algebra system, an enormous Lisp application written in Maclisp, to DEC 8 | VAX-11 minicomputer. UC Berkeley distributed it with the Berkeley Software 9 | Distribution. Franz Inc. was founded to provide commercial support of Franz 10 | Lisp, but the company switched to Common Lisp afterward. 11 | 12 | ## License 13 | 14 | The original code is retrieved from [Franz Lisp Opus 38.93b][op38.93b] at the 15 | [CMU AI Repository][ai]. According to the page, that is placed in the public 16 | domain. However, since the origin of the code is the Berkeley Software 17 | Distribution, it would be safer to treat it as distributed under the term of 18 | the 4-clause BSD License. Thus, I decided to do so. [Kamil Rytarowski pointed 19 | it out](https://github.com/omasanori/franz-lisp/issues/1#issuecomment-302843065), 20 | thanks a lot! 21 | 22 | Note that UCB has declared that the clause 3 is no longer effective for their 23 | code in BSD, so Franz Lisp in this repository is practically under the term of 24 | the 3-clause BSD License that is OSI-approved and GPL-compatible. 25 | 26 | See ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change for details. 27 | 28 | Also, this repository contains no code from AT&T. 29 | 30 | ## A Short Guide 31 | 32 | The `doc/` directory contains the Franz Lisp manual written in roff. The 33 | [manual in the PDF format][manual] can be obtained at the [Software 34 | Preservation Group][spg]'s Web site. 35 | 36 | The `franz/` directory contains the source code of the interpreter called 37 | `lisp`. It is mostly written in C but plain old (pre-ANSI) one. There is also 38 | some assembly code for VAX, Motorola 68000 and so on. 39 | 40 | The `lisplib/` directory contains Lisp code that may or may not run on Franz 41 | Lisp, from *official* essential libraries to some advanced libraries such as a 42 | port of Flavors (an object-oriented Lisp system) and the loop macro. You must 43 | have fun here! :) 44 | 45 | The `liszt/` directory contains the source code of the compiler called `liszt`. 46 | It is written in Franz Lisp itself. The names of franz and liszt are taken from 47 | the Hungarian composer Franz Liszt. 48 | 49 | The `pearl/` directory contains an implementation of PEARL (Package for 50 | Efficient Access to Representations in Lisp) AI programming language that was 51 | developed by Michael Deering and Joseph Faletti at the Berkeley AI Research 52 | Project (BAIR). Some information is available at the [Michael Deering's Web 53 | page about PEARL][pearl]. 54 | 55 | The `utils/` directory contains some utilities used by the original developers. 56 | 57 | [ai]: http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/0.html 58 | [manual]: http://www.softwarepreservation.org/projects/LISP/franz/Franz_Lisp_July_1983.pdf 59 | [op38.93b]: http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/others/franzlsp/op38_93b/0.html 60 | [pearl]: http://michaelfrankdeering.com/Projects/AI/PEARL/PEARL.html 61 | [spg]: http://www.softwarepreservation.org/ 62 | -------------------------------------------------------------------------------- /pearl/symord.l: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; symord.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; Functions for defining symbols and ordinal types. 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ; Copyright (c) 1983 , The Regents of the University of California. 5 | ; All rights reserved. 6 | ; Authors: Joseph Faletti and Michael Deering. 7 | 8 | ; Define one SYMBOL in a hunk for easy identification. 9 | ; This will not work independently (for some reason). 10 | (dm onesymbol (none) 11 | '(funl (symname) 12 | (or (and (not (litatom symname)) 13 | (not (msg t "SYMBOL: Symbols can only be simple names, not:" 14 | symname t))) 15 | (and (eq symname 'nilsym) 16 | (boundp (symatom 'nilsym)) 17 | (not (msg t "SYMBOL: Cannot redefine nilsym." t))) 18 | (and (null symname) 19 | (not (msg t "SYMBOL: Cannot name a symbol nil." t))) 20 | (and (symbolnamep symname) 21 | ; but okay to do. 22 | (and *warn* 23 | (msg t "SYMBOL: Warning: Redefining symbol: " 24 | symname t))) 25 | (let ((block (set (symatom symname) (makhunk 3)))) 26 | (putuniquenum (newnum) block) 27 | (puttypetag '*pearlsymbol* block) 28 | (putsymbolpname symname block) 29 | block)))) 30 | 31 | ; Define a bunch of SYMBOLS. 32 | (df symbol (l) 33 | (mapcar (onesymbol) l)) 34 | 35 | ; An EXPR which allows the defining of one SYMBOL. 36 | (de symbole (symname) 37 | (cond ((not (litatom symname)) 38 | (msg t "SYMBOLE: symbols can only be simple names, not: " 39 | symname t) 40 | (pearlbreak)) 41 | ( t (apply* (onesymbol) (ncons symname)) symname))) 42 | 43 | (de getsymbol (symname) 44 | (cond ((symbolnamep symname) 45 | (eval (symatom symname))) 46 | ( t (msg t "GETSYMBOL: " symname " is not the name of a symbol." t) 47 | (pearlbreak)))) 48 | 49 | ; (ordinal name (x y z)) or (ordinal name (x 1 y 3 z 8)). 50 | ; Define a set of integer constants for readability in input and output. 51 | ; Also define o:name, name:max and name:min, and name:x, name:y and name:z. 52 | (df ordinal (l) 53 | (let ((ordinalname (car l)) 54 | (ordinalelements (cadr l)) 55 | (alist (ncons nil)) 56 | (count 0) 57 | (min 0) 58 | max 59 | name 60 | value) 61 | (push ordinalname *ordinalnames*) 62 | (set (ordatom ordinalname) 63 | (cond ((not (numberp (cadr ordinalelements))) 64 | ; generate numbers. 65 | (while ordinalelements 66 | (setq count (1+ count)) 67 | (tconc alist (cons (setq name (pop ordinalelements)) 68 | count)) 69 | (set (concat ordinalname ":" name) count)) 70 | (or (\=& 0 count) 71 | (setq min 1)) 72 | (setq max count) 73 | (car alist)) 74 | ; use numbers provided by user. 75 | ( t (setq min (setq max (cadr ordinalelements))) 76 | (while ordinalelements 77 | (tconc alist 78 | (cons (setq name (pop ordinalelements)) 79 | (setq value (pop ordinalelements)))) 80 | (set (concat ordinalname ":" name) value) 81 | (and (<& value min) 82 | (setq min value)) 83 | (and (>& value max) 84 | (setq max value))) 85 | (car alist)))) 86 | (set (concat ordinalname ":min") min) 87 | (set (concat ordinalname ":max") max) 88 | (cons ordinalname (car alist)))) 89 | 90 | 91 | ; vi: set lisp: 92 | -------------------------------------------------------------------------------- /liszt/vax/Makefile: -------------------------------------------------------------------------------- 1 | #$Header: /na/franz/liszt/vax/RCS/Makefile,v 1.6 83/08/15 19:27:49 layer Exp $ 2 | # 3 | # Makefile for liszt 4 | # 5 | # Copyright (c) 1980, 1982, The Regents of the University of California. 6 | # the Copyright applies to all files referenced in this Makefile. 7 | # All rights reserved. 8 | # author: j. foderaro 9 | # 10 | # this makefile creates these things: 11 | # nliszt - the lisp compiler. We call it nliszt so we can test it out 12 | # without having to say ./liszt 13 | # tags - a tags file for use by ex/vi 14 | # 15 | # CTE refers to compile time enviroment 16 | # 17 | #--- Default Paths and programs 18 | # 19 | .DEFAULT:nliszt 20 | 21 | CopyTo = /dev/null 22 | ObjDir = /usr/ucb 23 | Liszt = ${ObjDir}/liszt 24 | Lisp = ${ObjDir}/lisp 25 | 26 | Flg = -xqa 27 | 28 | CTESrc = ../chead.l ../cmacros.l ../const.l 29 | 30 | CTEObj= cmacros.o 31 | 32 | Src = ../array.l ../datab.l ../decl.l ../expr.l ../fixnum.l ../funa.l \ 33 | ../funb.l ../func.l ../io.l ../tlev.l ../util.l ../lversion.l \ 34 | ../vector.l ../instr.l 35 | 36 | SharedSrc = ${CTESrc} ${Src} ../ChangeLog ../cmake.l 37 | 38 | AllSrc = Makefile lisprc.l lisztrc.l 39 | 40 | Obj = array.o datab.o decl.o expr.o fixnum.o funa.o funb.o func.o io.o \ 41 | tlev.o util.o lversion.o vector.o instr.o 42 | 43 | AllObj = ${CTEObj} ${Obj} 44 | 45 | donliszt: 46 | rm -f nliszt 47 | make Liszt=${Liszt} Lisp=${Lisp} nliszt 48 | 49 | nliszt: ${CTEObj} ${Obj} ${Lisp} 50 | echo "(load '../cmake.l)(genl nliszt)" | ${Lisp} 51 | 52 | #--- generate an interpreted version 53 | snliszt: ${Src} ${Lisp} 54 | echo "(load '../cmake.l)(genl snliszt slow)" | ${Lisp} 55 | 56 | array.o: ../array.l 57 | ${Liszt} ${Flg} ../array.l -o array.o 58 | 59 | vector.o: ../vector.l 60 | ${Liszt} ${Flg} ../vector.l -o vector.o 61 | 62 | instr.o: ../instr.l 63 | ${Liszt} ${Flg} ../instr.l -o instr.o 64 | 65 | datab.o: ../datab.l 66 | ${Liszt} ${Flg} ../datab.l -o datab.o 67 | 68 | decl.o: ../decl.l 69 | ${Liszt} ${Flg} ../decl.l -o decl.o 70 | 71 | expr.o: ../expr.l 72 | ${Liszt} ${Flg} ../expr.l -o expr.o 73 | 74 | fixnum.o: ../fixnum.l 75 | ${Liszt} ${Flg} ../fixnum.l -o fixnum.o 76 | 77 | funa.o: ../funa.l 78 | ${Liszt} ${Flg} ../funa.l -o funa.o 79 | 80 | funb.o: ../funb.l 81 | ${Liszt} ${Flg} ../funb.l -o funb.o 82 | 83 | func.o: ../func.l 84 | ${Liszt} ${Flg} ../func.l -o func.o 85 | 86 | io.o: ../io.l 87 | ${Liszt} ${Flg} ../io.l -o io.o 88 | 89 | tlev.o: ../tlev.l 90 | ${Liszt} ${Flg} ../tlev.l -o tlev.o 91 | 92 | util.o: ../util.l 93 | ${Liszt} ${Flg} ../util.l -o util.o 94 | 95 | lversion.o: ../lversion.l 96 | ${Liszt} ${Flg} ../lversion.l -o lversion.o 97 | 98 | cmacros.o: ../cmacros.l 99 | ${Liszt} ${Flg} ../cmacros.l -o cmacros.o 100 | 101 | tags: ../tags ${Src} ${CTESrc} 102 | awk -f ../ltags ${Src} ${CTESrc} | sort > ../tags 103 | 104 | # 105 | install: nliszt 106 | -rm -f ${ObjDir}/liszt 107 | mv nliszt ${ObjDir}/liszt 108 | 109 | copysource: ${AllSrc} 110 | (tar cf - ${AllSrc} | (cd ${CopyTo} ; tar xf -)) 111 | 112 | copyobjects: ${AllObj} 113 | (tar cf - ${AllObj} | (cd ${CopyTo} ; tar xf -)) 114 | 115 | scriptcatall: ${AllSrc} 116 | @../../scriptcat . liszt/vax ${AllSrc} 117 | 118 | cleanobj: 119 | rm -f \#* *.[xo] map 120 | 121 | clean: 122 | make cleanobj 123 | rm -f nliszt snliszt 124 | -------------------------------------------------------------------------------- /liszt/tahoe/Makefile: -------------------------------------------------------------------------------- 1 | #$Header: /na/franz/liszt/vax/RCS/Makefile,v 1.6 83/08/15 19:27:49 layer Exp $ 2 | # 3 | # Makefile for liszt 4 | # 5 | # Copyright (c) 1980, 1982, The Regents of the University of California. 6 | # the Copyright applies to all files referenced in this Makefile. 7 | # All rights reserved. 8 | # author: j. foderaro 9 | # 10 | # this makefile creates these things: 11 | # nliszt - the lisp compiler. We call it nliszt so we can test it out 12 | # without having to say ./liszt 13 | # tags - a tags file for use by ex/vi 14 | # 15 | # CTE refers to compile time enviroment 16 | # 17 | #--- Default Paths and programs 18 | # 19 | .DEFAULT:nliszt 20 | 21 | CopyTo = /dev/null 22 | ObjDir = /usr/ucb 23 | Liszt = liszt 24 | Lisp = ../../franz/tahoe/nlisp 25 | 26 | Flg = -qa 27 | 28 | CTESrc = ../chead.l ../cmacros.l ../const.l 29 | 30 | CTEObj= cmacros.o 31 | 32 | Src = ../array.l ../datab.l ../decl.l ../expr.l ../fixnum.l ../funa.l \ 33 | ../funb.l ../func.l ../io.l ../tlev.l ../util.l ../lversion.l \ 34 | ../vector.l ../instr.l 35 | 36 | SharedSrc = ${CTESrc} ${Src} ../ChangeLog ../cmake.l 37 | 38 | AllSrc = Makefile lisprc.l lisztrc.l 39 | 40 | Obj = array.o datab.o decl.o expr.o fixnum.o funa.o funb.o func.o io.o \ 41 | tlev.o util.o lversion.o vector.o instr.o 42 | 43 | AllObj = ${CTEObj} ${Obj} 44 | 45 | donliszt: 46 | rm -f nliszt 47 | make Liszt=${Liszt} Lisp=${Lisp} nliszt 48 | 49 | nliszt: ${CTEObj} ${Obj} ${Lisp} 50 | echo "(load '../cmake.l)(genl nliszt)" | ${Lisp} 51 | 52 | #--- generate an interpreted version 53 | snliszt: ${Src} ${Lisp} 54 | echo "(load '../cmake.l)(genl snliszt slow)" | ${Lisp} 55 | 56 | array.o: ../array.l 57 | ${Liszt} ${Flg} ../array.l -o array.o 58 | 59 | vector.o: ../vector.l 60 | ${Liszt} ${Flg} ../vector.l -o vector.o 61 | 62 | instr.o: ../instr.l 63 | ${Liszt} ${Flg} ../instr.l -o instr.o 64 | 65 | datab.o: ../datab.l 66 | ${Liszt} ${Flg} ../datab.l -o datab.o 67 | 68 | decl.o: ../decl.l 69 | ${Liszt} ${Flg} ../decl.l -o decl.o 70 | 71 | expr.o: ../expr.l 72 | ${Liszt} ${Flg} ../expr.l -o expr.o 73 | 74 | fixnum.o: ../fixnum.l 75 | ${Liszt} ${Flg} ../fixnum.l -o fixnum.o 76 | 77 | funa.o: ../funa.l 78 | ${Liszt} ${Flg} ../funa.l -o funa.o 79 | 80 | funb.o: ../funb.l 81 | ${Liszt} ${Flg} ../funb.l -o funb.o 82 | 83 | func.o: ../func.l 84 | ${Liszt} ${Flg} ../func.l -o func.o 85 | 86 | io.o: ../io.l 87 | ${Liszt} ${Flg} ../io.l -o io.o 88 | 89 | tlev.o: ../tlev.l 90 | ${Liszt} ${Flg} ../tlev.l -o tlev.o 91 | 92 | util.o: ../util.l 93 | ${Liszt} ${Flg} ../util.l -o util.o 94 | 95 | lversion.o: ../lversion.l 96 | ${Liszt} ${Flg} ../lversion.l -o lversion.o 97 | 98 | cmacros.o: ../cmacros.l 99 | ${Liszt} ${Flg} ../cmacros.l -o cmacros.o 100 | 101 | tags: ../tags ${Src} ${CTESrc} 102 | awk -f ../ltags ${Src} ${CTESrc} | sort > ../tags 103 | 104 | # 105 | install: nliszt 106 | -rm -f ${ObjDir}/liszt 107 | install nliszt ${ObjDir}/liszt 108 | 109 | copysource: ${AllSrc} 110 | (tar cf - ${AllSrc} | (cd ${CopyTo} ; tar xf -)) 111 | 112 | copyobjects: ${AllObj} 113 | (tar cf - ${AllObj} | (cd ${CopyTo} ; tar xf -)) 114 | 115 | scriptcatall: ${AllSrc} 116 | @../../scriptcat . liszt/tahoe ${AllSrc} 117 | 118 | cleanobj: 119 | rm -f \#* *.[xo] map 120 | 121 | clean: 122 | make cleanobj 123 | rm -f nliszt snliszt 124 | -------------------------------------------------------------------------------- /lisplib/buildlisp.l: -------------------------------------------------------------------------------- 1 | (int:setsyntax '\; 'splicing 'zapline) 2 | ;; buildlisp.l -[Mon Aug 15 11:04:31 1983 by jkf]- 3 | ;; build the lisp system from the C kernel 4 | ;; the order of these files is very important. 5 | ;; 6 | (setq rcs-buildlisp- 7 | "$Header: /usr/lib/lisp/RCS/buildlisp.l,v 1.2 83/08/15 22:16:06 jkf Exp $") 8 | 9 | ; variables to modify the way buildlisp works: 10 | ; build:dir -- directory containing the object files to load 11 | ; default: /usr/lib/lisp 12 | ; build:map -- map file to write the fasl map into. 13 | ; default: no map is written 14 | ; build:load -- if t then only loading will be done, no fasl'ing 15 | ; build:lisp-type -- may contain a site dependent name to help build 16 | ; a personalized lisp 17 | ; lisp-library-directory -- directory which will contain lisp library 18 | ; this directory will be part of the default search path 19 | ; lisp-object-directory -- directory which contains the lisp object file 20 | ; 21 | (or (boundp 'build:dir) (setq build:dir '/usr/lib/lisp)) 22 | (or (boundp 'build:map) (setq build:map nil)) 23 | (or (boundp 'build:load) (setq build:load nil)) 24 | (or (boundp 'build:lisp-type) (setq build:lisp-type 'franz)) 25 | (or (boundp 'lisp-library-directory) 26 | (setq lisp-library-directory '/usr/lib/lisp)) 27 | (or (boundp 'lisp-object-directory) 28 | (setq lisp-object-directory '/usr/ucb)) 29 | 30 | 31 | (def build:load 32 | (lambda (x) 33 | (prog (name) 34 | (setq name (concat build:dir "/" x)) 35 | (cond (build:map 36 | (fasl-or-load name t build:map) 37 | ; concatentate to map after first file loaded 38 | (cond ((null (status appendmap)) 39 | (sstatus appendmap t)))) 40 | (t (fasl-or-load name nil nil)))))) 41 | 42 | (def fasl-or-load 43 | (lambda (name provide-map map-name) 44 | (prog (tempname) 45 | (cond ((and (null build:load) 46 | (probef (setq tempname (concat name ".o")))) 47 | (cond (provide-map (fasl tempname map-name)) 48 | (t (fasl name)))) 49 | ((probef (setq tempname (concat name ".l"))) 50 | (load tempname)) 51 | (t (patom "fasl-or-load: Can't find file: ") 52 | (patom name) 53 | (terpr) 54 | (exit 1) ; just go away fast so user will realize problem 55 | ))))) 56 | 57 | 58 | (build:load 'common0) 59 | (build:load 'syntax) 60 | (build:load 'charmac) 61 | (build:load 'macros) 62 | (build:load 'common1) 63 | (build:load 'common2) 64 | (build:load 'common3) 65 | (build:load 'vector) 66 | (build:load 'array) 67 | (build:load 'pp) 68 | 69 | ; only load format if it is compiled. This will save some time when 70 | ; building an interpreted lisp system 71 | (cond ((probef (concat build:dir "/format.o")) 72 | (build:load 'format))) 73 | 74 | (build:load 'version) 75 | 76 | (and (not (eq build:lisp-type 'zlisp)) 77 | (build:load 'tpl)) 78 | 79 | (build:load 'toplevel) 80 | 81 | (cond ((eq build:lisp-type 'franz)) 82 | ((eq build:lisp-type 'zlisp) 83 | (build:load 'zlisp)) 84 | (t (patom "Invalid lisp type: ") 85 | (patom build:lisp-type) 86 | (terpr) 87 | (exit 1))) 88 | 89 | ; kill definitions 90 | (putd 'fasl-or-load nil) 91 | (putd 'build:load nil) 92 | (allocate 'hunk3 2) ; make space for format to use 93 | (new-vector 1024) 94 | (new-vectori-long 512) 95 | (gc) 96 | 97 | 98 | 99 | 100 | 101 | 102 | -------------------------------------------------------------------------------- /utils/divide.c: -------------------------------------------------------------------------------- 1 | /* divide :: divide a file into parts by byte numbers, not by 2 | line (as split does) 3 | */ 4 | #include 5 | 6 | #define DEFCHARS 199000 7 | 8 | char *prefix = "dv"; /* prefix char for created files */ 9 | int linemode = 0; /* always break on line boundaries */ 10 | int chars = DEFCHARS; /* number of chars per output file */ 11 | 12 | int d1 = 0, d2 = 0; 13 | main(argc,argv) 14 | int argc; 15 | char **argv; 16 | { 17 | int n, next, nbytes, outfile, S ; 18 | char filename[30]; 19 | int processed = 0; 20 | char *coreloc; 21 | 22 | argv++; 23 | 24 | while(--argc) 25 | { 26 | if(argv[0][0] == '-') 27 | switch(argv[0][1]) 28 | { 29 | case '\0': 30 | process(0); /* process standard input */ 31 | processed++; 32 | break; 33 | 34 | case '0': 35 | case '1': 36 | case '2': 37 | case '3': 38 | case '4': 39 | case '5': 40 | case '6': 41 | case '7': 42 | case '8': 43 | case '9': 44 | chars = atoi(&argv[0][1]); 45 | if(chars < 1) 46 | { 47 | fprintf(stderr,"bad char count %d\n",chars); 48 | exit(-1); 49 | } 50 | break; 51 | case 'l': 52 | linemode++; 53 | break; 54 | case 'p': 55 | if(argv[0][2]) prefix = &argv[0][2]; 56 | break; 57 | default: 58 | fprintf(stderr,"Bad option %c\n",argv[0][1]); 59 | exit(-1); 60 | } 61 | else 62 | { 63 | process(argv[0]); 64 | processed++; 65 | } 66 | argv++; 67 | } 68 | if(!processed) process(0); /* if none given, process standard input */ 69 | exit(0); 70 | } 71 | 72 | process(name) 73 | char *name; 74 | { 75 | int infile, outfile, nbytes, retval; 76 | char filename[100]; 77 | char *coreloc; 78 | 79 | if(!name) 80 | { 81 | infile = 0; /* standard input */ 82 | name = "standard input"; 83 | } 84 | else if((infile = open(name,0)) < 0) 85 | { 86 | perror(name); 87 | exit(-1); 88 | } 89 | 90 | if((coreloc = (char *) malloc(chars)) <= 0) 91 | { 92 | fprintf(stderr,"Allocation of %d bytes failed\n",chars); 93 | } 94 | 95 | while((retval = fillbuf(coreloc,infile,chars)) > 0) 96 | { 97 | if(d2 >= 26) { d1++ ; d2=0;}; 98 | sprintf(filename,"%s%c%c",prefix, 99 | (int) 'a' + d1, 100 | (int) 'a' + d2++); 101 | if((outfile = creat(filename,0666)) < 0) 102 | { 103 | perror(filename); 104 | exit(-1); 105 | } 106 | if(write(outfile,coreloc,retval) != retval) 107 | { 108 | perror(name); 109 | exit(-1); 110 | } 111 | if(linemode) 112 | { 113 | while(1) 114 | { 115 | if(read(infile,coreloc,1) > 0) 116 | { 117 | write(outfile,coreloc,1); 118 | if(*coreloc == '\n') break; 119 | } 120 | else break; 121 | } 122 | } 123 | close(outfile); 124 | } 125 | if(retval < 0) 126 | { 127 | perror(name); 128 | exit(-1); 129 | } 130 | free(coreloc); /* give back space */ 131 | 132 | } 133 | 134 | fillbuf(buffer,filenum,size) 135 | char *buffer; 136 | int filenum,size; 137 | { 138 | int grab,got; 139 | char *ptr; 140 | 141 | grab = size; 142 | ptr = buffer; 143 | while((got = read(filenum,ptr,grab)) > 0) 144 | { 145 | ptr += got; 146 | grab -= got; 147 | if(grab <= 0) break; 148 | if((got == 0) && (grab == size)) break; 149 | } 150 | if((got <= 0) && (grab == size)) return(got); /* error or eof */ 151 | else return(size-grab); /* else return amount grabbed */ 152 | } 153 | 154 | 155 | -------------------------------------------------------------------------------- /liszt/chead.l: -------------------------------------------------------------------------------- 1 | ;;; ---- c h e a d header file for inclusion 2 | 3 | ;$Header: chead.l,v 1.9 87/12/16 11:56:14 sklower Exp $ 4 | ; 5 | ; -[Tue Nov 22 08:32:26 1983 by jkf]- 6 | 7 | ; Copyright (c) 1982 , The Regents of the University of California. 8 | ; Copyright (c) 1980 , The Regents of the University of California. 9 | ; All rights reserved. 10 | 11 | ; authors: John K. Foderaro and Kevin Layer 12 | 13 | (putprop 'chead t 'version) ; flag that this file has been loaded 14 | 15 | ;--- build tahoe by default 16 | ; 17 | (cond ((not (or (status feature for-vax) (status feature for-68k) 18 | (status feature for-tahoe))) 19 | (sstatus feature for-tahoe))) 20 | 21 | ; global franz special variables 22 | (declare (special $gcprint ; t means print stats when gc occurs. 23 | $ldprint ; t means print fasl messages 24 | $gccount$ ; incremented every gc 25 | $global-reg$ ; t means that np and lbot are in global regs 26 | float-format ; printf string used to print flonums 27 | lisp-library-directory ; contains as assembler 28 | lisp-object-directory ; contains lisp for -r option 29 | franz-minor-version-number ; just what it says 30 | )) 31 | 32 | ; keep 'em sorted please! 33 | (declare (special 34 | Liszt-file-names 35 | arithequiv 36 | bnp-sym 37 | ch-newline 38 | compiler-name 39 | er-fatal ;; # of fatal erros 40 | er-warn ;; # of warnings 41 | fl-anno 42 | fl-asm 43 | fl-comments 44 | fl-inter 45 | fl-macl 46 | fl-profile 47 | fl-tran 48 | fl-tty 49 | fl-verb 50 | fl-vms 51 | fl-warn 52 | fl-xref 53 | formsiz 54 | g-allf 55 | g-arginfo 56 | g-args 57 | g-arrayspecs 58 | g-bindloc 59 | g-bindtype 60 | g-calltype 61 | g-cc 62 | g-comments 63 | g-compfcn ; t if compiling a function 64 | g-complrname 65 | g-current 66 | g-currentargs 67 | g-decls 68 | g-didvectorcode 69 | g-dropnpcnt 70 | g-falseop 71 | g-flocal 72 | g-fname 73 | g-ftype 74 | g-funcs 75 | g-functype 76 | g-ignorereg 77 | g-labs 78 | g-litcnt 79 | g-lits 80 | g-loc 81 | g-localf 82 | g-loccnt 83 | g-locs 84 | g-masklab 85 | g-optionalp 86 | g-reflst 87 | g-refseen 88 | g-regmaskvec 89 | g-reguse 90 | g-ret 91 | g-skipcode 92 | g-spec 93 | g-stackspace 94 | g-stdref 95 | g-topsym 96 | g-tran 97 | g-tranloc 98 | g-trancnt 99 | g-trueloc 100 | g-trueop 101 | g-vartype 102 | ibase 103 | in-line-lambda-number 104 | internal-macros 105 | k-ftype 106 | liszt-eof-forms 107 | liszt-file-name 108 | liszt-process-forms 109 | liszt-root-name 110 | macros 111 | old-declare-fcn 112 | old-top-level 113 | original-readtable 114 | piport 115 | poport 116 | readtable 117 | special 118 | twa-list 119 | user-top-level 120 | v-form 121 | v-ifile 122 | v-sfile 123 | v-xfile 124 | vms-pointers 125 | vns-include 126 | vp-sfile 127 | vp-xfile 128 | vps-include)) 129 | 130 | (eval-when (compile eval) 131 | (or (get 'const 'loaded) (load '../const.l))) 132 | 133 | ; load in the macro files if compiling or interpreting. 134 | ; 135 | (eval-when (compile eval) 136 | (or (get 'cmacros 'version) (load 'cmacros))) 137 | -------------------------------------------------------------------------------- /lisplib/common3.l: -------------------------------------------------------------------------------- 1 | (setq rcs-common2- 2 | "$Header: common3.l,v 1.4 84/02/29 23:23:35 layer Exp $") 3 | 4 | ;; 5 | ;; common3.l -[Sat Sep 10 10:51:18 1983 by jkf]- 6 | ;; 7 | ;; 8 | 9 | (declare (macros t)) 10 | 11 | (defun litatom macro (x) 12 | `(and (atom . ,(cdr x)) 13 | (not (numberp . ,(cdr x))))) 14 | 15 | ; This function really should compile optimally in-line 16 | ; 17 | (defun nequal (arg1 arg2) 18 | (not (equal arg1 arg2))) 19 | 20 | (defun lineread (&rest args) 21 | (let (flag port) 22 | (mapc (function ; get the options 23 | (lambda (x) 24 | (cond ((portp x) (setq port x)) 25 | ((setq flag x))))) 26 | args) 27 | (cond ((not (and flag ; flag for empty line 28 | (eq (tyipeek port) #\lf) 29 | (tyi port))) 30 | (prog (input) 31 | (setq input (ncons nil)) ; initialize for tconc. 32 | (tconc input (read port)) ; do read to make sure 33 | ; an s-expression gets read 34 | loop 35 | (cond ((not (eq (tyipeek port) #\lf)) 36 | (tconc input (read port)) 37 | (go loop)) 38 | ( t ; the actual list is in the CAR. 39 | (tyi port) 40 | (return (car input))))))))) 41 | 42 | (defun defv fexpr (l) 43 | (set (car l) (cadr l))) 44 | 45 | 46 | (defun initsym (&rest l) 47 | (mapcar (function initsym1) l)) 48 | 49 | (defun initsym1 expr (l) 50 | (prog (num) 51 | (cond ((dtpr l) 52 | (setq num (cadr l)) 53 | (setq l (car l))) 54 | ( t (setq num 0))) 55 | (putprop l num 'symctr) 56 | (return (concat l num)))) 57 | 58 | (defun newsym (name) 59 | (concat name 60 | (putprop name 61 | (1+ (or (get name 'symctr) 62 | -1)) 63 | 'symctr))) 64 | 65 | (defun oldsym (sym) 66 | (cond ((get sym 'symctr) (concat sym (get sym 'symctr))) 67 | ( t sym))) 68 | 69 | (defun allsym (name) 70 | (prog (num symctr syms) 71 | (cond ((dtpr name) 72 | (setq num (cadr name)) 73 | (setq name (car name))) 74 | ( t (setq num 0))) 75 | (or (setq symctr (get name 'symctr)) 76 | (return)) 77 | loop 78 | (and (>& num symctr) 79 | (return syms)) 80 | (setq syms (cons (concat name symctr) syms)) 81 | (setq symctr (1- symctr)) 82 | (go loop))) 83 | 84 | (defun remsym (&rest l) 85 | (mapcar (function remsym1) l)) 86 | 87 | (defun remsym1 expr (l) 88 | (prog1 (oldsym (cond ((dtpr l) (car l)) 89 | ( t l))) 90 | (mapc (function remob) (allsym l)) 91 | (cond ((dtpr l) 92 | (putprop (car l) (1- (cadr l)) 'symctr)) 93 | ( t (remprop l 'symctr))))) 94 | 95 | (defun symstat (&rest l) 96 | (mapcar (function (lambda (k) 97 | (list k (get k 'symctr)))) 98 | l)) 99 | 100 | ;; from peter@renoir 101 | (defun wide-print-list (given-list &optional (left-margin (nwritn))) 102 | ; given a (presumably long) list, print it as wide as possible. 103 | (declare (special lpar rpar)) 104 | (let ((max-width 78)) 105 | (tab left-margin) 106 | (cond ((not (listp given-list)) 107 | (patom given-list)) 108 | ((null given-list) 109 | (patom nil)) 110 | (t 111 | (patom lpar) 112 | (do ((left given-list (cdr left)) 113 | (need-space-p nil t)) 114 | ((null left) nil) 115 | (cond (need-space-p 116 | (patom " "))) 117 | (let* ((element (car left)) 118 | (length (flatc element)) 119 | (used (nwritn)) 120 | (available (- max-width used))) 121 | (cond ((>= length available) 122 | (tab (1+ left-margin)))) 123 | (cond ((listp element) 124 | (wide-print-list element)) 125 | (t 126 | (patom element))))) 127 | (patom rpar))))) 128 | -------------------------------------------------------------------------------- /lisplib/fcninfo.l: -------------------------------------------------------------------------------- 1 | (setq rcs-fcninfo- "$Header: fcninfo.l,v 1.2 84/01/29 23:39:00 layer Exp $") 2 | 3 | ;; 4 | ;; fcninfo.l -[Sun Jan 29 23:38:10 1984 by layer]- 5 | ;; 6 | ;; This is normally not loaded into a lisp system but is loaded into 7 | ;; the compiler. 8 | ;; number of arguments information for C coded functions 9 | ;; not included: evalframe evalhook wait exece 10 | ;; stopped in sysat.c after *invmod 11 | ; 12 | ;; the information is stored in such as way as to minimize the 13 | ;; amount of space required to store the informaion. 14 | 15 | 16 | (eval-when (compile eval) 17 | (setq cdescrip " defined in C-coded kernel")) 18 | 19 | (defmacro decl-fcn-info (tag fcns) 20 | `(let ((fcninfo ',tag)) 21 | ,@(mapcar '(lambda (fcn) `(putprop ',fcn fcninfo 'fcn-info)) fcns))) 22 | (defmacro zero (&rest args) 23 | `(decl-fcn-info ((0 . 0) ,cdescrip) ,args)) 24 | (defmacro zero-to-one (&rest args) 25 | `(decl-fcn-info ((0 . 1) ,cdescrip) ,args)) 26 | (defmacro zero-to-two (&rest args) 27 | `(decl-fcn-info ((0 . 2) ,cdescrip) ,args)) 28 | (defmacro zero-to-inf (&rest args) 29 | `(decl-fcn-info (nil ,cdescrip) ,args)) 30 | (defmacro one (&rest args) 31 | `(decl-fcn-info ((1 . 1) ,cdescrip) ,args)) 32 | (defmacro one-to-two (&rest args) 33 | `(decl-fcn-info ((1 . 2) ,cdescrip) ,args)) 34 | (defmacro one-to-three (&rest args) 35 | `(decl-fcn-info ((1 . 3) ,cdescrip) ,args)) 36 | (defmacro one-to-inf (&rest args) 37 | `(decl-fcn-info ((1 . nil) ,cdescrip) ,args)) 38 | (defmacro two (&rest args) 39 | `(decl-fcn-info ((2 . 2) ,cdescrip) ,args)) 40 | (defmacro two-to-inf (&rest args) 41 | `(decl-fcn-info ((1 . nil) ,cdescrip) ,args)) 42 | (defmacro three (&rest args) 43 | `(decl-fcn-info ((3 . 3) ,cdescrip) ,args)) 44 | (defmacro three-to-five (&rest args) 45 | `(decl-fcn-info ((3 . 5) ,cdescrip) ,args)) 46 | (defmacro three-to-inf (&rest args) 47 | `(decl-fcn-info ((3 . nil) ,cdescrip) ,args)) 48 | (defmacro four (&rest args) 49 | `(decl-fcn-info ((4 . 4) ,cdescrip) ,args)) 50 | (defmacro five (&rest args) 51 | `(decl-fcn-info ((5 . 5) ,cdescrip) ,args)) 52 | 53 | 54 | (zero baktrace fork oblist ptime reset resetio zapline) 55 | (zero-to-one arg close drain dumplisp exit 56 | gensym monitor nwritn random return terpr time-string tyipeek) 57 | (zero-to-two err ratom read readc tyi) 58 | (zero-to-inf + - * / and concat cond 59 | difference greaterp lessp list or plus product prog quotient setq 60 | sum times unconcat) 61 | (one 1+ 1- absval add1 62 | aexplode aexplodec aexploden argv 63 | arrayp ascii asin acos atom bcdp 64 | bignum-to-list boundp car cdr chdir cos 65 | dtpr exp fact fake fix float frexp function get_pname getaccess getaux 66 | getd getdata getdelta 67 | getentry getenv getdisc getlength go haulong infile log 68 | implode intern maknam maknum makunbound minus minusp 69 | not ncons null numberp onep plist pntlen portp ptr 70 | quote readlist remob *rset sin sizeof stringp sub1 sqrt symbolp 71 | truename type valuep zerop) 72 | (one-to-two errset flatc outfile patom print status tyo untyi) 73 | (one-to-three fasl load process) 74 | (one-to-inf funcall progv) 75 | (two allocate alphalessp 76 | arrayref assq atan bignum-leftshift *catch cons 77 | Divide eq equal freturn 78 | get haipart *invmod lsh 79 | mfunction mod *mod nthelem putaux putd 80 | putdata putdelta putdisc putlength 81 | remprop replace rot rplaca rplacd segment set setarg setplist scons 82 | signal sstatus sticky-bignum-leftshift *throw 83 | vref vrefi-byte vrefi-word vrefi-long) 84 | 85 | (two-to-inf apply def mapc mapcan mapcar mapcon maplist prog2) 86 | (three putprop) 87 | (three-to-five cfasl) 88 | (three-to-inf boole) 89 | (four Emuldiv) 90 | (five marray) 91 | 92 | -------------------------------------------------------------------------------- /pearl/template: -------------------------------------------------------------------------------- 1 | TTTTTTTTT EEEEEEE M M PPPPP L AA TTTTTTTTT EEEEEEE 2 | T E MM MM P P L A A T E 3 | T EEEEE M M M M PPPPP L AAAAAA T EEEEE 4 | T E M M M P L A A T E 5 | T EEEEEEE M M P LLLLLL A A T EEEEEEE 6 | 7 | Structure Definition Information Template 8 | 9 | Header 10 | ||=========================================|| 11 | || 0 unique number (integer) || 12 | || 1 *pearldefinition* tag (atom ptr) || 13 | || 2 length (integer) || 14 | || 3 default instance (core ptr) || 15 | || 4 isa (core ptr) || 16 | || 5 print name (atom ptr) || 17 | || 6 hash alias (integer) || 18 | || 7 hash focus (integer) || 19 | || 8 expansion list (list ptr) || 20 | || 9 base hooks (lisp ptr) || 21 | ||=========================================|| 22 | 23 | and for each slot (multiply slot number by 4 and add): 24 | ||=========================================|| 25 | || +6 free (28)! enforce (1) ! hash (6) || 26 | || +7 type number (integer) || 27 | || +8 slot print name (atom ptr) || 28 | || +9 pp set info (atom ptr) || 29 | ||=========================================|| 30 | 31 | 32 | 33 | 34 | Structure Instance Template 35 | 36 | Header 37 | ||=========================================|| 38 | || 0 definition (core ptr) || 39 | || 1 *pearlinst* tag (atom ptr) || 40 | || 2 a-list and alist copy (conscell) || 41 | || 3 abbreviation (atom ptr) || 42 | ||=========================================|| 43 | 44 | and for each slot (multiply slot number by 4 and add): 45 | ||=========================================|| 46 | || +0 value type (integer) || 47 | || +1 value ( ? ptr) || 48 | || +2 predicate list (list ptr) || 49 | || +3 slothook list (list ptr) || 50 | ||=========================================|| 51 | 52 | 53 | 54 | symbol template 55 | 56 | ||=========================================|| 57 | || 0 unique number (integer) || 58 | || 1 *pearlsymbol* tag (atom ptr) || 59 | || 2 print name (atom ptr) || 60 | ||=========================================|| 61 | 62 | 63 | 64 | data bases 65 | 66 | header 67 | ||=========================================|| 68 | || 0 name (atom ptr) || 69 | || 1 *pearldb* tag (atom ptr) || 70 | || 2 children (lisp ptr) || 71 | || 3 active (t or nil) || 72 | || 4 parent (lisp ptr) || 73 | || 5 db1 (core ptr) || 74 | || 6 db2 (core ptr) || 75 | ||=========================================|| 76 | 77 | and for each hash slot i (a small 1 hash db and then a large 2/3 hash db): 78 | ||=========================================|| 79 | || i hash bucket (lisp ptr) || 80 | ||=========================================|| 81 | 82 | 83 | block template (3 cons-cells) 84 | 85 | b:Name ---+ 86 | | 87 | ||========V================================|| 88 | || Name (atom) | ptr to vars part || 89 | ||==========================|==============|| 90 | | 91 | ||==========V==============================|| 92 | Name ---> || ptr to 2nd conscell | ptr to free vars || 93 | ||==========|==============================|| 94 | | 95 | ||==========V==============================|| 96 | || ptr to frozen vars | *pearlunbound* || 97 | ||=========================================|| 98 | -------------------------------------------------------------------------------- /franz/lamgc.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: lamgc.c,v 1.5 84/03/31 22:34:28 layer Exp $"; 4 | #endif 5 | 6 | /* -[Sat Jan 29 13:07:37 1983 by jkf]- 7 | * lamgc.c $Locker: $ 8 | * file used to meter gc, not always loaded 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | #include "global.h" 14 | #include "gc.h" 15 | #include 16 | #ifdef METER 17 | #include 18 | #endif 19 | 20 | /* 21 | this file is temporary and will contain routines to meter 22 | the garbage collector 23 | */ 24 | 25 | /* gcstat - temporary routine used to report on gc statistics. 26 | if this causes variables to be undefined,then it should be removed 27 | */ 28 | 29 | extern int *beginsweep,gensymcounter; 30 | int gcstat; 31 | int mrkdpcnt; 32 | int gccount; 33 | int conssame; 34 | int consdiff; 35 | int consnil; 36 | 37 | 38 | /* 39 | * gcstat - initiate and record gc statistics 40 | * calls: 41 | * (gcstat 0) -- initiate gc statistics by creating gc.out 42 | * and writing header. 43 | * (gcstat 1) -- finish off gc statistics file by writing typetable 44 | * and closing file. 45 | */ 46 | lispval 47 | Lgcstat() 48 | { 49 | register lispval handy; 50 | int nbytes; 51 | struct gchead hhh; 52 | 53 | chkarg(1,"gcstat"); 54 | 55 | if(TYPE(handy=lbot->val) != INT) 56 | { error("gcstat: non integer arg ",FALSE); 57 | } 58 | 59 | switch(handy->i) 60 | { 61 | case 0: if((gcstat = creat("gc.out",0644)) < 0) 62 | error("cant open gc.out",FALSE); 63 | hhh.version = 5; 64 | hhh.lowdata = (int)beginsweep; 65 | printf("writing %d bytes \n",sizeof(hhh)); 66 | write(gcstat,(char *)&hhh,sizeof(hhh)); 67 | gccount = 0; 68 | return(tatom); 69 | 70 | case 1: 71 | /* first write out the type table */ 72 | nbytes = 0; 73 | /* 0 means type table follows */ 74 | printf("gc's %d, writing %d bytes \n",gccount, 75 | sizeof(nbytes)); 76 | write(gcstat,(char *)&nbytes,sizeof(nbytes)); 77 | write(gcstat,(char *)&typetable[ATOX(beginsweep)+1], 78 | nbytes = ((int)datalim - (int)beginsweep)>>9); 79 | printf("writing %d bytes \n",nbytes+sizeof(nbytes)); 80 | write(gcstat,(char *)&nbytes,sizeof(nbytes)); 81 | close(gcstat); 82 | gcstat = 0; 83 | return(inewint(nbytes)); 84 | default: 85 | error("Bad value to gcstat ",TRUE); 86 | } 87 | /* NOTREACHED */ 88 | } 89 | extern int bitmapi[]; /* a bit of a lie it is really a double array*/ 90 | char *bitmapc = (char *)bitmapi; 91 | /* called in the garbage collector after the bit maps have been made 92 | only if gcstat is non zero */ 93 | gcdump() 94 | { 95 | #ifdef 96 | extern struct vtimes premark,presweep,alldone; 97 | int nbytes, recsize; 98 | /* 16 bytes/page in the bitmap */ 99 | nbytes = (((int) datalim - (int) beginsweep) >> 9) * 16; 100 | recsize = nbytes + 6*sizeof(int) + 3*sizeof(struct vtimes); 101 | write(gcstat,(char *)&recsize,sizeof(recsize)); /* whole record size */ 102 | write(gcstat,(char *)&premark,sizeof(premark)); 103 | write(gcstat,(char *)&presweep,sizeof(presweep)); 104 | write(gcstat,(char *)&alldone,sizeof(alldone)); 105 | write(gcstat,(char *)&gensymcounter,sizeof(int)); 106 | write(gcstat,(char *)&conssame,sizeof(int)); 107 | write(gcstat,(char *)&consdiff,sizeof(int)); 108 | write(gcstat,(char *)&consnil,sizeof(int)); 109 | write(gcstat,(char *)&mrkdpcnt,sizeof(int)); 110 | write(gcstat,(char *)&nbytes,sizeof(nbytes)); /* bit table size */ 111 | write(gcstat,(char *)&bitmapc[ATOX(beginsweep) * 16],nbytes); 112 | printf("gc: %d, written %d bytes\n",++gccount,nbytes); 113 | #endif 114 | } 115 | -------------------------------------------------------------------------------- /franz/trace.c: -------------------------------------------------------------------------------- 1 | #ifndef lint 2 | static char *rcsid = 3 | "$Header: /na/franz/franz/RCS/trace.c,v 1.2 83/08/19 09:50:34 jkf Exp $"; 4 | #endif 5 | 6 | /* -[Thu Aug 18 10:08:36 1983 by jkf]- 7 | * trace.c $Locker: $ 8 | * evalhook evaluator 9 | * 10 | * (c) copyright 1982, Regents of the University of California 11 | */ 12 | 13 | #include "global.h" 14 | lispval 15 | Leval1(){ 16 | register struct nament *bindptr; 17 | register lispval handy; 18 | if (np-lbot == 2) { /*if two arguments to eval */ 19 | if (TYPE((lbot+1)->val) != INT) 20 | error("Eval: 2nd arg not legal alist pointer", FALSE); 21 | bindptr = orgbnp + (lbot+1)->val->i; 22 | if (rsetsw == 0 || rsetatom->a.clb == nil) 23 | error("Not in *rsetmode; second arg is useless - eval", TRUE); 24 | if (bptr_atom->a.clb != nil) 25 | error("WARNING - Nesting 2nd args to eval will give spurious values", TRUE); 26 | if (bindptr < orgbnp || bindptr >bnplim) 27 | error("Illegal pdl pointer as 2nd arg - eval", FALSE); 28 | handy = newdot(); 29 | handy->d.car = (lispval)bindptr; 30 | handy->d.cdr = (lispval)bnp; 31 | PUSHDOWN(bptr_atom, handy); 32 | handy = eval(lbot->val); 33 | POP; 34 | return(handy); 35 | } else { /* normal case - only one arg */ 36 | chkarg(1,"eval"); 37 | handy = eval(lbot->val); 38 | return(handy); 39 | }; 40 | } 41 | 42 | lispval 43 | Levalhook() 44 | { 45 | register lispval handy; 46 | register lispval funhval = CNIL; 47 | 48 | switch (np-lbot) 49 | { 50 | case 2: break; 51 | case 3: funhval = (lbot+2)->val; 52 | break; 53 | default: argerr("evalhook"); 54 | } 55 | 56 | /* Don't do this check any longer 57 | * if (evalhsw == 0) 58 | * error("evalhook called before doing sstatus-evalhook", TRUE); 59 | * if (rsetsw == 0 || rsetatom->a.clb == nil) 60 | * error("evalhook called while not in *rset mode", TRUE); 61 | */ 62 | 63 | if(funhval != CNIL) { PUSHDOWN(funhatom,funhval); } 64 | 65 | PUSHDOWN(evalhatom,(lispval)(lbot+1)->val); 66 | /* eval checks evalhcall to see if this is a LISP call to evalhook 67 | in which case it avoids call to evalhook function, but clobbers 68 | value to nil so recursive calls will check. */ 69 | evalhcallsw = TRUE; 70 | handy = eval(lbot->val); 71 | POP; 72 | 73 | if(funhval != CNIL) { POP; } 74 | 75 | return(handy); 76 | } 77 | 78 | 79 | lispval 80 | Lfunhook() 81 | { 82 | register lispval handy; 83 | register lispval evalhval = CNIL; 84 | Savestack(2); 85 | 86 | 87 | switch (np-lbot) 88 | { 89 | case 2: break; 90 | case 3: evalhval = (lbot+2)->val; 91 | break; 92 | default: argerr("funcallhook"); 93 | } 94 | 95 | /* Don't do this check any longer 96 | * if (evalhsw == 0) 97 | * error("funcallhook called before doing sstatus-evalhook", TRUE); 98 | *if (rsetsw == 0 || rsetatom->a.clb == nil) 99 | * error("funcallhook called while not in *rset mode", TRUE); 100 | */ 101 | 102 | handy = lbot->val; 103 | while (TYPE(handy) != DTPR) 104 | handy = errorh1(Vermisc,"funcallhook: first arg must be a list",nil,TRUE, 105 | 0,handy); 106 | if(evalhval != CNIL) { PUSHDOWN(evalhatom,evalhval); } 107 | 108 | PUSHDOWN(funhatom,(lispval)(lbot+1)->val); 109 | /* funcall checks funcallhcall to see if this is a LISP call to evalhook 110 | in which case it avoids call to evalhook function, but clobbers 111 | value to nil so recursive calls will check. */ 112 | funhcallsw = TRUE; 113 | /* 114 | * the first argument to funhook is a list of already evaluated expressions 115 | * which we just stack can call funcall on 116 | */ 117 | lbot = np; /* base of new args */ 118 | for ( ; handy != nil ; handy = handy->d.cdr) 119 | { 120 | protect(handy->d.car); 121 | } 122 | handy = Lfuncal(); 123 | POP; 124 | if(evalhval != CNIL) { POP; } 125 | Restorestack(); 126 | return(handy); 127 | } 128 | 129 | 130 | lispval 131 | Lrset () 132 | { 133 | chkarg(1,"rset"); 134 | 135 | rsetsw = (lbot->val == nil) ? 0 : 1; 136 | rsetatom->a.clb = (lbot->val == nil) ? nil: tatom; 137 | evalhcallsw = FALSE; 138 | return(lbot->val); 139 | } 140 | 141 | -------------------------------------------------------------------------------- /doc/lmacs: -------------------------------------------------------------------------------- 1 | ." @(#)lmacs 34.4 3/23/82 2 | ." $Header: lmacs 1.2 83/07/01 11:21:33 sklower Exp $ 3 | .""""""" 4 | ." macros for the Franz Lisp Manual 5 | ." 6 | ." first we set these global me variables 7 | ."""""""" 8 | .nr ss 3v \" space 4v between sections 9 | ."" comment: 10 | .nr si 3n \" section indent 11 | ."""""""" 12 | ." the following two lines are for larger type font 13 | ." .nr pp 12 14 | ." .nr sp 12 15 | ." If we are making an on line manual, include the line below: 16 | .if 0 .ll 7.5i \" extra wide for nroff, DISABLED 17 | .""""""""""""""" 18 | ." A chapter is begun by 19 | ." .Lc chaptertitle number 20 | ." 21 | ." a function is introduced by a 22 | ." .Lf functionname arglist 23 | ." where the arglist must be one string, use "'s if necessary. 24 | ." if there are two names for a function then the first is called with 25 | ." .Lf and subsequent ones with .Lx 26 | ." then there are these macros to begin text describing what the function 27 | ." does: 28 | ." .Wh 29 | ." says "WHERE" allowing you to give more 30 | ." details on a function. 31 | ." .Re 32 | ." tells what value the function returns 33 | ." 34 | ." .No 35 | ." begins a note, giving more detail on the fcn 36 | ." 37 | ." .Se 38 | ." describes a size effect of a function. 39 | ." 40 | ." .Im 41 | ." note to implementor. this will only be 42 | ." printed out in the implementors version of 43 | ." the manual. 44 | ." .Rm prints a message about this function being 45 | ." likely to disappear 46 | ." 47 | ." .Ex begin a short example 48 | ." 49 | ." .Eb begin an large offset example 50 | ." .Ee end an example 51 | ." 52 | ." .Fb begin a large offset example but don't 53 | ." try to keep it on one page. 54 | ." .Fe end what .Fb started 55 | ." 56 | ." useful macros 57 | ." .Fr rest prints out Franz Lisp and appends rest 58 | ." to it. 59 | ." 60 | ." used in creating the index, table of contents and appendicies 61 | ." 62 | ." .Ib begin index 63 | ." .In ch# pg# fcn-name fcn-args this isnt inserted by hand, but 64 | ." is generated by the index program. it indicates 65 | ." where a function begins. 66 | ." 67 | ." .Ap c T begin appendix c with title T 68 | ." 69 | ."""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" 70 | .de Lc 71 | ." .in 0 72 | .++ RC '\\$1''\\\\\\\\\\\\\\\\n(ch-%' 73 | .nr % 2 74 | .nr ch \\$2-1 75 | .+c \\$1 76 | .fo '''\fR\s-2Printed:\ \*(td\s0\fP' 77 | .. 78 | .de Lf 79 | .sp 1v 80 | .ne 11 81 | .Lx \\$1 "\\$2" 82 | .. 83 | .de Lx 84 | .in 0 85 | .ie '\\$2'' \fB(\\$1)\fP 86 | .el \fB(\\$1\fP \\$2\fB)\fP 87 | .br 88 | .nr $i 5n 89 | ." if troff, then put nice index entry, if nroff then we are making an 90 | ." online manual so put out a cryptic lisp expression. If you want to 91 | ." make an nroff version of the manual with index, then you will have 92 | ." to alter the lines below: replace .if t with .if 1 and .if n with .if 0 93 | .if t .tm .In \\n(ch \\n% \\$1 "\\$2" 94 | .if n .tm (\\$1 ch\\n(ch.r) 95 | .. 96 | .de Re 97 | .ip \s-2RETURNS\s0: 9 98 | .. 99 | .de Ex 100 | .ip \s-2EXAMPLE\s0: 9 101 | .. 102 | .de No 103 | .ip \s-2NOTE\s0: 6 104 | .. 105 | .de Eq 106 | .ip \s-2EQUIVALENT\ TO\s0: 15 107 | .. 108 | .de Im 109 | .ip \s-2IMPLEMENTATION\s0: 20 110 | .. 111 | .de Se 112 | .ip \s-2SIDE\ EFFECT\s0: 13 113 | .. 114 | .de Wh 115 | .ip \s-2WHERE\s0: 9 116 | .. 117 | .de Rm 118 | .No 119 | this function will most likely disappear in future releases. 120 | .. 121 | .de Fr 122 | F\s-2RANZ\s0 L\s-2ISP\s0\\$1 123 | .. 124 | .de Ib \" beginning of index 125 | .Ap 1 Index\ to\ F\s-2RANZ\s0\ L\s-2ISP\s0\ Functions 126 | .ta 6i \" set tab stop for location column 127 | .tc . \" generate dots to line up page numbers 128 | .nf 129 | .. 130 | .de In 131 | .ie '\\$4'' (\\fB\\$3\\fR)\t\\$1-\\$2 132 | .el (\\fB\\$3\\fR\ \\$4)\t\\$1-\\$2 133 | .. 134 | .de Eb 135 | .in 0 136 | .(b 137 | .sp 1v 138 | .hl 139 | .sz -2 140 | .. 141 | .de Ee 142 | .sz +2 143 | .hl 144 | .sp 1v 145 | .)b 146 | .. 147 | .de Fb 148 | .in 0 149 | .sp 1v 150 | .ne 1i 151 | .hl 152 | .sz -2 153 | .. 154 | .de Fe 155 | .sz +2 156 | .hl 157 | .sp 1v 158 | .. 159 | .de Ap \" appendix n title (n is 1 2 3 4 for A B C D etc) 160 | .++ RA '''\\\\\\\\\\\\\\\\n(ch-%' 161 | .nr ch \\$1-1 162 | .+c \\$2 163 | .fo '''\fR\s-2Printed:\ \*(td\s0\fP' 164 | .. 165 | -------------------------------------------------------------------------------- /lisplib/Makefile: -------------------------------------------------------------------------------- 1 | # $Header: Makefile,v 1.14 87/12/15 16:33:48 sklower Exp $ 2 | # Makefile for /usr/lib/lisp 3 | # this directory contains the lisp coded portion of the standard 4 | # lisp system and other useful lisp programs. 5 | # The command 'make all' insures that all source files are compiled 6 | # The command 'make install' installs these files in the standard 7 | # place (/usr/lib/lisp). This is only useful of course if the current 8 | # directory is not /usr/lib/lisp. 9 | # 10 | .SUFFIXES: .l.s.o 11 | 12 | .l.s: 13 | ${Liszt} -xaqS $* 14 | .l.o: 15 | ${Liszt} -xaq $* 16 | 17 | #--- Default paths and programs: 18 | LibDir = /usr/lib/lisp 19 | CopyTo = /dev/null 20 | Liszt = liszt 21 | 22 | 23 | #--- ReqSrc: required source for building lisp system 24 | # 25 | ReqSrc = charmac.l common0.l common1.l common2.l common3.l toplevel.l \ 26 | syntax.l macros.l vector.l array.l pp.l format.l version.l \ 27 | tpl.l fcninfo.l 28 | 29 | 30 | #--- OtherSrc: other lisp coded library files 31 | OtherSrc = machacks.l loop.l ucifnc.l ucido.l jkfmacs.l trace.l\ 32 | record.l syscall.l \ 33 | cmumacs.l cmufncs.l fix.l step.l cmufile.l cmutpl.l cmuedit.l \ 34 | structini.l struct.l prof.l hash.l flavorm.l lmhacks.l 35 | 36 | LocalSrc = describe.l flavors.l vanilla.l 37 | 38 | ReqObj = charmac.o common0.o common1.o common2.o common3.o toplevel.o \ 39 | syntax.o macros.o vector.o array.o pp.o format.o version.o \ 40 | tpl.o fcninfo.o 41 | 42 | OtherObj = machacks.o loop.o ucifnc.o ucido.o jkfmacs.o trace.o\ 43 | record.o syscall.o\ 44 | cmumacs.o cmufncs.o fix.o step.o cmufile.o cmutpl.o cmuedit.o \ 45 | struct.o prof.o hash.o flavorm.o lmhacks.o 46 | 47 | LocalObj = describe.o flavors.o vanilla.o 48 | 49 | #--- AllSrc: all source files required for lisp system 50 | # LocalSrc isn't included! 51 | # Now it is! (SMH@MIT-EMS) 52 | 53 | AllSrc = Makefile ReadMe buildlisp.l cmuenv.l fixit.ref \ 54 | ${ReqSrc} ${OtherSrc} autorun/vax autorun/tahoe autorun/unisoft \ 55 | autorun/sun4.2 autorun/mc500 autorun/68k \ 56 | $(LocalSrc) 57 | 58 | AllObj = ${ReqObj} ${OtherObj} 59 | 60 | # all: ${AllObj} 61 | 62 | all: ${AllObj} ${LocalObj} 63 | 64 | required: ${ReqObj} 65 | 66 | DotSSrc = charmac.s common0.s common1.s\ 67 | common2.s common3.s toplevel.s syntax.s macros.s\ 68 | vector.s array.s pp.s format.s\ 69 | version.s tpl.s fcninfo.s 70 | 71 | xtra: ${DotSSrc} 72 | 73 | fromasm: 74 | for i in *.s; do echo $$i; ${LibDir}/as $$i; done 75 | # rm -f *.s 76 | 77 | 78 | ## defstruct should be compiled with a compiled version of itself. 79 | ## When a compiled form doesn't exist, structini.l can be used to 80 | ## build a struct.o which is close but not exactly what you want. 81 | ## Recompiling struct will use struct.o and create the correct struct.o 82 | ## 83 | struct-again: 84 | ${Liszt} -xaq struct 85 | 86 | ## The three flavor files have dependencies (SMH@MIT-EMS): 87 | flavors.o: flavorm.o 88 | vanilla.o: flavors.o 89 | 90 | ## this will only work if you have an up to date version of ctags which 91 | ## understands lisp files. 92 | 93 | tags: ${AllSrc} 94 | ctags ${AllSrc} 95 | 96 | sources: ${AllSrc} 97 | 98 | xref: 99 | lxref ${AllSrc} > xref 100 | 101 | echofiles: 102 | @echo ${ReqSrc} ${OtherSrc} 103 | 104 | echorequired: 105 | @echo ${ReqSrc} 106 | 107 | # updatemachine will vcp all objects and source to machine 108 | # named with 'mach' on the command line 109 | 110 | updatemachine: ${AllSrc} ${AllObj} 111 | -vcp -wfq /usr/ucb/lisp /usr/ucb/liszt ${mach}:. 112 | -vcp -wfq ${AllSrc} ${mach}:/usr/lib/lisp 113 | -vcp -wfq ${AllObj} ${mach}:/usr/lib/lisp 114 | 115 | copysource: ${AllSrc} 116 | (tar cf - ${AllSrc} | (cd ${CopyTo} ; tar xf -)) 117 | 118 | copyobjects: ${AllObj} 119 | (tar cf - ${AllObj} | (cd ${CopyTo} ; tar xf -)) 120 | 121 | scriptcatall: ${AllSrc} 122 | @(X=`pwd` ; cd ${CdTo}; scriptcat $$X lisplib ${AllSrc}) 123 | 124 | scriptcatxtra: 125 | @(X=`pwd` ; cd ${CdTo}; scriptcat $$X lisplib ${DotSSrc}) 126 | 127 | as: 128 | @echo "Grabbing as from /bin" 129 | cp /bin/as as 130 | 131 | nld: 132 | @echo "Grabbing nld from /bin" 133 | cp /bin/ld nld 134 | 135 | cleanreq: 136 | -rm -f ${ReqObj} 137 | 138 | cleanall: 139 | -rm -f ${AllObj} 140 | 141 | cleanother: 142 | -rm -f ${OtherObj} 143 | 144 | clean: 145 | -rm -f *.o 146 | -rm -f *.blat 147 | -rm -f *.x 148 | -------------------------------------------------------------------------------- /doc/ch17.n: -------------------------------------------------------------------------------- 1 | ." $Header: ch17.n,v 40.1 84/08/08 21:36:08 layer Exp $ 2 | ." (c) Copyright 1984, Franz Inc., Berkeley California 3 | .Lc Hash\ Tables 17 4 | .sh 2 Overview 5 | .pp 6 | A hash table is an object that can efficiently map a given object to another. 7 | Each hash table is a collection of entries, 8 | each of which associates a unique \fIkey\fP with a \fIvalue\fP. 9 | There are elemental functions to add, delete, and find entries 10 | based on a particular key. 11 | Finding a value in a hash table is relatively fast compared to 12 | looking up values in, for example, an assoc list or property list. 13 | .pp 14 | Adding a key to a hash table modifies the hash table, and so 15 | it is a descructive operation. 16 | .pp 17 | There are two different kinds of hash tables: those that use the 18 | function \fIequal\fP for the comparing of keys, and those that 19 | use \fIeq\fP, the default. 20 | If a key is "eq" to another object, then a match is assumed. 21 | Likewise with "equal". 22 | .sh 2 Functions 23 | .Lf makeht "'x_size ['s_test]" 24 | .Re 25 | A hash table of x_size hash buckets. 26 | If present, s_test is used as the test to compare keys in the 27 | hash table, the default being \fBeq\fP. 28 | \fIEqual\fP might be used to create a hash table where the 29 | keys are to be lists (or any lisp object). 30 | .No 31 | At this time, hash tables are implemented on top of vectors. 32 | .Lf hash-table-p "'H_arg" 33 | .Re 34 | t if H_arg is a hash table. 35 | .No 36 | Since hash tables are really vectors, the lisp type of a hash table 37 | is a vector, so that given a vector, this function will return t. 38 | .Lf gethash "'g_key 'H_htable ['g_default]" 39 | .Re 40 | the value associated the key g_key in hash table H_htable. 41 | If there is not an entry given by the key and g_default is specified, 42 | then g_default is returned, otherwise, a symbol that is unbound 43 | is returned. 44 | This is so that \fBnil\fP can be a associated with a key. 45 | .No 46 | \fIsetf\fP may be used to set the value assocaited with a key. 47 | .Lf remhash "'g_key 'H_htable" 48 | .Re 49 | t if there was an entry for g_key in the hash table 50 | H_htable, nil otherwise. In the case of a match, the 51 | entry and associated object are removed from the hash 52 | table. 53 | .Lf maphash "'u_func 'H_htable" 54 | .Re 55 | nil. 56 | .No 57 | The function u_func is applied to every element in the 58 | hash table H_htable. The function is called with two arguments: 59 | the key and value of an element. 60 | The mapped function should not add or delete object from the 61 | table because the results would be unpredicable. 62 | .Lf clrhash "'H_htable" 63 | .Re 64 | the hash table cleared of all entries. 65 | .Lf hash-table-count "'H_htable" 66 | .Re 67 | the number of entries in H_htable. Given a new hash table 68 | with no entries, this function returns zero. 69 | .Eb 70 | ; make a vanilla hash table using "eq" to compare items... 71 | \-> (setq black-box (makeht 20)) 72 | hash-table[26] 73 | \-> (hash-table-p black-box) 74 | t 75 | \-> (hash-table-count black-box) 76 | 0 77 | \-> (setf (gethash 'key black-box) '(the value associated with the key)) 78 | key 79 | \-> (gethash 'key black-box) 80 | (the value associated with the key) 81 | \-> (hash-table-count black-box) 82 | 1 83 | \-> (addhash 'composer black-box 'franz) 84 | composer 85 | \-> (gethash 'composer black-box) 86 | franz 87 | \-> (maphash '(lambda (key val) (msg "key " key " value " val N)) black-box) 88 | key composer value franz 89 | key key value (the value associated with the key) 90 | nil 91 | \-> (clrhash black-box) 92 | hash-table[26] 93 | \-> (hash-table-count black-box) 94 | 0 95 | \-> (maphash '(lambda (key val) (msg "key " key " value " val N)) black-box) 96 | nil 97 | 98 | ; here is an example using "equal" as the comparator 99 | \-> (setq ht (makeht 10 'equal)) 100 | hash-table[16] 101 | \-> (setf (gethash '(this is a key) ht) '(and this is the value)) 102 | (this is a key) 103 | \-> (gethash '(this is a key) ht) 104 | (and this is the value) 105 | ; the reader makes a new list each time you type it... 106 | \-> (setq x '(this is a key)) 107 | (this is a key) 108 | \-> (setq y '(this is a key)) 109 | (this is a key) 110 | ; so these two lists are really different lists that compare "equal" 111 | ; not "eq" 112 | \-> (eq x y) 113 | nil 114 | ; but since we are using "equal" to compare keys, we are OK... 115 | \-> (gethash x ht) 116 | (and this is the value) 117 | \-> (gethash y ht) 118 | (and this is the value) 119 | .Ee 120 | -------------------------------------------------------------------------------- /lispconf: -------------------------------------------------------------------------------- 1 | #! /bin/csh 2 | #$Header: lispconf,v 1.18 87/12/11 16:41:21 sklower Exp $ 3 | # 4 | # csh script to configure lisp 5 | # use: 6 | # lispconf type 7 | # where type is one of 8 | # vax_4_1 vax_4_1a vax_4_1c vax_eunice_vms 9 | # tahoe_4_3 10 | # sun_4_1c sun_unisoft dual_unisoft pixel_unisoft lisa_uniplus3 11 | # sun_4_2 sun_4_2beta mc500_2_0 12 | # 13 | if ($#argv == 1) then 14 | set argument = $argv[1] 15 | else 16 | set argument = junk 17 | endif 18 | 19 | #fix makefile 20 | sed "s%^RootDir = .*%RootDir = `pwd`%" Makefile > Make$$ 21 | mv Make$$ Makefile < /dev/null 22 | 23 | switch ($argument) 24 | case vax_eunice_vms: 25 | mv franz/vax/{Makefile,Make.unix} 26 | mv franz/vax/{Make.vms,Makefile} 27 | case vax_4_1: 28 | case vax_4_1a: 29 | case vax_4_1c: 30 | case vax_4_2: 31 | case vax_4_3: 32 | case sun_4_1c: 33 | case sun_4_2: 34 | case sun_4_2beta: 35 | case mc500_2_0: 36 | case tahoe_4_3: 37 | case sun_unisoft: 38 | case dual_unisoft: 39 | case pixel_unisoft: 40 | case lisa_unisys3: 41 | echo "/* this file created by ../../lispconf */" >! franz/h/lconf.h 42 | echo "#define $argv[1] 1" >>! franz/h/lconf.h 43 | rm -f franz/h/{aout,lispo}.h 44 | cp /usr/include/a.out.h franz/h/aout.h 45 | cp /usr/include/a.out.h franz/h/lispo.h 46 | breaksw 47 | default: 48 | echo "use: lispconf type" 49 | echo " where type is one of " 50 | echo " vax_4_1 vax_4_1a vax_4_1c vax_4_2 vax_4_3" 51 | echo " vax_eunice_vms tahoe_4_3" 52 | echo " sun_4_1c sun_unisoft dual_unisoft pixel_unisoft " 53 | echo " sun_4_2beta lisa_unisys3 mc500_2_0" 54 | exit 1 55 | endsw 56 | 57 | set ifusft="" 58 | set ifsys3="" 59 | switch ($argument) 60 | case vax_*: 61 | set VAX mach="vax" 62 | (echo vax ucbstd; cat Makefile) | awk -f cvt.awk > Make$$ 63 | mv Make$$ Makefile < /dev/null 64 | breaksw 65 | case tahoe_*: 66 | set TAHOE mach="tahoe" 67 | (echo tahoe ucbstd; cat Makefile) | awk -f cvt.awk >Make$$ 68 | mv Make$$ Makefile Make$$ 78 | mv Make$$ Makefile < /dev/null 79 | breaksw 80 | endsw 81 | 82 | # for the 68k version of the lisp compiler 83 | # The type of makefile built depends of the type of 68k 84 | # system you have. We assume that sun's and mc500's have virtual 85 | # memory and that dual/unisoft's have no vm (thus, define swapper). 86 | # As long as we are checking to see if we are dealing with 87 | # a 68000 unisoft machine; make some patches to the C part as well. 88 | set ifsunII="" 89 | if ($?M68K) then 90 | switch ($argument) 91 | case *_unisys3: 92 | case *_unisoft: 93 | (echo swapper unisoft;\ 94 | cat liszt/68k/Makefile) |awk -f cvt.awk > Make$$ 95 | (echo unisoft $ifsys3;\ 96 | cat franz/68k/Makefile) |awk -f cvt.awk > franz/68k/Make$$ 97 | rm -f franz/h/{lispo,aout}.h 98 | cp franz/h/duallispo.h franz/h/lispo.h 99 | cp franz/h/dualaout.h franz/h/aout.h 100 | cp franz/h/hpagsiz.h franz/h/pagsiz.h 101 | cp lisplib/autorun/unisoft lisplib/autorun/68k 102 | breaksw 103 | case sun_4_2beta: 104 | case sun_4_2: 105 | set ifsunII=sunII 106 | case sun_4_1c: 107 | (echo sun; cat liszt/68k/Makefile) | awk -f cvt.awk > Make$$ 108 | (echo sun $ifsunII; cat franz/68k/Makefile)\ 109 | | awk -f cvt.awk > franz/68k/Make$$ 110 | cp lisplib/autorun/sun4.2 lisplib/autorun/68k 111 | breaksw 112 | case mc500_2_*: 113 | (echo mc500; cat liszt/68k/Makefile) | awk -f cvt.awk > Make$$ 114 | (echo mc500; cat franz/68k/Makefile)\ 115 | | awk -f cvt.awk > franz/68k/Make$$ 116 | cp lisplib/autorun/mc500 lisplib/autorun/68k 117 | breaksw 118 | endsw 119 | rm -f liszt/68k/Makefile 120 | sed "s%^RootDir = .*%RootDir = `pwd`%" Make$$ > liszt/68k/Makefile 121 | rm -f Make$$ 122 | rm -f franz/68k/Makefile 123 | mv franz/68k/Make$$ franz/68k/Makefile 124 | 125 | if ($ifusft/x == unisoft/x) then 126 | switch ($argument) 127 | case sun_unisoft: 128 | set OFFSET=0x40000 129 | breaksw 130 | case dual_unisoft: 131 | set OFFSET=0x800000 132 | breaksw 133 | case pixel_unisoft: 134 | case lisa_unisys3: 135 | set OFFSET=0x20000 136 | breaksw 137 | endsw 138 | sed "s%^OFFSET = .*%OFFSET = $OFFSET%"\ 139 | lisplib/autorun/68k > temp$$ 140 | mv temp$$ lisplib/autorun/68k