;;;;;;;;;;;;;;;;;;;;;;;;;;;; franz.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Franz-dependent PEARL functions, declarations, and initializations
; that don't use PEARL functions.
; Functions to make Franz accept UCI Lisp functions are in ucisubset.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 , The Regents of the University of California.
; Authors: Joseph Faletti and Michael Deering.
; Version numbers, major and minor.
(defvar pearlmajorversion 3)
(defvar pearlminorversion 9)
;3.1: Use of lets and other speedups and new slot encoding.
;3.2: Slot encoding applied to speeded-up match.
;3.3: New faster hashing.
;3.4: Type tags added to symbols, instances, definitions and databases.
;3.5: New print functions.
;3.6: Made hooks additive and fixed global variables in failed matches.
;3.7: Minor bug fixes in scopy and hooks.
;3.8: Unification added; minor bug fixes in setv and create.
;3.9: Bug fixes in blocks and freezing; selectq becomes selectq*.
(declare (*fexpr builddb))
(defvar *pearlinactivedb*)
(defvar *availablesizes* '((-1. . 1.) (0. . 1.) (1. . 1.) (2. . 3.)
(3. . 7.) (4. . 13.) (5. . 29.) (6. . 61.)
(7. . 127.) (8. . 127.) (9. . 127.)
(10. . 127.) (11. . 127.)
(12. . 127.) (13. . 127.)))
; For UCI Lisp or Franz (7. . 127.) (8. . 251.) (9. . 509.)
; with vectors (soon?). (10. . 1021.) (11. . 2039.)
; (12. . 4093.) (13. . 8191.)))
(defvar *activedbnames* nil)
(declare (*fexpr varvalue setv *var* *global* global unbind))
(declare (*fexpr block endblock endanyblocks setblock))
(defvar *runallslothooks* t)
(defvar *runallbasehooks* t)
(defvar *runputpathhooks* t)
(defvar *runclearpathhooks* t)
(defvar *runaddsetpathhooks* t)
(defvar *rundelsetpathhooks* t)
(defvar *runaddpredpathhooks* t)
(defvar *rundelpredpathhooks* t)
(defvar *rungetpathhooks* t)
(defvar *rungetpredpathhooks* t)
(defvar *rungethookpathhooks* t)
(defvar *runapplypathhooks* t)
(defvar *runmatchhooks* t)
(defvar *runsmergehooks* t)
(defvar *runindividualhooks* t)
(defvar *runexpandedhooks* t)
(defvar *runpatternhooks* t)
(defvar *runnextitemhooks* t)
(defvar *runfetchhooks* t)
(defvar *runinsertdbhooks* t)
(defvar *runremovedbhooks* t)
(defvar *runindbhooks* t)
(defvar *runnextequalhooks* t)
(defvar *runstrequalhooks* t)
; symord and create and scopy (and all):
(declare (*fexpr pearlbreak symbol ordinal create cr insidecreate))
(defvar *currenttopcreated*)
(defvar *currenttopalists*)
(defvar *currenttopcopy*)
(defvar *currentcreatetype*)
(defvar *ordinalnames* nil)
(defvar *globallist* nil)
; So that unique numbers start at 0.
(defvar *lastsymbolnum* -1)
(defvar *unhashablevalues*)
(defvar *blockstack* nil)
(defvar *zero-ordinal-value* 0)
(defvar *currentpearlstructure* nil)
(defvar *currentstructure* nil)
(declare (*fexpr foreach quiet))
(defvar *abbrevprint* nil)
(defvar *uniqueprint* nil)
(defvar *uniqueprintlist* nil)
(defvar *streamprintlength* 2)
(defvar pearltraceprintfn)
(defvar pearlshowstackprintfn)
(defvar pearlbreakprintfn)
(defvar pearltracebreakprintfn)
(setq trace-printer 'pearltraceprintfn)
(defvar showstack-printer)
(setq showstack-printer 'pearlshowstackprintfn)
(setq top-level-print 'pearltracebreakprintfn)
; if t, then enters and exits to tracing are quiet,
; but info is still kept so (tracedump) will work
(defvar *function-stream:*)
(defvar *slotvalues* (makhunk 64))
(defvar *hashingmarks* (makhunk 64))
(defvar *multiproducts* '(16. 256. 4096. 65536. 1048576. 16777216.
268435456. 42944967296.))
(defvar *matchunboundsresult* nil)
(defvar *globalsavestack* nil)
(defvar *equivsavestack* nil)
(defvar *unifyunbounds* nil)
(defvar *historynumber* -1.)
(defvar *historysize* 64.)
(defvar *history* (makhunk *historysize*))
(defvar *histval* (makhunk *historysize*))
(defvar *printhistorynumber* nil)
(defvar *readlinechanged*)
(defvar *firststartup* t)
(defvar *pearlprompt* '|pearl> |)
(declare (*fexpr savepearl))
; Franz: PEARL-top-level:
(defvar pearl-title (concat " plus PEARL "
(defvar franz-not-virgin)
(defvar pearl-top-level-init)
(defvar franz-minor-version-number)
; PEARL-break-err-handler or trace or fixit debugger:
(defvar break-level-count)
(defvar debug-level-count)
; (funl (x...) body) expands to (function (lambda (x...) body)).
(defmacro funl (&rest rest)
`(function (lambda .,rest)))
; Various Lisps store functions different ways. Check for
; lambda-ness (expr-ness).
(and (neq 'binary (type fcn))
(or (and (eq 'binary (type fcn))
(eq 'lambda (getdisc fcn)))
(eq 'lambda (car fcn)))))
; Tests for an actual literal atom rather than nil!!
(defmacro reallitatom (potatom)
; To avoid problems with UCI Lisp's unbound, we use a special value
; for PEARL (pattern-matching) variables to indicate unboundness.
(defmacro punboundatomp (yyy)
;(aliasdef 'To 'From 'Property) means define To to be the same as From
; (under Property in UCILisp). HOWEVER, in Franz it means copy the
; function definition of To to From and ignore Property.
(defmacro aliasdef (to from property)
`(putd ,to (getd ,from)))