[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
PCL Genera 7.2 bugfixes
- To: commonloops.pa@Xerox.COM
- Subject: PCL Genera 7.2 bugfixes
- From: Mike Thome <mthome@VAX.BBN.COM>
- Date: Wed, 21 Sep 88 16:11:28 -0400
- Redistributed: commonloops.pa
Below are some commented bugfixes for PCL (AAAI release) under
Symbolics Genera 7.2. The bulk of them are environment hacks, but there
are a few significant bugfixes in there (read the comments).
enjoy,
-mike thome (mthome@bbn.com)
PS. Question: Anyone tried running PCL with MacIvory yet?
PPS. I'm still getting two of every commonloops list messages...
-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
NOTES: anything marked #+patched-in-sources must be "patched in the
sources" for full effect - that is if you want the fixes to apply to the
innards of PCL, you'll have to recompile everything.
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
;;; PATCH BOOT.LISP
;;; call fdefine on the fspec so stuff gets remembered.
;;; (needed for full M-., etc capability)
;;; A side effect is that the function spec of the new method is
;;; returned by the defmethod form.
;;;
#+patched-in-sources
(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)))
#+patched-in-sources
(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)
))
;;; Patch FIN.LISP
;;; fixes (defmethod foo (x) x) bug: in vanilla aaai-pcl, if you type
;;; that [---^] form to the interpreter when foo had no previous
;;; definition, pcl would get blown out of the water due to a #' getting
;;; expanded to an SI:DIGESTED-LAMBDA form. this fixes the problem.
;;;
(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)))))
;;; Patch 3600-LOW.LISP
;;; removed comments that keep definition records from being saved.
;;; also fix up stuff so C-E from debugger works.
;;; The hash tables must use equal, 'cuz the keys are consed-up lists.
;;; MT - 880822
#+patched-in-sources
(defvar *method-fdefs* (make-hash-table :test #'equal :size 500))
#+patched-in-sources
(defvar *method-setf-fdefs* (make-hash-table :test #'equal :size 500))
#+patched-in-sources
(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)
)))
;;; PATCH 3600-low.lisp
;;; Support for multi-line arg lists when a buffer is sectionized while reading - i.e.
;;; M-. on a method whose name, specializers and qualifiers appear on more than one
;;; line in a file which either has not yet been read in or was read in as a result
;;; of another M-.-like function.
;;; NOTE: this also fixes a number of related bugs-- even some existing problems
;;; in finding standard symbolics definitions (see below).
;;; This is especially important when trying to follow the internals of PCL whose
;;; source commmonly contains multiple-line argument lists.
;(defun find-me (x) t) ; Always worked (and still does)
;(defun ; Fixed by patch
; dont-find-me (x) t)
;(defmethod ok-method ((x bar)) x) ; Worked under pcl before
;(defmethod loser-method ((x bar) ; Fixed by patch
; (y bar)) ; (lambda-list split)
; (cons x y))
;(defmethod even-worse-method ; Ditto
; ((x bar))
; x)
;(defmethod badder-than-that ; (You get the idea)
; ((x
; bar))
; x)
;(defmethod really-bad ((x bar) ; Does NOT work (surprisingly enough)...
;(defmethod should-be-found ; ...But its not working doesn't prevent
; ((x bar)) ; following definitions to get broken.
; x)
;;; The variable zwei::*sectionize-line-lookahead* controls how many lines the parser
;;; is willing to look ahead while trying to parse a definition. Even 2 lines is enough
;;; for just about all cases, but there isn't much overhead, and 10 should be enough
;;; to satisfy pretty much everyone... but feel free to change it.
;;; - MT 880921
zwei:
(defvar *sectionize-line-lookahead* 10)
zwei:
(DEFMETHOD (:SECTIONIZE-BUFFER MAJOR-MODE :DEFAULT)
(FIRST-BP LAST-BP BUFFER STREAM INT-STREAM ADDED-COMPLETIONS)
ADDED-COMPLETIONS ;ignored, obsolete
(WHEN STREAM
(SEND-IF-HANDLES STREAM :SET-RETURN-DIAGRAMS-AS-LINES T))
(INCF *SECTIONIZE-BUFFER*)
(LET ((BUFFER-TICK (OR (SEND-IF-HANDLES BUFFER :SAVE-TICK) *TICK*))
OLD-CHANGED-SECTIONS)
(TICK)
;; Flush old section nodes. Also collect the names of those that are modified, they are
;; the ones that will be modified again after a revert buffer.
(DOLIST (NODE (NODE-INFERIORS BUFFER))
(AND (> (NODE-TICK NODE) BUFFER-TICK)
(PUSH (LIST (SECTION-NODE-FUNCTION-SPEC NODE)
(SECTION-NODE-DEFINITION-TYPE NODE))
OLD-CHANGED-SECTIONS))
(FLUSH-BP (INTERVAL-FIRST-BP NODE))
(FLUSH-BP (INTERVAL-LAST-BP NODE)))
(DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT INT-LINE))
(LIMIT (BP-LINE LAST-BP))
(EOFFLG)
(ABNORMAL T)
(DEFINITION-LIST NIL)
(BP (COPY-BP FIRST-BP))
(FUNCTION-SPEC)
(DEFINITION-TYPE)
(STR)
(INT-LINE)
(first-time t)
(future-line) ; we actually read into future line
(future-int-line)
(PREV-NODE-START-BP FIRST-BP)
(PREV-NODE-DEFINITION-LINE NIL)
(PREV-NODE-FUNCTION-SPEC NIL)
(PREV-NODE-TYPE 'HEADER)
(PREVIOUS-NODE NIL)
(NODE-LIST NIL)
(STATE (SEND SELF :INITIAL-SECTIONIZATION-STATE)))
(NIL)
;; If we have a stream, read another line.
(when (AND STREAM (NOT EOFFLG))
(let ((lookahead (if future-line 1 *sectionize-line-lookahead*)))
(dotimes (i lookahead) ; startup lookahead
(MULTIPLE-VALUE (future-LINE EOFFLG)
(LET ((DEFAULT-CONS-AREA *LINE-AREA*))
(SEND STREAM ':LINE-IN LINE-LEADER-SIZE)))
(IF future-LINE (SETQ future-INT-LINE (FUNCALL INT-STREAM ':LINE-OUT future-LINE)))
(when first-time
(setq first-time nil)
(setq line future-line)
(setq int-line future-int-line))
(when eofflg
(return)))))
(SETQ INT-LINE LINE)
(when int-line
(MOVE-BP BP INT-LINE 0)) ;Record as potentially start-bp for a section
;; See if the line is the start of a defun.
(WHEN (AND LINE
(LET (ERR)
(MULTIPLE-VALUE (FUNCTION-SPEC DEFINITION-TYPE STR ERR STATE)
(SEND SELF ':SECTION-NAME INT-LINE BP STATE))
(NOT ERR)))
(PUSH (LIST FUNCTION-SPEC DEFINITION-TYPE) DEFINITION-LIST)
(SECTION-COMPLETION FUNCTION-SPEC STR NIL)
;; List methods under both names for user ease.
(LET ((OTHER-COMPLETION (SEND SELF ':OTHER-SECTION-NAME-COMPLETION
FUNCTION-SPEC INT-LINE)))
(WHEN OTHER-COMPLETION
(SECTION-COMPLETION FUNCTION-SPEC OTHER-COMPLETION NIL)))
(LET ((PREV-NODE-END-BP (BACKWARD-OVER-COMMENT-LINES BP ':FORM-AS-BLANK)))
;; Don't make a section node if it's completely empty. This avoids making
;; a useless Buffer Header section node. Just set all the PREV variables
;; so that the next definition provokes the *right thing*
(UNLESS (BP-= PREV-NODE-END-BP PREV-NODE-START-BP)
(SETQ PREVIOUS-NODE
(ADD-SECTION-NODE PREV-NODE-START-BP
(SETQ PREV-NODE-START-BP PREV-NODE-END-BP)
PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
(IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
(EQ PREV-NODE-TYPE TYPE)))
*TICK* BUFFER-TICK)
BUFFER-TICK))
(PUSH PREVIOUS-NODE NODE-LIST)))
(SETQ PREV-NODE-FUNCTION-SPEC FUNCTION-SPEC
PREV-NODE-TYPE DEFINITION-TYPE
PREV-NODE-DEFINITION-LINE INT-LINE))
;; After processing the last line, exit.
(WHEN (OR #+ignore EOFFLG (null line) (AND (NULL STREAM) (EQ LINE LIMIT)))
;; If reading a stream, we should not have inserted a CR
;; after the eof line.
(WHEN STREAM
(DELETE-INTERVAL (FORWARD-CHAR LAST-BP -1 T) LAST-BP T))
;; The rest of the buffer is part of the last node
(UNLESS (SEND SELF ':SECTION-NAME-TRIVIAL-P)
;; ---oh dear, what sort of section will this be? A non-empty HEADER
;; ---node. Well, ok for now.
(PUSH (ADD-SECTION-NODE PREV-NODE-START-BP LAST-BP
PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
(IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
(EQ PREV-NODE-TYPE TYPE)))
*TICK* BUFFER-TICK)
BUFFER-TICK)
NODE-LIST)
(SETF (LINE-NODE (BP-LINE LAST-BP)) (CAR NODE-LIST)))
(SETF (NODE-INFERIORS BUFFER) (NREVERSE NODE-LIST))
(SETF (NAMED-BUFFER-WITH-SECTIONS-FIRST-SECTION BUFFER) (CAR (NODE-INFERIORS BUFFER)))
(SETQ ABNORMAL NIL) ;timing windows here
;; Speed up completion if enabled.
(WHEN SI:*ENABLE-AARRAY-SORTING-AFTER-LOADS*
(SI:SORT-AARRAY *ZMACS-COMPLETION-AARRAY*))
(SETQ *ZMACS-COMPLETION-AARRAY*
(FOLLOW-STRUCTURE-FORWARDING *ZMACS-COMPLETION-AARRAY*))
(RETURN
(VALUES
(CL:SETF (ZMACS-SECTION-LIST BUFFER)
(NREVERSE DEFINITION-LIST))
ABNORMAL))))))
;;; Patch 3600-LOW.LISP
;;; Previously, if a source file in a PCL-based package contained what looks like
;;; flavor defmethod forms (i.e. an (IN-PACKAGE 'non-pcl-package) form appears at top
;;; level, and then a flavor-style defmethod form) appear, the parser would break.
;;; Now, if we can't parse the defmethod form, we send it to the flavor defmethod parser
;;; instead.
;;; also now supports multi-line arglist sectionizing.
;;;
zwei:
(defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp)
(block parser
(flet ((barf (&optional (error t))
(return-from parser
(cond ((eq error :flavor)
(funcall (get 'flavor:defmethod 'zwei::definition-function-spec-parser)
bp-after-defmethod))
(t
(values nil nil nil error))))))
(let ((bp-after-generic (forward-sexp bp-after-defmethod))
(qualifiers ())
(specializers ())
(spec nil)
(ignore1 nil)
(ignore2 nil))
(when bp-after-generic
(multiple-value-bind (generic error-p)
(read-fspec-item-from-interval bp-after-defmethod
bp-after-generic)
(if error-p
(barf) ; error here is really bad.... BARF!
(progn
(when (listp generic)
(if (and (symbolp (car generic))
(string-equal (cl:symbol-name (car generic)) "SETF"))
(setq generic (second generic) ; is a (setf xxx) form
setfp t)
(barf :flavor))) ; make a last-ditch-effort with flavor parser
(let* ((bp1 bp-after-generic)
(bp2 (forward-sexp bp1)))
(cl:loop
(if (null bp2)
(barf :more) ; item not closed - need another line!
(multiple-value-bind (item error-p)
(read-fspec-item-from-interval bp1 bp2)
(cond (error-p (barf)) ;
((listp item)
(setq qualifiers (nreverse qualifiers))
(cl:multiple-value-setq (ignore1
ignore2
specializers)
(pcl::parse-specialized-lambda-list item))
(setq spec (pcl::make-method-spec
(if setfp
`(cl:setf ,generic)
generic)
qualifiers
specializers))
(return (values spec
'defun
(string-interval
bp-after-defmethod
bp2))))
(t (push item qualifiers)
(setq bp1 bp2
bp2 (forward-sexp bp2))))))))))))))))
;;; PATCH 3600-low.lisp (or maybe rel-7-2-patches?)
;;; Fix a minor but annoying bug in Genera 7.2 dynamic window presentations...
;;; it isn't directly related to PCL at all, but use of PCL is how we found the
;;; bug.
;;; - rshapiro
#+genera-release-7-2
dw::
(defun symbol-flavor-or-cl-type (symbol)
(declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
non-atomic-deftype))
(multiple-value-bind (result foundp)
(gethash symbol *flavor-or-cl-type-cache*)
(let ((frob
(if foundp result
(setf (gethash symbol *flavor-or-cl-type-cache*)
(or (get symbol 'flavor:flavor)
(not (null (defstruct-type-p symbol)))
(let* ((deftype (get symbol 'deftype))
(descriptor (symbol-presentation-type-descriptor symbol))
(typep
(unless (and descriptor
(presentation-type-explicit-type-function
descriptor))
;; Don't override the one defined in the presentation-type.
(get symbol 'typep)))
(atomic-subtype-parent (find-atomic-subtype-parent symbol))
(non-atomic-deftype
(when (and (not descriptor) deftype)
(not (member (first (type-arglist symbol))
'(&rest &key &optional))))))
(if (or typep (not (atom deftype))
non-atomic-deftype
;; deftype overrides atomic-subtype-parent.
(and (not deftype) atomic-subtype-parent))
(list-in-area *handler-dynamic-area*
deftype typep atomic-subtype-parent
non-atomic-deftype)
deftype)))))))
(locally (declare (inline compiled-function-p))
(etypecase frob
(array (values frob))
(null (values nil))
((member t) (values nil t))
(compiled-function (values nil nil frob))
(lexical-closure (values nil nil frob)) ;bugfix - added clause.
(list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
frob
(values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
(symbol (values nil nil nil nil frob)))))))