[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: errors compiling pcl under Symbolics 7.1
- To: commonloops.pa@Xerox.COM, victoria.media.mit.edu@VICTORIA.MEDIA.MIT.EDU
- Subject: Re: errors compiling pcl under Symbolics 7.1
- From: klapper@antiphos.UUCP
- Date: Thu, 6 Oct 88 10:59:59 EDT
- Cc: hook%antiphos@cu-arpa.cs.cornell.edu, klapper%antiphos@cu-arpa.cs.cornell.edu
- Redistributed: commonloops.pa
You should incorporate some patches for Genera 7.2 that
Mike Thome submitted to this mailing list a couple of weeks ago.
In particular, his load-defmethod and load-defmethod-internal
patches fix the definition of methods for setf's.
Allow me to take this opportunity to present the changes
which allowed us to get PCL up and running on the Symbolics under
Genera 7.1. This may be incomplete, since several patches from this
mailing list may have been installed before I got my hands on it.
I have presented top-level forms in their entirety rather than
incremental directions so that all changes to that form, both known
and unknown, are reflected.
------------------------Start of changes----------------------------
;;; Changes to PCL for 7.1 which allowed our stuff to work
;;; Changes to 3600-low
;;; Comments removed (Thome's patch)
(defun record-definition (type spec &rest args)
(declare (ignore args))
(case type
(method (if (listp (cadr spec))
(si:record-source-file-name spec 'method)
(si:record-source-file-name spec 'method)))
(class (si:record-source-file-name spec 'defclass)
(si:record-source-file-name spec 'deftype)
)))
;;; eq -> equal (Thome's patch)
(defvar *method-fdefs* (make-hash-table :test #'equal :size 500))
(defvar *method-setf-fdefs* (make-hash-table :test #'equal :size 500))
;;; Added (fboundp 'generic-function-p) before it is called.
;;; Fails miserably without it
(defun setup-function-specs-to-edit-advice-1 (spec)
(and (or (symbolp spec)
(and (listp spec) (eq (car spec) 'setf)))
(gboundp spec)
(fboundp 'generic-function-p)
(generic-function-p (gdefinition spec))
(mapcar #'(lambda (m)
(make-method-spec spec
(method-qualifiers m)
(unparse-specializers
(method-type-specifiers m))))
(generic-function-methods (gdefinition spec)))))
;;; Changes to 7debug
;;; Note: I changed defsys.lisp so that 7debug would be loaded for 7.1
;;; (member fspec *uninteresting-functions*) -> (gethash fspec
*uninteresting-functions*)
;;; *uninteresting-functions* is a list in 7.1 (at least for us).
(defun frame-interesting-p (frame
&optional (censor-invisible-frames *censor-invisible-frames*))
(labels ((uninternalize-fspec (fspec)
;; Internal functions of uninteresting functions are uninteresting
(if (and (listp fspec) (eq (first fspec) :internal))
(if (and (or (eq (fourth fspec)
'si:with-process-interactive-priority-body)
(eq (fourth fspec)
'si:with-process-non-interactive-priority-body))
(not (memq :process-priority *invisible-frame-types-to-show*)))
;; These things aren't interesting
(return-from frame-interesting-p nil)
(uninternalize-fspec (second fspec)))
fspec)))
(if (and censor-invisible-frames
(frame-invisible-p frame))
nil
(let* ((function (frame-function frame))
(fspec (uninternalize-fspec (function-name-for-debugger frame))))
(and (neq fspec function) ;Not an unnamed LAMBDA expression
(not (member fspec *uninteresting-functions*))
(not (member fspec si:*digested-special-forms*)))))))
;;; Housecleaning: removed show-all-compiled-7-1 & show-all-compiled-7-2,
using #+ and #- instead
#-genera-Release-7-2
(defun show-all-compiled (&optional show-source-file-p)
(let* ((*printing-monitor-message* t)
(frame *current-frame*)
(function (frame-function frame)))
(format t "~V~S~" *emphasis-character-style*
(function-name-for-debugger frame))
(when show-source-file-p
(print-function-source-file function))
(format t "~2%")
;; Print the arguments, including the rest-arg which is a local
(let ((local-start (print-frame-args *current-frame* 1 t)))
(cond ((frame-active-p *current-frame*)
;; Print the rest of the locals, if the frame is active
(print-frame-locals *current-frame* local-start 1)
(format t "~%~VDisassembled code:~" *deemphasis-character-style*)
(show-all-compiled-1 frame function)
;; This kludge is to prevent the prompt from triggering a **MORE**
;; when it comes out on the bottom line of the window
(if (memq :notice (send standard-output :which-operations))
(send standard-output :notice :input-wait)))))))
#+genera-Release-7-2
(defun show-all-compiled (&optional show-source-file-p)
(let* ((*printing-monitor-message* t)
(frame *current-frame*)
(function (frame-function frame)))
(format t "~V~S~" *emphasis-character-style*
(FUNCTION-NAME-FOR-DEBUGGER FRAME))
;; KRA: (lframe-function-name *current-language* function nil))
(when show-source-file-p
(print-function-source-file function))
(format t "~2%")
;; Print the arguments, including the rest-arg which is a local
(let ((local-start (print-frame-args *current-frame* 1 t)))
(cond ((frame-active-p frame)
;; Print the rest of the locals, if the frame is active
(print-frame-locals frame local-start 1)
(lframe-show-code-for-function *current-language* frame function
(lframe-show-source-code-p *current-language*)
:brief nil)
;; This kludge is to prevent the prompt from triggering a **MORE**
;; when it comes out on the bottom line of the window
(when (memq :notice (send standard-output :which-operations))
(send standard-output :notice :input-wait))))))
;;; Changes to boot
;;; Fixes function-spec for methods once load-defmethod-internal
;;; returns a useful value (Thome's patch)
(defun load-defmethod
(class name quals specls ll doc isl-cache-symbol plist fn)
(let ((method-spec (make-method-spec name quals specls)))
(record-definition 'method method-spec)
(setq fn (set-function-name fn method-spec))
(let ((method
(load-defmethod-internal
name quals specls ll doc isl-cache-symbol plist fn class)))
#+Genera
(when method ; patched... MT 880829
(scl:fdefine method-spec fn))
method-spec)))
(defun load-defmethod-internal
(gf-spec qualifiers specializers
lambda-list doc isl-cache-symbol plist fn method-class)
(when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
(when plist
(setq plist (copy-list plist)) ;Do this to keep from affecting
;the plist that is about to be
;dumped when we are compiling.
(let ((uisl (getf plist :isl))
(isl nil))
(when uisl
(setq isl (intern-slot-lists uisl))
(setf (getf plist :isl) isl))
(when isl-cache-symbol
(setf (getf plist :isl-cache-symbol) isl-cache-symbol)
(set isl-cache-symbol isl)))
(setf (method-function-plist fn) plist))
(let ((method (add-named-method
gf-spec qualifiers specializers lambda-list fn
:documentation doc)))
(unless (or (eq method-class 'standard-method)
(eq (find-class method-class nil) (class-of method)))
(format *error-output*
"At the time the method with qualifiers ~:~S and~%~
specializers ~:S on the generic function ~S~%~
was compiled, the method-class for that generic function
was~%~
~S. But, the method class is now ~S, this~%~
may mean that this method was compiled improperly."
qualifiers specializers gf-spec
method-class (class-name (class-of method))))
method ; return a useful value (MT)
))
;;; Housecleaning: added generic-function-class to the ignore declaration
(defun ensure-generic-function (spec &rest keys
&key lambda-list
argument-precedence-order
declarations
documentation
method-combination
generic-function-class
method-class)
(declare (ignore lambda-list argument-precedence-order declarations
documentation method-combination generic-function-class method-class))
(let ((existing (and (gboundp spec)
(gdefinition spec))))
(cond ((null existing)
(let ((new (apply #'ensure-gf-internal spec keys)))
(setq new (set-function-name new spec))
(setf (gdefinition spec) new)))
((funcallable-instance-p existing) existing)
(existing
#+Lispm
(zl:signal 'generic-clobbers-function :name spec)
#-Lispm
(error "~S already names an ordinary function or a macro,~%~
it can't be converted to a generic function."
spec)))))
;;; Changes to defs
;;; Commented out class-options as an argument to do-standard-defsetfs
(do-standard-defsetfs method-function-plist
method-function-get
get-setf-function
gdefinition
; class-options ;also above
class-instance-slots
slotd-name
slot-value--std
slot-value--fsc
slot-value-using-class
)
;;; Changes to defsys
;;; made 7debug part of 7.1 and 7.2 systems
(defsystem pcl
*pcl-directory*
;; file load compile files which port
;; environment environment force the of
;; recompilation
;; of this file
((rel-6-patches t t () rel-6)
(rel-7-1-patches t t ()
rel-7-1)
(rel-7-2-patches t t ()
rel-7-2)
(ti-patches t t () ti)
(pyr-patches t t ()
pyramid)
(xerox-patches t t () xerox)
(kcl-patches t t () kcl)
(pkg t t ())
(walk (pkg) (pkg) ())
(iterate t t ())
(macros t t ())
(low (pkg macros) t (macros))
(3600-low (low) (low) (low) Genera)
(lucid-low (low) (low) (low) Lucid)
(Xerox-low (low) (low) (low) Xerox)
(ti-low (low) (low) (low) TI)
(vaxl-low (low) (low) (low) vaxlisp)
(kcl-low (low) (low) (low) KCL)
(excl-low (low) (low) (low) excl)
(cmu-low (low) (low) (low) CMU)
(hp-low (low) (low) (low) HP)
(gold-low (low) (low) (low) gclisp)
(pyr-low (low) (low) (low) pyramid)
(coral-low (low) (low) (low) coral)
(fin t t (low))
(defs t t (macros iterate))
(boot t t (defs fin))
(vector t t (boot defs fin))
(slots t t (boot defs low fin))
(mki t t (boot defs low fin))
(init t t (boot defs low fin))
(defclass t t (boot defs low fin
slots))
(std-class t t (boot defs low fin
slots))
(braid1 t t (boot defs low fin))
(fsc t t (slots boot defs low
fin))
(methods t t (boot defs low fin
slots))
(combin t t (boot defs low fin))
(dcode t t (defs low vector fin
slots))
(dcode-pre1 t t (defs low fin vector
slots dcode))
(fixup t t (boot defs low fin))
(high t t (boot defs low fin))
(compat t t ())
(7debug t t ()
#+Genera-Release-7-1 rel-7-1
#+Genera-Release-7-2 rel-7-2
#-Genera-Release-7 rel-7)
))
;;; Changes to fin
;;; More from Thome's patch
;;; put into #+Genera section
(proclaim '(inline applyable-thing-p))
(defun applyable-thing-p (thing)
(or (functionp thing) (and (consp thing) (eq (car thing)
'si:digested-lambda))))
(defun set-funcallable-instance-function (fin new-value)
(cond ((not (funcallable-instance-p fin))
(error "~S is not a funcallable-instance" fin))
((not (applyable-thing-p new-value))
(error "~S is not a function." new-value))
((and (si:lexical-closure-p new-value)
(compiled-function-p (si:lexical-closure-function new-value)))
(let* ((fin-env (si:lexical-closure-environment fin))
(new-env (si:lexical-closure-environment new-value))
(new-env-size (zl:length new-env))
(fin-env-size (- funcallable-instance-closure-size
(length funcallable-instance-data))))
(cond ((<= new-env-size fin-env-size)
(dotimes (i fin-env-size)
(setf (sys:%p-contents-offset fin-env i)
(and (< i new-env-size)
(sys:%p-contents-offset new-env i))))
(setf (si:lexical-closure-function fin)
(si:lexical-closure-function new-value)))
(t
(set-funcallable-instance-function
fin
(make-trampoline new-value))))))
(t
(set-funcallable-instance-function fin
(make-trampoline new-value)))))
;;; Changes to iterate
;;; (return-from ,block-name) -> (return-from ,block-name (values))
(defun optimize-iterate-form (type clauses body iterate-env)
(let*
((temp-vars *iterate-temp-vars-list*)
(block-name (gensym))
(finish-form `(return-from ,block-name (values)))
(bound-vars (mapcan #'(lambda (clause)
(let ((names (first clause)))
(if (listp names)
(copy-list names)
(list names))))
clauses))
iterate-decls generator-decls update-forms bindings final-bindings
leftover-body)
(do ((tail bound-vars (cdr tail)))
((null tail)) ; check for duplicates
(when (member (car tail)
(cdr tail))
(warn "variable appears more than once in iterate: ~s" (car
tail))))
(flet
((get-iterate-temp nil ; make temporary var. note
; that it is ok to re-use
these
; symbols in each iterate,
; because they are not used
; within body.
(or (pop temp-vars)
(gensym))))
(dolist (clause clauses)
(cond
((or (not (consp clause))
(not (consp (cdr clause))))
(warn
"bad syntax in iterate: clause not of form (var iterator):
~s"
clause))
(t
(unless (null (cddr clause))
(warn
"probable parenthesis error in iterate clause--more than 2 elements:
~s"
clause))
(multiple-value-bind
(let-body binding-type let-bindings localdecls otherdecls
extra-body)
(expand-into-let (second clause)
type iterate-env)
;; we have expanded the generator clause and parsed it into
its
;; let pieces.
(prog* ((vars (first clause))
gen-args renamed-vars)
(#+Genera-Release-7-1 block #+Genera-Release-7-1 punt1
#-Genera-Release-7-1 progn
(setq vars (if (listp vars)
(copy-list vars)
(list vars)))
; vars is now a (fresh) list
of
; all iteration vars bound
in
; this clause
(when (setq let-body (function-lambda-p let-body 1))
;; we have something of the form #'(lambda
;; (finisharg) ...), possibly with some let
bindings
;; around it.
(setq let-body (cdr let-body))
(setq gen-args (pop let-body))
(when let-bindings
;; the first transformation we want to perform is
;; "let-eversion": turn (let* ((generator (let
;; (..bindings..) #'(lambda ...)))) ..body..)
into
;; (let* (..bindings.. (generator #'(lambda
...)))
;; ..body..). this transformation is valid if
;; nothing in body refers to any of the bindings,
;; something we can assure by alpha-converting
the
;; inner let (substituting new names for each
var).
;; of course, none of those vars can be special,
but
;; we already checked for that above.
(multiple-value-setq (let-bindings
renamed-vars)
(rename-let-bindings let-bindings
binding-type iterate-env
leftover-body
#'get-iterate-temp))
(setq leftover-body nil)
; if there was any leftover
; from previous, it is now
; consumed
)
(let
((finish-arg (first gen-args)))
;; the second transformation is substituting the
;; body of the generator (lambda (finish-arg) .
;; gen-body) for its appearance in the update
form
;; (funcall generator #'(lambda () finish-form)),
;; then simplifying that form. the requirement
for
;; this part is that the generator body not refer
to
;; any variables that are bound between the
;; generator binding and the appearance in the
loop
;; body. the only variables bound in that
interval
;; are generator temporaries, which have unique
;; names so are no problem, and the iteration
;; variables themselves: all of them in the case
of
;; iterate, only the remaining ones in the case
of
;; iterate*. we'll discover the story as we walk
;; the body.
(multiple-value-bind
(finishdecl other rest)
(parse-declarations let-body gen-args)
(declare (ignore finishdecl))
; pull out declares, if any,
; separating out the one(s)
; referring to the finish
arg,
; which we will throw away
(when other ; combine remaining decls
with
; decls extracted from the
let,
; if any
(setq otherdecls (nconc otherdecls other)))
(setq
let-body
(cond
(otherdecls ; there are interesting
; declarations, so have to
keep
; it wrapped.
`(let nil (declare ,@otherdecls)
,@rest))
((null (cdr rest))
; only one form left
(first rest)))))
(setq
let-body
(walk-form
let-body iterate-env
#'(lambda (form context env)
(declare (ignore context))
;; need to substitute renamed-vars, as well
as
;; turn (funcall finish-arg) into the
finish
;; form
(cond
((symbolp form)
(let (renaming)
(cond
((and (eq form finish-arg)
(variable-same-p
form
env
iterate-env))
; an occurrence of the
finish
; arg outside of funcall
; context--i can't handle
this
(maybe-warn :definition
"couldn't optimize ~s because generator ~s does something with its finish
arg besides funcall it."
type (second
clause))
#-Genera-Release-7-1
(go punt)
#+Genera-Release-7-1
(return-from punt1 nil)
)
((and (setq renaming
(assoc form
renamed-vars
))
(variable-same-p
form
env
iterate-env))
; reference to one of the
vars
; we're renaming
(cdr renaming))
((and (member form
bound-vars)
(variable-same-p
form
env
iterate-env))
; form is a var that is
bound
; in this same iterate, or
; bound later in this
iterate*.
; this is a conflict.
(maybe-warn
:user "couldn't optimize
~s because generator ~s is closed over ~s, in conflict with another
iteration variable.~@[ you may have meant to use iterate*~]"
type (second clause)
form
(eq type 'iterate))
#-Genera-Release-7-1
(go punt)
#+Genera-Release-7-1
(return-from punt1 nil)
)
(t form))))
((and (consp form)
(eq (first form)
'funcall)
(eq (second form)
finish-arg)
(variable-same-p (second
form)
env iterate-env))
; (funcall finish-arg) =>
; finish-form
(unless (null (cddr form))
(maybe-warn :definition
"generator for ~s applied its finish arg to > 0 arguments
~s--ignored."
(second clause)
(cddr form)))
finish-form)
(t form)))))
;; gen-body is now a form which, when evaluated,
;; returns updated values for the iteration
;; variable(s)
(push (mv-setq (copy-list vars)
let-body)
update-forms)
;; note possible further optimization: if the
above
;; expanded into (setq var (prog1 oldvalue
;; prepare-for-next-iteration)), as so many do,
then
;; we could in most cases split the prog1 into
two
;; pieces: do the (setq var oldvalue) here, and
do
;; the prepare-for-next-iteration at the bottom
of
;; the loop. this does a slight optimization of
the
;; prog1 and also rearranges the code in a way
that
;; a reasonably clever compiler might detect how
to
;; get rid of redundant variables altogether
(such
;; as happens with interval and list-tails); that
;; would make the whole thing closer to what you
;; might have coded by hand. however, to do this
;; optimization, we need to assure that (a) the
;; prepare-for-next-iteration refers freely to no
;; vars other than the internal vars we have
;; extracted from the let, and (b) that the code
has
;; no side effects. these are both true for all
the
;; iterators defined by this module, but how
shall
;; we represent side-effect info and/or tap into
the
;; compiler's knowledge of same?
(when localdecls ; there were declarations
for
; the generator locals--have
to
; keep them for later, and
; rename the vars mentioned
(setq
generator-decls
(nconc
generator-decls
(mapcar
#'(lambda
(decl)
(let
((head (car decl)))
(cons head
(if (eq head 'type)
(cons (second decl)
(sublis renamed-vars
(cddr decl)))
(sublis renamed-vars
(cdr decl))))))
localdecls))))
(go finish-clause)))
(maybe-warn :definition "could not optimize ~s clause
~s because generator not of form (let[*] ... (function (lambda (finish)
...)))"
type (second clause))
);end of block punt1 or progn
#-Genera-Release-7-1
punt
(let
((gvar (get-iterate-temp))
(generator (second clause)))
;; for some reason, we can't expand this guy, so go
with
;; the formal semantics: bind a var to the generator,
;; then call it in the update section
(setq
let-bindings
(list
(list gvar
(cond
(leftover-body; have to use this up
`(progn ,@(prog1 leftover-body
(setq leftover-body
nil))
generator))
(t generator)))))
(push (mv-setq (copy-list vars)
`(funcall ,gvar #'(lambda nil
,finish-form))
)
update-forms))
finish-clause
(case type
(iterate ; for iterate, don't bind
any
; iv's until all exprs are
; evaluated, so defer this
(setq final-bindings (nconc final-bindings
vars))
(setq vars nil)
(when extra-body ; have to save this for next
; clause, too
(setq leftover-body (nconc leftover-body
extra-body))
(setq extra-body nil)))
(iterate* ; pop off the vars we have
now
; bound from the list of
vars
; to watch out for--we'll
bind
; them right now
(dolist (v vars)
#-Genera
(declare (ignore v))
(pop bound-vars))))
(setq
bindings
(nconc bindings let-bindings
(cond
(extra-body ; there was some computation
to
; do after the
bindings--here's
; our chance
(cons (list (first vars)
`(progn ,@extra-body nil))
(rest vars)))
(t vars))))))))))
(do ((tail body (cdr tail)))
((not (and (consp tail)
(consp (car tail))
(eq (caar tail)
'declare))) ; tail now points at first
; non-declaration. if there
; were declarations, pop
them
; off so they appear in the
; right place
(unless (eq tail body)
(setq iterate-decls (ldiff body tail))
(setq body tail))))
`(block ,block-name
(let* ,(append bindings final-bindings)
,@(and generator-decls `((declare ,@generator-decls)))
,@iterate-decls
,@leftover-body
(loop ,@(nreverse update-forms)
,@body)))))
;;; (return) -> (return (values))
(defun optimize-gathering-form (clauses body gathering-env)
(let*
(acc-info leftover-body top-bindings finish-forms top-decls)
(dolist (clause clauses)
(multiple-value-bind
(let-body binding-type let-bindings localdecls otherdecls
extra-body)
(expand-into-let (second clause)
'gathering gathering-env)
(prog* ((acc-var (first clause))
renamed-vars accumulator realizer)
(when (and (consp let-body)
(eq (car let-body)
'values)
(consp (setq let-body (cdr let-body)))
(setq accumulator (function-lambda-p (car
let-body))
)
(consp (setq let-body (cdr let-body)))
(setq realizer (function-lambda-p (car let-body)
0))
(null (cdr let-body)))
;; Macro returned something of the form (VALUES
#'(lambda
;; (value) ...) #'(lambda () ...)), a function to
;; accumulate values and a function to realize the
result.
(when binding-type
;; Gatherer expanded into a LET
(cond
(otherdecls (maybe-warn
:definition "Couldn't optimize
GATHERING clause ~S because its expansion carries declarations about more
than the bound variables: ~S"
(second clause)
`(declare ,@otherdecls))
(go punt)))
(when let-bindings
;; The first transformation we want to perform is
a
;; variant of "LET-eversion": turn (mv-bind (acc
;; real) (let (..bindings..) (values #'(lambda
...)
;; #'(lambda ...))) ..body..) into (let*
;; (..bindings.. (acc #'(lambda ...)) (real
;; #'(lambda ...))) ..body..). This
transformation
;; is valid if nothing in body refers to any of
the
;; bindings, something we can assure by
;; alpha-converting the inner let (substituting
new
;; names for each var). Of course, none of those
;; vars can be special, but we already checked
for
;; that above.
(multiple-value-setq (let-bindings
renamed-vars)
(rename-let-bindings let-bindings
binding-type gathering-env
leftover-body))
(setq top-bindings (nconc top-bindings
let-bindings
))
(setq leftover-body nil)
; If there was any leftover
; from previous, it is now
; consumed
))
(setq leftover-body (nconc leftover-body extra-body))
; Computation to do after
these
; bindings
(push (cons acc-var (rename-and-capture-variables
accumulator renamed-vars
gathering-env))
acc-info)
(setq realizer (rename-variables realizer renamed-vars
gathering-env))
(push (cond
((null (cdddr realizer))
; Simple (LAMBDA () expr) =>
; expr
(third realizer))
(t ; There could be
declarations
; or something, so leave as
a
; LET
(cons 'let (cdr realizer))))
finish-forms)
(unless (null localdecls) ; Declarations about the LET
; variables also has to
; percolate up
(setq top-decls (nconc top-decls (sublis
renamed-vars
localdecls))))
(return (values)))
(maybe-warn :definition "Couldn't optimize GATHERING clause
~S because its expansion is not of the form (VALUES #'(LAMBDA ...)
#'(LAMBDA () ...))"
(second clause))
punt
(let
((gs (gensym))
(expansion `(multiple-value-list ,(second clause))))
; Slow way--bind gensym to
the
; macro expansion, and we
will
; funcall it in the body
(push (list acc-var gs)
acc-info)
(push `(funcall (cadr ,gs))
finish-forms)
(setq
top-bindings
(nconc
top-bindings
(list
(list gs
(cond
(leftover-body
`(progn ,@(prog1 leftover-body (setq
leftover-body
nil))
,expansion))
(t expansion))))))))))
(setq body (walk-gathering-body body gathering-env acc-info))
(cond
((eq body :abort) ; Couldn't finish expansion
nil)
(t `(let* ,top-bindings ,@(and top-decls
`((declare ,@top-decls)))
,body
,(cond
((null (cdr finish-forms)); just a single value
(car finish-forms))
(t `(values ,@(reverse finish-forms)))))))))
;;; Changes to pkg.lisp
;;; We need to import these symbols
#+3600
(import '(sys:%instance-ref sys:instancep) *the-pcl-package*)
;;; And don't need to export them. Also, %instancep -> instancep
(defvar *other-exports* '(
get-setf-function
get-setf-function-name
standard-class
standard-generic-function
standard-method
make
initialize
mki
class-prototype
class
object
essential-class
class-name
class-precedence-list
class-local-supers
class-local-slots
class-direct-subclasses
class-direct-methods
class-slots
method-arglist
method-argument-specifiers
method-function
method-equal
slotd-name
slot-missing
define-meta-class
%allocate-instance
;; %instance-ref
;; instancep
%instance-meta-class
allocate-instance
optimize-slot-value
optimize-setf-of-slot-value
add-named-class
class-for-redefinition
add-class
supers-changed
slots-changed
check-super-metaclass-compatibility
make-slotd
compute-class-precedence-list
walk-method-body
walk-method-body-form
add-named-method
add-method
remove-named-method
remove-method
find-method
find-method-internal
))
;;; Changes to slots
;;; Symbolics likes the initial values of constants to be constants
;;; and not just expressions which evaluate to constants
(defvar slot-value-cache-mask (make-cache-mask slot-value-cache-size 3))
;;; Changes to vector
;;; (return) -> (return nil)
(defun cache-key-from-wrappers-1 (cache-size specialized-positions objects)
(let ((offset 0)
(nspecialized 0)
(i 0))
(dolist (obj objects)
(when (null specialized-positions) (return nil))
(when (= i (car specialized-positions))
(setq specialized-positions (cdr specialized-positions))
(incf nspecialized)
(let* ((wrapper (wrapper-of-1 obj))
(number (wrapper-cache-no wrapper)))
(when (zerop number)
(setq wrapper (obsolete-instance-trap wrapper obj)
number (wrapper-cache-no wrapper)))
(setq offset (%logxor offset number))))
(incf i))
(%logand offset (make-cache-mask cache-size (1+ nspecialized)))))
------------------------End of changes------------------------------
Hope this helps.
Carl Klapper
Odyssey Research Associates, Inc.
301A Harris B. Dates Drive
Ithaca, NY 14850
(607) 277-2020
klapper%oravax.uucp@cu-arpa.cs.cornell.edu