![[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] / 42BSD / ucb / lisp / pearl|
Return to franz.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / 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.