From 099d6dd1f6a5ac2ffec5c14d07a4b905322ef968 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 27 Feb 2001 22:09:13 +0000 Subject: [PATCH] 0.6.11.5: MNA hack to DEFCONSTANT-EQX to support cmucl-2.4.19 as xc host patches ported by MNA from CMU CL.. ..no need to export the unused symbols %FUNCTION-HEADER-TYPE, %FUNCTION-HEADER-ARGLIST, and %FUNCTION-HEADER-NAME ..Upon a stack trace ambiguity in X86-CALL-CONTEXT, choose the Lisp frame in preference to the C frame as this is the frame of interest. ..Limit the stack trace failure warning in X86-CALL-CONTEXT to fails for the immediate frame rather then failures deeper within the search. ..Catch missing slots in CONDITION-READER-FUNCTION, and signal an error. ..PPRINT-NEWLINE, PPRINT-INDENT, and PPRINT-TAB should do nothing when *PRINT-PRETTY* is false. ..Correct the pretty printing by PRINT-UNREADABLE-OBJECT. Only attempt to print pretty when the stream is a PRETTY-STREAM (and when *PRINT-PRETTY*) to ensure that all output goes to the same stream. ..Have PRINT-UNREADABLE-OBJECT respect *PRINT-PRETTY*. ..Fix OUTPUT-CHARACTER to escape the CHAR-NAME. Rework QUOTE-STRING to not write the delimiting quotes so that it can be used by OUTPUT-CHARACTER. ..Within GENERATE-BYTE-CODE-FOR-SET, avoid trying to set a lexical variable with no refs since the compiler deletes such variables. ..Within SET-LEAF-VALUE-LAMBDA-VAR, avoid trying to set a lexical variable with no refs since the compiler deletes such variables. ..Rework the ASH DERIVE-TYPE optimizer to better handle large negative bounds. Based on suggestions from Raymond Toy. ..Add a defensive declaration to PARSE-SPECIALIZERS. ..Add a defensive declaration to PARSE-DEFMETHOD, as well. ..Silence compiler warnings about undefined function when compiling a method containing a MAKE-INSTANCE call. ..Correct the printing of instance objects for which the length was being incorrectly calculated. --- package-data-list.lisp-expr | 7 ++- src/code/debug-int.lisp | 31 +++++++--- src/code/late-target-error.lisp | 4 ++ src/code/pprint.lisp | 10 +++- src/code/primordial-extensions.lisp | 13 ++++- src/code/print.lisp | 107 ++++++++++++++++++++++------------- src/compiler/byte-comp.lisp | 12 +++- src/compiler/eval.lisp | 35 +++++++----- src/compiler/srctran.lisp | 102 ++++++++++++++++++++++++++------- src/pcl/boot.lisp | 6 +- src/pcl/fast-init.lisp | 12 +++- src/runtime/print.c | 14 ++++- version.lisp-expr | 2 +- 13 files changed, 263 insertions(+), 92 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 35433e8..663c17e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -843,8 +843,11 @@ is a good idea, but see SB-SYS for blurring of boundaries." "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK" "%COSH" "%DEPOSIT-FIELD" "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" - "%FUNCTION-HEADER-ARGLIST" - "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" +;;; MNA: cmucl-commit: Mon, 4 Dec 2000 13:50:25 -0800 (PST) +;;; No need to export the unused symbols %function-header-arglist +;;; %function-header-name %function-header-type. +;;; "%FUNCTION-HEADER-ARGLIST" +;;; "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" "%HYPOT" "%INSTANCE-SET-CONDITIONAL" "%LDB" "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index e066ee8..465887f 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -738,7 +738,16 @@ ;;; ;;; XXX Should handle interrupted frames, both Lisp and C. At present it ;;; manages to find a fp trail, see linux hack below. -(defun x86-call-context (fp &key (depth 8)) + +;;; MNA: cmucl-commit: Mon, 6 Nov 2000 10:08:39 -0800 (PST) +;;; Upon a stack trace ambiguity in x86-call-context, choose the lisp +;;; frame in preference to the C frame as this is frame of interest. + +;;; MNA: cmucl-commit: Mon, 6 Nov 2000 09:48:00 -0800 (PST) +;;; Limit the stack trace failure warning in x86-call-context to fails for the +;;; immediate frame rather failures deeper within the search. + +(defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) ;;(format t "*CC ~S ~S~%" fp depth) @@ -762,15 +771,19 @@ lisp-ocfp lisp-ra c-ocfp c-ra) ;; Look forward another step to check their validity. (let ((lisp-path-fp (x86-call-context lisp-ocfp - :depth (- depth 1))) - (c-path-fp (x86-call-context c-ocfp :depth (- depth 1)))) + :depth (1+ depth))) + (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) (cond ((and lisp-path-fp c-path-fp) - ;; Both still seem valid - choose the smallest. - #+nil (format t "debug: both still valid ~S ~S ~S ~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - (if (sap< lisp-ocfp c-ocfp) - (values lisp-ra lisp-ocfp) - (values c-ra c-ocfp))) + ;; Both still seem valid - choose the lisp frame. + #+nil (when (zerop depth) + (format t "debug: both still valid ~S ~S ~S ~S~%" + lisp-ocfp lisp-ra c-ocfp c-ra)) + #+freebsd + (if (sap> lisp-ocfp c-ocfp) + (values lisp-ra lisp-ocfp) + (values c-ra c-ocfp)) + #-freebsd + (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 8fc3f32..45b4bd1 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -217,6 +217,10 @@ (if (eq val *empty-condition-slot*) (let ((actual-initargs (condition-actual-initargs condition)) (slot (find-condition-class-slot class name))) + ;; MNA: cmucl-commit: Mon, 8 Jan 2001 21:21:23 -0800 (PST) + ;; Catch missing slots in condition-reader-function, and signal an error. + (unless slot + (error "Slot ~S of ~S missing." name condition)) (dolist (initarg (condition-slot-initargs slot)) (let ((val (getf actual-initargs initarg diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index bbfa315..df096b1 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -628,6 +628,10 @@ ;;;; user interface to the pretty printer +;;; MNA: cmucl-commit: Wed, 27 Dec 2000 07:42:40 -0800 (PST) +;;; pprint-newline, pprint-indent, and pprint-tab should do nothing if +;;; *print-pretty* is not true. + (defun pprint-newline (kind &optional stream) #!+sb-doc "Output a conditional newline to STREAM (which defaults to @@ -655,7 +659,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (pretty-stream-p stream) + (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-newline stream kind))) nil) @@ -678,7 +682,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (pretty-stream-p stream) + (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-indent stream relative-to n))) nil) @@ -703,7 +707,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (pretty-stream-p stream) + (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-tab stream kind colnum colinc))) nil) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index cb45dc3..8d0db4b 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -182,7 +182,18 @@ ,expr-tmp)) (error "already bound differently: ~S"))) (t - (defconstant ,symbol ,expr-tmp ,@(when doc `(,doc))))))) + ;;; MNA: CMU CL does not like DEFCONSTANT-EQX, + ;;; at least it does not like using EXPR-TMP-, + ;;; below. + (defconstant ,symbol + ;; MNA: + ;; FIXME: this is a very ugly hack, + ;; to be able to build SBCL with CMU CL (2.4.19), + ;; because there seems to be some confusion in + ;; CMU CL about ,expr-temp at EVAL-WHEN time ... + #-cmu ,expr-tmp + #+cmu ,expr + ,@(when doc `(,doc))))))) ;; The #+SB-XC :COMPILE-TOPLEVEL situation is special, since we ;; want to define the symbol not just in the cross-compilation ;; host Lisp (which was handled above) but also in the diff --git a/src/code/print.lisp b/src/code/print.lisp index d715bf1..5c6dd4f 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -236,24 +236,48 @@ ;;;; support for the PRINT-UNREADABLE-OBJECT macro +;;; MNA: cmucl-commit: Mon, 1 Jan 2001 01:30:53 -0800 (PST) +;;; Correct the pretty printing by print-unreadable-object. Only attempt +;;; to print pretty when the stream is a pretty-stream (and when *print-pretty*) +;;; to ensure that all output goes to the same stream. + +;;; MNA: cmucl-commit: Wed, 27 Dec 2000 05:24:30 -0800 (PST) +;;; Have print-unreadable-object respect *print-pretty*. + +;;; Guts of print-unreadable-object. +;;; +;;; When *print-pretty* and the stream is a pretty-stream, format the object +;;; within a logical block - pprint-logical-block does not rebind the stream +;;; when it is already a pretty stream so output from the body will go to the +;;; same stream. +;;; (defun %print-unreadable-object (object stream type identity body) (when *print-readably* (error 'print-not-readable :object object)) - (write-string "#<" stream) - (when type - (write (type-of object) :stream stream :circle nil - :level nil :length nil) - (write-char #\space stream)) - (when body - (funcall body)) - (when identity - (unless (and type (null body)) - (write-char #\space stream)) - (write-char #\{ stream) - (write (get-lisp-obj-address object) :stream stream - :radix nil :base 16) - (write-char #\} stream)) - (write-char #\> stream) + (flet ((print-description () + (when type + (write (type-of object) :stream stream :circle nil + :level nil :length nil) + (when (or body identity) + (write-char #\space stream) + (pprint-newline :fill stream))) + (when body + (funcall body)) + (when identity + (when body + (write-char #\space stream) + (pprint-newline :fill stream)) + (write-char #\{ stream) + (write (get-lisp-obj-address object) :stream stream + :radix nil :base 16) + (write-char #\} stream)))) + (cond ((and (sb!pretty:pretty-stream-p stream) *print-pretty*) + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (print-description))) + (t + (write-string "#<" stream) + (print-description) + (write-char #\> stream)))) nil) ;;;; WHITESPACE-CHAR-P @@ -940,27 +964,30 @@ (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) - (if (or *print-escape* *print-readably*) - (quote-string vector stream) - (write-string vector stream))) + (cond ((or *print-escape* *print-readably*) + (write-char #\" stream) + (quote-string vector stream) + (write-char #\" stream)) + (t + (write-string vector stream)))) ((not (or *print-array* *print-readably*)) - (output-terse-array vector stream)) + (output-terse-array vector stream)) ((bit-vector-p vector) - (write-string "#*" stream) - (dotimes (i (length vector)) - (output-object (aref vector i) stream))) + (write-string "#*" stream) + (dotimes (i (length vector)) + (output-object (aref vector i) stream))) (t - (when (and *print-readably* - (not (eq (array-element-type vector) 't))) - (error 'print-not-readable :object vector)) - (descend-into (stream) - (write-string "#(" stream) - (dotimes (i (length vector)) - (unless (zerop i) - (write-char #\space stream)) - (punt-print-if-too-long i stream) - (output-object (aref vector i) stream)) - (write-string ")" stream))))) + (when (and *print-readably* + (not (eq (array-element-type vector) 't))) + (error 'print-not-readable :object vector)) + (descend-into (stream) + (write-string "#(" stream) + (dotimes (i (length vector)) + (unless (zerop i) + (write-char #\space stream)) + (punt-print-if-too-long i stream) + (output-object (aref vector i) stream)) + (write-string ")" stream))))) ;;; This function outputs a string quoting characters sufficiently that so ;;; someone can read it in again. Basically, put a slash in front of an @@ -970,15 +997,13 @@ ;; KLUDGE: We probably should look at the readtable, but just do ;; this for now. [noted by anonymous long ago] -- WHN 19991130 `(or (char= ,char #\\) - (char= ,char #\")))) - (write-char #\" stream) + (char= ,char #\")))) (with-array-data ((data string) (start) (end (length string))) (do ((index start (1+ index))) ((>= index end)) (let ((char (schar data index))) (when (needs-slash-p char) (write-char #\\ stream)) - (write-char char stream)))) - (write-char #\" stream))) + (write-char char stream)))))) (defun output-array (array stream) #!+sb-doc @@ -1489,6 +1514,12 @@ ;;;; other leaf objects +;;; MNA: cmucl-commit: Mon, 1 Jan 2001 03:41:18 -0800 (PST) +;;; Fix output-character to escape the char-name. Reworking quote-string +;;; to not write the delimiting quotes so that is can be used by +;;; output-character. + + ;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output the ;;; character name or the character in the #\char format. (defun output-character (char stream) @@ -1496,7 +1527,7 @@ (let ((name (char-name char))) (write-string "#\\" stream) (if name - (write-string name stream) + (quote-string name stream) (write-char char stream))) (write-char char stream))) diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index 196ae9b..fa70dfd 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -1275,8 +1275,18 @@ ((:special :global) (output-push-constant segment (global-var-name leaf)) (output-do-inline-function segment 'setf-symbol-value)))) + ;;; MNA: cmucl-commit: Tue, 26 Sep 2000 09:41:00 -0700 (PDT) + ;;; Within generate-byte-code-for-set, avoid trying to set a lexical + ;;; variable with no refs since the compiler deletes such variables. (lambda-var - (output-set-lambda-var segment leaf (node-environment set)))) + (cond ((leaf-refs leaf) + (unless (eql values 0) + ;; Someone wants the value, so copy it. + (output-do-xop segment 'dup)) + (output-set-lambda-var segment leaf (node-environment set))) + ;; If no-one wants the value then pop it else leave it for them. + ((eql values 0) + (output-byte-with-operand segment byte-pop-n 1))))) (unless (eql values 0) (checked-canonicalize-values segment cont 1))) (values)) diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp index 94fa93b..79afc72 100644 --- a/src/compiler/eval.lisp +++ b/src/compiler/eval.lisp @@ -845,22 +845,27 @@ ;;; This does SET-LEAF-VALUE for a lambda-var leaf. The debugger tools' ;;; internals uses this also to set interpreted local variables. + +;;; MNA: cmucl-commit: Tue, 26 Sep 2000 09:40:37 -0700 (PDT) +;;; Within set-leaf-value-lambda-var, avoid trying to set a lexical +;;; variable with no refs since the compiler deletes such variables. (defun set-leaf-value-lambda-var (node var frame-ptr closure value) - (let ((env (sb!c::node-environment node))) - (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var)) - env)) - (setf (indirect-value - (svref closure - (position var (sb!c::environment-closure env) - :test #'eq))) - value)) - ((sb!c::lambda-var-indirect var) - (setf (indirect-value - (eval-stack-local frame-ptr (sb!c::lambda-var-info var))) - value)) - (t - (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var)) - value))))) + (when (sb!c::leaf-refs var) + (let ((env (sb!c::node-environment node))) + (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var)) + env)) + (setf (indirect-value + (svref closure + (position var (sb!c::environment-closure env) + :test #'eq))) + value)) + ((sb!c::lambda-var-indirect var) + (setf (indirect-value + (eval-stack-local frame-ptr (sb!c::lambda-var-info var))) + value)) + (t + (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var)) + value)))))) ;;; This figures out how to return a value for a ref node. Leaf is the ref's ;;; structure that tells us about the value, and it is one of the following diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 931032f..807b362 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1404,6 +1404,25 @@ ) ; PROGN +;;; MNA: cmucl-commit: Wed, 3 Jan 2001 21:49:12 -0800 (PST) +;;; Rework the 'ash derive-type optimizer so better handle large negative bounds. +;;; Based on suggestions from Raymond Toy. + +;;; 'ash derive type optimizer. +;;; +;;; Large resulting bounds are easy to generate but are not particularly +;;; useful, so an open outer bound is returned for a shift greater than 64 - +;;; the largest word size of any of the ports. Large negative shifts are also +;;; problematic as the 'ash implementation only accepts shifts greater than +;;; the most-negative-fixnum. These issues are handled by two local functions: +;;; +;;; ash-outer: performs the shift when within an acceptable range, otherwise +;;; returns an open bound. +;;; +;;; ash-inner: performs the shift when within range, limited to a maximum of +;;; 64, otherwise returns the inner limit. +;;; + ;;; KLUDGE: All this ASH optimization is suppressed under CMU CL ;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH ;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero) @@ -1412,6 +1431,39 @@ (progn #!-propagate-fun-type (defoptimizer (ash derive-type) ((n shift)) + (flet ((ash-outer (n s) + (when (and (fixnump s) + (<= s 64) + (> s most-negative-fixnum)) + (ash n s))) + (ash-inner (n s) + (if (and (fixnump s) + (> s most-negative-fixnum)) + (ash n (min s 64)) + (if (minusp n) -1 0)))) + (or (let ((n-type (continuation-type n))) + (when (numeric-type-p n-type) + (let ((n-low (numeric-type-low n-type)) + (n-high (numeric-type-high n-type))) + (if (constant-continuation-p shift) + (let ((shift (continuation-value shift))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low (ash n-low shift)) + :high (when n-high (ash n-high shift)))) + (let ((s-type (continuation-type shift))) + (when (numeric-type-p s-type) + (let ((s-low (numeric-type-low s-type)) + (s-high (numeric-type-high s-type))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low + (if (minusp n-low) + (ash-outer n-low s-high) + (ash-inner n-low s-low))) + :high (when n-high + (if (minusp n-high) + (ash-inner n-high s-low) + (ash-outer n-high s-high))))))))))) + *universal-type*)) (or (let ((n-type (continuation-type n))) (when (numeric-type-p n-type) (let ((n-low (numeric-type-low n-type)) @@ -1438,28 +1490,40 @@ (make-numeric-type :class 'integer :complexp :real))))))))) *universal-type*)) + #!+propagate-fun-type (defun ash-derive-type-aux (n-type shift same-arg) (declare (ignore same-arg)) - (or (and (csubtypep n-type (specifier-type 'integer)) - (csubtypep shift (specifier-type 'integer)) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type)) - (s-low (numeric-type-low shift)) - (s-high (numeric-type-high shift))) - ;; KLUDGE: The bare 64's here should be related to - ;; symbolic machine word size values somehow. - (if (and s-low s-high (<= s-low 64) (<= s-high 64)) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low - (min (ash n-low s-high) - (ash n-low s-low))) - :high (when n-high - (max (ash n-high s-high) - (ash n-high s-low)))) - (make-numeric-type :class 'integer - :complexp :real)))) - *universal-type*)) + (flet ((ash-outer (n s) + (when (and (fixnump s) + (<= s 64) + (> s most-negative-fixnum)) + (ash n s))) + ;; KLUDGE: The bare 64's here should be related to + ;; symbolic machine word size values somehow. + + (ash-inner (n s) + (if (and (fixnump s) + (> s most-negative-fixnum)) + (ash n (min s 64)) + (if (minusp n) -1 0)))) + (or (and (csubtypep n-type (specifier-type 'integer)) + (csubtypep shift (specifier-type 'integer)) + (let ((n-low (numeric-type-low n-type)) + (n-high (numeric-type-high n-type)) + (s-low (numeric-type-low shift)) + (s-high (numeric-type-high shift))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low + (if (minusp n-low) + (ash-outer n-low s-high) + (ash-inner n-low s-low))) + :high (when n-high + (if (minusp n-high) + (ash-inner n-high s-low) + (ash-outer n-high s-high)))))) + *universal-type*))) + #!+propagate-fun-type (defoptimizer (ash derive-type) ((n shift)) (two-arg-derive-type n shift #'ash-derive-type-aux #'ash)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 8dcef58..f734467 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2047,7 +2047,7 @@ bootstrapping. ;;; into the 'real' arguments. This is where the syntax of DEFMETHOD ;;; is really implemented. (defun parse-defmethod (cdr-of-form) - ;;(declare (values name qualifiers specialized-lambda-list body)) + (declare (list cdr-of-form)) (let ((name (pop cdr-of-form)) (qualifiers ()) (spec-ll ())) @@ -2057,7 +2057,11 @@ bootstrapping. (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) +;;; MNA: cmucl-commit: Tue, 19 Dec 2000 06:26:31 -0800 (PST) +;;; Add a defensive declaration to PARSE-SPECIALIZERS. + (defun parse-specializers (specializers) + (declare (list specializers)) (flet ((parse (spec) (let ((result (specializer-from-type spec))) (if (specializerp result) diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index f49a8b4..9740481 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -60,6 +60,16 @@ (sym (make-instance-function-symbol key))) (push key *make-instance-function-keys*) (when sym + ;; MNA: cmucl-commit Sat, 27 Jan 2001 07:07:45 -0800 (PST) + ;; Silence compiler warnings about undefined function + ;; + ;; when compiling a method containing a make-instance call. + (progn ;; Lifted from c::%%defun. + (sb-c::proclaim-as-function-name sym) + (when (eq (sb-int:info :function :where-from sym) :assumed) + (setf (sb-int:info :function :where-from sym) :defined) + (when (sb-int:info :function :assumed-type sym) + (setf (sb-int:info :function :assumed-type sym) nil)))) `(,sym ',class (list ,@initargs))))))) (defmacro expanding-make-instance-top-level (&rest forms &environment env) @@ -683,7 +693,7 @@ (defvar *note-iis-entry-p* nil) (defvar *compiled-initialize-instance-simple-functions* - (make-hash-table :test 'equal)) + (make-hash-table :test #'equal)) (defun initialize-instance-simple-function (use info class form-list) (let* ((pv-cell (get-pv-cell-for-class class)) diff --git a/src/runtime/print.c b/src/runtime/print.c index 56cdb39..505c7fe 100644 --- a/src/runtime/print.c +++ b/src/runtime/print.c @@ -530,7 +530,6 @@ static void print_otherptr(lispobj obj) break; case type_SimpleVector: - case type_InstanceHeader: NEWLINE; printf("length = %ld", length); ptr++; @@ -541,6 +540,19 @@ static void print_otherptr(lispobj obj) } break; + /* MNA: cmucl-commit Tue, 9 Jan 2001 11:46:57 -0800 (PST) + Correct the printing of instance objects for which the length was + being incorrectly calculated. */ + case type_InstanceHeader: + NEWLINE; + printf("length = %ld", (long) count); + index = 0; + while (count-- > 0) { + sprintf(buffer, "%d: ", index++); + print_obj(buffer, *ptr++); + } + break; + case type_SimpleArray: case type_SimpleBitVector: case type_SimpleArrayUnsignedByte2: diff --git a/version.lisp-expr b/version.lisp-expr index 573e12c..42493bf 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.4" +"0.6.11.5" -- 1.7.10.4