![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to franz.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl|
Return to franz.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl |
1.1 ! root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;; franz.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ! 2: ; Franz-dependent PEARL functions, declarations, and initializations ! 3: ; that don't use PEARL functions. ! 4: ; Functions to make Franz accept UCI Lisp functions are in ucisubset.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: ; Version numbers, major and minor. ! 11: (defvar pearlmajorversion 3) ! 12: (defvar pearlminorversion 9) ! 13: ;3.1: Use of lets and other speedups and new slot encoding. ! 14: ;3.2: Slot encoding applied to speeded-up match. ! 15: ;3.3: New faster hashing. ! 16: ;3.4: Type tags added to symbols, instances, definitions and databases. ! 17: ;3.5: New print functions. ! 18: ;3.6: Made hooks additive and fixed global variables in failed matches. ! 19: ;3.7: Minor bug fixes in scopy and hooks. ! 20: ;3.8: Unification added; minor bug fixes in setv and create. ! 21: ;3.9: Bug fixes in blocks and freezing; selectq becomes selectq*. ! 22: ! 23: ; db: ! 24: (declare (*fexpr builddb)) ! 25: (defvar *pearldb*) ! 26: (defvar *pearlinactivedb*) ! 27: (defvar db) ! 28: (defvar *db1size*) ! 29: (defvar *db2size*) ! 30: ! 31: (defvar *availablesizes* '((-1. . 1.) (0. . 1.) (1. . 1.) (2. . 3.) ! 32: (3. . 7.) (4. . 13.) (5. . 29.) (6. . 61.) ! 33: (7. . 127.) (8. . 127.) (9. . 127.) ! 34: (10. . 127.) (11. . 127.) ! 35: (12. . 127.) (13. . 127.))) ! 36: ;(( ! 37: ; For UCI Lisp or Franz (7. . 127.) (8. . 251.) (9. . 509.) ! 38: ; with vectors (soon?). (10. . 1021.) (11. . 2039.) ! 39: ; (12. . 4093.) (13. . 8191.))) ! 40: ; (setq buildpplst nil) ! 41: ! 42: (defvar *maindb*) ! 43: (defvar *db*) ! 44: (defvar *activedbnames* nil) ! 45: ! 46: ; vars: ! 47: (declare (*fexpr varvalue setv *var* *global* global unbind)) ! 48: (declare (*fexpr block endblock endanyblocks setblock)) ! 49: ! 50: ; hook: ! 51: (defvar *runallslothooks* t) ! 52: (defvar *runallbasehooks* t) ! 53: ! 54: (defvar *runputpathhooks* t) ! 55: (defvar *runclearpathhooks* t) ! 56: (defvar *runaddsetpathhooks* t) ! 57: (defvar *rundelsetpathhooks* t) ! 58: (defvar *runaddpredpathhooks* t) ! 59: (defvar *rundelpredpathhooks* t) ! 60: (defvar *rungetpathhooks* t) ! 61: (defvar *rungetpredpathhooks* t) ! 62: (defvar *rungethookpathhooks* t) ! 63: (defvar *runapplypathhooks* t) ! 64: ! 65: (defvar *runmatchhooks* t) ! 66: (defvar *runsmergehooks* t) ! 67: (defvar *runindividualhooks* t) ! 68: (defvar *runexpandedhooks* t) ! 69: (defvar *runpatternhooks* t) ! 70: (defvar *runnextitemhooks* t) ! 71: (defvar *runfetchhooks* t) ! 72: (defvar *runinsertdbhooks* t) ! 73: (defvar *runremovedbhooks* t) ! 74: (defvar *runindbhooks* t) ! 75: (defvar *runnextequalhooks* t) ! 76: (defvar *runstrequalhooks* t) ! 77: ! 78: ; symord and create and scopy (and all): ! 79: (defvar *pearlunbound*) ! 80: (defvar *equivclass*) ! 81: (defvar *invisible*) ! 82: (defvar *warn* t) ! 83: ! 84: (defvar *pearlsymbol*) ! 85: (defvar *pearldef*) ! 86: (defvar *pearlinst*) ! 87: ! 88: (declare (*fexpr pearlbreak symbol ordinal create cr insidecreate)) ! 89: (defvar nilstruct) ! 90: (defvar d:nilstruct) ! 91: (defvar i:nilstruct) ! 92: (defvar s:nilsym) ! 93: (defvar *lastcreated*) ! 94: (defvar *toplevelp*) ! 95: (defvar *currenttopcreated*) ! 96: (defvar *currenttopalists*) ! 97: (defvar *currenttopcopy*) ! 98: (defvar *currentcreatetype*) ! 99: (defvar *ordinalnames* nil) ! 100: (defvar *globallist* nil) ! 101: ; So that unique numbers start at 0. ! 102: (defvar *lastsymbolnum* -1) ! 103: (defvar *unhashablevalues*) ! 104: (defvar *any*conscell*) ! 105: (defvar *blockstack* nil) ! 106: (defvar *zero-ordinal-value* 0) ! 107: (defvar *currentpearlstructure* nil) ! 108: (defvar *currentstructure* nil) ! 109: (defvar *scopieditems*) ! 110: ! 111: ; path: ! 112: (defvar *pathtop*) ! 113: (defvar *pathlocal*) ! 114: ! 115: ; print: ! 116: (declare (*fexpr foreach quiet)) ! 117: (defvar *fullprint* nil) ! 118: (defvar *abbrevprint* nil) ! 119: (defvar *uniqueprint* nil) ! 120: (defvar *uniqueprintlist* nil) ! 121: (defvar *streamprintlength* 2) ! 122: (defvar *quiet* nil) ! 123: (defvar prinlevel) ! 124: (setq prinlevel 7) ! 125: (defvar printvar) ! 126: (defvar pearltraceprintfn) ! 127: (defvar pearlshowstackprintfn) ! 128: (defvar pearlbreakprintfn) ! 129: (defvar pearlfixprintfn) ! 130: (defvar msgprintfn) ! 131: (defvar pearltracebreakprintfn) ! 132: (defvar pearlprintfn) ! 133: (defvar dskprintfn) ! 134: (defvar trace-printer) ! 135: (setq trace-printer 'pearltraceprintfn) ! 136: (defvar showstack-printer) ! 137: (setq showstack-printer 'pearlshowstackprintfn) ! 138: (defvar top-level-print) ! 139: (setq top-level-print 'pearltracebreakprintfn) ! 140: ! 141: ; if t, then enters and exits to tracing are quiet, ! 142: ; but info is still kept so (tracedump) will work ! 143: (defvar \$tracemute) ! 144: ! 145: ; hash: ! 146: (defvar *stream*) ! 147: (defvar *stream:*) ! 148: (defvar *function-stream:*) ! 149: (defvar *slotvalues* (makhunk 64)) ! 150: (defvar *hashingmarks* (makhunk 64)) ! 151: ; (and via lowlevel.l): ! 152: (defvar *multiproducts* '(16. 256. 4096. 65536. 1048576. 16777216. ! 153: 268435456. 42944967296.)) ! 154: ! 155: ; match: ! 156: (defvar *matchunboundsresult* nil) ! 157: (defvar *globalsavestack* nil) ! 158: (defvar *equivsavestack* nil) ! 159: (defvar *unifyunbounds* nil) ! 160: (defvar xvar) ! 161: (defvar yvar) ! 162: ! 163: ; history: ! 164: (defvar *historynumber* -1.) ! 165: (defvar *historysize* 64.) ! 166: (defvar *usealiases* t) ! 167: (defvar *history* (makhunk *historysize*)) ! 168: (defvar *histval* (makhunk *historysize*)) ! 169: (defvar *printhistorynumber* nil) ! 170: (defvar *readlinechanged*) ! 171: ! 172: ; PEARL-top-level: ! 173: (defvar *firststartup* t) ! 174: (defvar *pearlprompt* '|pearl> |) ! 175: (declare (*fexpr savepearl)) ! 176: ! 177: ; Franz: PEARL-top-level: ! 178: (defvar pearl-title (concat " plus PEARL " ! 179: pearlmajorversion "." ! 180: pearlminorversion)) ! 181: (defvar franz-not-virgin) ! 182: (defvar pearl-top-level-init) ! 183: (defvar top-level) ! 184: (defvar franz-minor-version-number) ! 185: (defvar franz-top-level) ! 186: (defvar +) ! 187: (defvar ++) ! 188: (defvar +++) ! 189: (defvar *) ! 190: (defvar **) ! 191: (defvar ***) ! 192: (defvar ER%tpl) ! 193: (defvar ER%brk) ! 194: (defvar ER%err) ! 195: (defvar evalhook) ! 196: (defvar \$gcprint) ! 197: (defvar funcallhook) ! 198: (defvar tpl-errlist) ! 199: (defvar user-top-level) ! 200: (defvar top-level-eof) ! 201: ! 202: ; PEARL-break-err-handler or trace or fixit debugger: ! 203: (defvar break-level-count) ! 204: (defvar debug-level-count) ! 205: (defvar errlist) ! 206: ! 207: ; (funl (x...) body) expands to (function (lambda (x...) body)). ! 208: (defmacro funl (&rest rest) ! 209: `(function (lambda .,rest))) ! 210: ! 211: ; Various Lisps store functions different ways. Check for ! 212: ; lambda-ness (expr-ness). ! 213: (de islambda (fcn) ! 214: (and (neq 'binary (type fcn)) ! 215: (setq fcn (getd fcn))) ! 216: (or (and (eq 'binary (type fcn)) ! 217: (eq 'lambda (getdisc fcn))) ! 218: (and (dtpr fcn) ! 219: (eq 'lambda (car fcn))))) ! 220: ! 221: ; Tests for an actual literal atom rather than nil!! ! 222: (defmacro reallitatom (potatom) ! 223: `(let ((pot ,potatom)) ! 224: (and (symbolp pot) ! 225: pot))) ! 226: ! 227: ; To avoid problems with UCI Lisp's unbound, we use a special value ! 228: ; for PEARL (pattern-matching) variables to indicate unboundness. ! 229: (dm punbound (none) ! 230: ''*pearlunbound*) ! 231: ! 232: (defmacro pboundp (a) ! 233: `(neq ,a (punbound))) ! 234: ! 235: (defmacro punboundatomp (yyy) ! 236: `(eq ,yyy (punbound))) ! 237: ! 238: ;(aliasdef 'To 'From 'Property) means define To to be the same as From ! 239: ; (under Property in UCILisp). HOWEVER, in Franz it means copy the ! 240: ; function definition of To to From and ignore Property. ! 241: (defmacro aliasdef (to from property) ! 242: `(putd ,to (getd ,from))) ! 243: ! 244: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.