"%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"
;;;
;;; 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)
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)
(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
\f
;;;; 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
((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)
((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)
((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)
,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-<X>,
+ ;;; 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
\f
;;;; 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)
\f
;;;; WHITESPACE-CHAR-P
(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
;; 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
\f
;;;; 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)
(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)))
((: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))
;;; 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
) ; 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)
(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))
(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))
;;; 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 ()))
(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)
(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
+ ;; <hairy-make-instance-name>
+ ;; 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)
(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))
break;
case type_SimpleVector:
- case type_InstanceHeader:
NEWLINE;
printf("length = %ld", length);
ptr++;
}
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:
;;; 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"
projects / sbcl.git / commitdiff