confused and compiles a full call to %INSTANCE-TYPEP (which doesn't exist
as a function) instead.
+37a:
+ The %INSTANCE-TYPEP problem in bug 37 comes up also when compiling
+ and loading
+ (IN-PACKAGE :CL-USER)
+ (LOCALLY
+ (DECLARE (OPTIMIZE (SAFETY 3) (SPEED 2) (SPACE 2)))
+ (DECLAIM (FTYPE (FUNCTION (&REST T) (VALUES)) EMPTYVALUES))
+ (DEFUN EMPTYVALUES (&REST REST)
+ (DECLARE (IGNORE REST))
+ (VALUES))
+ (DEFSTRUCT DUMMYSTRUCT X Y)
+ (DEFUN FROB-EMPTYVALUES (X)
+ (LET ((RES (EMPTYVALUES X X X)))
+ (UNLESS (TYPEP RES 'DUMMYSTRUCT)
+ 'EXPECTED-RETURN-VALUE))))
+ (ASSERT (EQ (FROB-EMPTYVALUES 11) 'EXPECTED-RETURN-VALUE))
+
+
38:
DEFMETHOD doesn't check the syntax of &REST argument lists properly,
accepting &REST even when it's not followed by an argument name:
-i Accumulation of half-understood design decisions eventually
+ Accumulation of half-understood design decisions eventually
chokes a program as a water weed chokes a canal. By refactoring
you can ensure that your full understanding of how the program
should be designed is always reflected in the program. As a
"%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION"
"%ARRAY-DISPLACED-P"
"%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
- "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH"
+ "%ARRAY-FILL-POINTER-P"
+ ;; MNA: open-coded-simple-array patch
+ "%ARRAY-SIMP"
+ "%ASIN" "%ASINH"
"%ATAN" "%ATAN2" "%ATANH"
"%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION"
"%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
"COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P"
"COMPLEX-VECTOR-P" "CONSED-SEQUENCE" "CONSTANT" "CONSTANT-TYPE"
"CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE"
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented out
+ ; "CONS-TYPE" "CONS-TYPE-CAR-TYPE" "CONS-TYPE-CDR-TYPE" "CONS-TYPE-P"
"CONTAINING-INTEGER-TYPE"
"CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
"COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA"
"LRA" "LRA-CODE-HEADER" "LRA-P"
"MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
"MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-DOUBLE-FLOAT"
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented out
+ ; "MAKE-CONS-TYPE"
"MAKE-FUNCTION-TYPE"
"MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT"
"MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE"
:inherits (sequence mutable-sequence mutable-collection
generic-sequence collection))
(cons
+ ;; MNA: cons compound-type patch
+ ;; FIXIT :all commented out
+ ; :translation cons
:codes (#.sb!vm:list-pointer-type)
:inherits (list sequence
mutable-sequence mutable-collection
(values-specifier-type-cache-clear))
(values))
\f
+
+;;; MNA: cons compound-type patch
+;;; FIXIT: all commented out
+;;;; Cons types:
+
+;;; The Cons-Type is used to represent cons types.
+;;;
+;; (defstruct (cons-type (:include ctype
+;; (:class-info (type-class-or-lose 'cons)))
+;; (:print-function %print-type))
+;; ;;
+;; ;; The car element type.
+;; (car-type *wild-type* :type ctype)
+;; ;;
+;; ;; The cdr element type.
+;; (cdr-type *wild-type* :type ctype))
+
+;; (define-type-class cons)
+
;;;; KLUDGE: not clear this really belongs here, but where?
;;; Is X a fixnum in the target Lisp?
(defun control-stack-usage ()
#!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
- control-stack-start)
- #!+x86 (- control-stack-end
+ sb!vm:control-stack-start)
+ #!+x86 (- sb!vm:control-stack-end
(sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
(defun binding-stack-usage ()
;;; Return the type of the first value indicated by Type. This is used
;;; by people who don't want to have to deal with values types.
-#!-sb-fluid (declaim (freeze-type values-type) (inline single-value-type))
+
+;;; MNA: fix-instance-typep-call patch
+#!-sb-fluid (declaim (freeze-type values-type))
+; (inline single-value-type))
(defun single-value-type (type)
(declare (type ctype type))
(cond ((values-type-p type)
(or (car (args-type-required type))
- (car (args-type-optional type))
+ (if (args-type-optional type)
+ (type-union (car (args-type-optional type)) (specifier-type 'null)))
(args-type-rest type)
- *universal-type*))
+ (specifier-type 'null)))
((eq type *wild-type*)
*universal-type*)
(t
(values (mapcar #'single-value-type req) (length req))))))
;;; Return two values:
+;;; MNA: fix-instance-typep-call patch
;;; 1. A list of all the positional (fixed and optional) types.
-;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
-;;; If no keywords or rest, *EMPTY-TYPE*.
-(defun values-type-types (type)
+;;; 2] The rest type (if any). If keywords allowed, *universal-type*.
+;;; If no keywords or rest then the default-type.
+(defun values-type-types (type &optional (default-type *empty-type*))
(declare (type values-type type))
(values (append (args-type-required type)
(args-type-optional type))
(cond ((args-type-keyp type) *universal-type*)
((args-type-rest type))
(t
- *empty-type*))))
+ ;; MNA: fix-instance-typep-call patch
+ default-type))))
;;; Return a list of OPERATION applied to the types in TYPES1 and
;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
;;; OPERATION returned true as its second value each time we called
;;; it. Since we approximate the intersection of VALUES types, the
;;; second value being true doesn't mean the result is exact.
-(defun args-type-op (type1 type2 operation nreq)
- (declare (type ctype type1 type2) (type function operation nreq))
+;;; MNA: fix-instance-typep-call patch
+(defun args-type-op (type1 type2 operation nreq default-type)
+ ;;; MNA: fix-instance-typep-call patch
+ (declare (type ctype type1 type2 default-type)
+ (type function operation nreq))
(if (or (values-type-p type1) (values-type-p type2))
(let ((type1 (coerce-to-values type1))
(type2 (coerce-to-values type2)))
- (multiple-value-bind (types1 rest1) (values-type-types type1)
- (multiple-value-bind (types2 rest2) (values-type-types type2)
+ (multiple-value-bind (types1 rest1)
+ ;;; MNA: fix-instance-typep-call patch
+ (values-type-types type1 default-type)
+ (multiple-value-bind (types2 rest2)
+ ;;; MNA: fix-instance-typep-call patch
+ (values-type-types type2 default-type)
(multiple-value-bind (rest rest-exact)
(funcall operation rest1 rest2)
(multiple-value-bind (res res-exact)
:optional (if opt-last
(subseq opt 0 (1+ opt-last))
())
- :rest (if (eq rest *empty-type*) nil rest))
+ ;; MNA fix-instance-typep-call patch
+ :rest (if (eq rest default-type) nil rest))
(and rest-exact res-exact)))))))))
(funcall operation type1 type2)))
((eq type1 *empty-type*) type2)
((eq type2 *empty-type*) type1)
(t
- (values (args-type-op type1 type2 #'type-union #'min)))))
+ ;;; MNA: fix-instance-typep-call patch
+ (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
+;;;
(defun-cached (values-type-intersection :hash-function type-cache-hash
:hash-bits 8
:values 2
(cond ((eq type1 *wild-type*) (values type2 t))
((eq type2 *wild-type*) (values type1 t))
(t
- (args-type-op type1 type2 #'type-intersection #'max))))
+ (args-type-op type1 type2 #'type-intersection #'max (specifier-type 'null)))))
;;; This is like TYPES-INTERSECT, except that it sort of works on
;;; VALUES types. Note that due to the semantics of
(return (make-hairy-type :specifier spec)))
(setq res int))))))
\f
+
+;;; MNA: cons compound-type patch
+;;; FIXIT: all commented out
+
+; (define-type-class cons)
+
+; (def-type-translator cons (&optional car-type cdr-type)
+; (make-cons-type :car-type (specifier-type car-type)
+; :cdr-type (specifier-type cdr-type)))
+
+; (define-type-method (cons :unparse) (type)
+; (let ((car-eltype (type-specifier (cons-type-car-type type)))
+; (cdr-eltype (type-specifier (cons-type-cdr-type type))))
+; (cond ((and (eq car-eltype '*) (eq cdr-eltype '*))
+; 'cons)
+; (t
+; `(cons ,car-eltype ,cdr-eltype)))))
+
+; (define-type-method (cons :simple-=) (type1 type2)
+; (declare (type cons-type type1 type2))
+; (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
+; (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
+
+; (define-type-method (cons :simple-subtypep) (type1 type2)
+; (declare (type cons-type type1 type2))
+; (multiple-value-bind (val-car win-car)
+; (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
+; (multiple-value-bind (val-cdr win-cdr)
+; (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+; (if (and val-car val-cdr)
+; (values t (and win-car win-cdr))
+; (values nil (or win-car win-cdr))))))
+
+; ;;; CONS :simple-union method -- Internal
+; ;;;
+; ;;; Give up if a precise type in not possible, to avoid returning overly
+; ;;; general types.
+; ;;;
+; (define-type-method (cons :simple-union) (type1 type2)
+; (declare (type cons-type type1 type2))
+; (let ((car-type1 (cons-type-car-type type1))
+; (car-type2 (cons-type-car-type type2))
+; (cdr-type1 (cons-type-cdr-type type1))
+; (cdr-type2 (cons-type-cdr-type type2)))
+; (cond ((type= car-type1 car-type2)
+; (make-cons-type :car-type car-type1
+; :cdr-type (type-union cdr-type1 cdr-type2)))
+; ((type= cdr-type1 cdr-type2)
+; (make-cons-type :car-type (type-union cdr-type1 cdr-type2)
+; :cdr-type cdr-type1)))))
+
+; (define-type-method (cons :simple-intersection) (type1 type2)
+; (declare (type cons-type type1 type2))
+; (multiple-value-bind (int-car win-car)
+; (type-intersection (cons-type-car-type type1) (cons-type-car-type type2))
+; (multiple-value-bind (int-cdr win-cdr)
+; (type-intersection (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+; (values (make-cons-type :car-type int-car :cdr-type int-cdr)
+; (and win-car win-cdr)))))
+
+
+
;;; Return the type that describes all objects that are in X but not
;;; in Y. If we can't determine this type, then return NIL.
;;;
(case-body-aux name keyform keyform-value clauses keys errorp proceedp
`(,(if multi-p 'member 'or) ,@keys))))
+
+;;; MNA: typecase-implicit-declarations patch
+
+;;; TYPECASE-BODY (interface)
+;;;
+;;; TYPECASE-BODY returns code for all the standard "typecase" macros.
+;;; Name is the macro name, and keyform is the thing to case on.
+;;; test is applied to the value of keyform and the entire first element,
+;;; instead of each part, of the case branch.
+;;; When errorp, no t or otherwise branch is permitted,
+;;; and an ERROR form is generated. When proceedp, it is an error to
+;;; omit errorp, and the ERROR form generated is executed within a
+;;; RESTART-CASE allowing keyform to be set and retested.
+(defun typecase-body (name keyform cases test errorp proceedp needcasesp)
+ (unless (or cases (not needcasesp))
+ (warn "no clauses in ~S" name))
+ (let* ((keyform-symbol-p (symbolp keyform))
+ (keyform-value (unless keyform-symbol-p
+ (gensym)))
+ (clauses ())
+ (keys ()))
+ (dolist (case cases)
+ (cond ((atom case)
+ (error "~S -- Bad clause in ~S." case name))
+ ((memq (car case) '(t otherwise))
+ (if errorp
+ (error 'simple-program-error
+ :format-control "No default clause is allowed in ~S: ~S"
+ :format-arguments (list name case))
+ (push `(t nil ,@(rest case)) clauses)))
+ (t
+ (push (first case) keys)
+ (push (if keyform-symbol-p
+ `((,test ,keyform ',(first case)) nil
+ (locally
+ ;; this will cause a compiler-warning ... disabled
+ ;; for now.
+ ;; (declare (type ,(first case) ,keyform))
+ ,@(rest case)))
+ `((,test ,keyform-value ',(first case)) nil
+ ,@(rest case)))
+ clauses))))
+ (if keyform-symbol-p
+ (typecase-symbol-body-aux name keyform clauses keys errorp proceedp
+ (cons 'or keys))
+ (case-body-aux name keyform keyform-value clauses keys errorp proceedp
+ (cons 'or keys)))))
+
+;;; TYPECASE-SYMBOL-BODY-AUX provides the expansion once CASE-BODY has groveled
+;;; all the cases, iff keyform is a symbol.
+(defun typecase-symbol-body-aux (name keyform clauses keys
+ errorp proceedp expected-type)
+ (if proceedp
+ (let ((block (gensym))
+ (again (gensym)))
+ `(block ,block
+ (tagbody
+ ,again
+ (return-from
+ ,block
+ (cond ,@(nreverse clauses)
+ (t
+ (setf ,keyform
+ (case-body-error
+ ',name ',keyform ,keyform
+ ',expected-type ',keys)))
+ (go ,again))))))
+ `(progn
+ (cond
+ ,@(nreverse clauses)
+ ,@(if errorp
+ `((t (error 'sb!conditions::case-failure
+ :name ',name
+ :datum ,keyform
+ :expected-type ',expected-type
+ :possibilities ',keys))))))))
+
;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
;;; all the cases. Note: it is not necessary that the resulting code
;;; signal case-failure conditions, but that's what KMP's prototype
"TYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true."
- (case-body 'typecase keyform cases nil 'typep nil nil nil))
+ (typecase-body 'typecase keyform cases 'typep nil nil nil))
(defmacro-mundanely ctypecase (keyform &body cases)
#!+sb-doc
"CTYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then a correctable error is signalled."
- (case-body 'ctypecase keyform cases nil 'typep t t t))
+ (typecase-body 'ctypecase keyform cases 'typep t t t))
(defmacro-mundanely etypecase (keyform &body cases)
#!+sb-doc
"ETYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then an error is signalled."
- (case-body 'etypecase keyform cases nil 'typep t nil t))
+ (typecase-body 'etypecase keyform cases 'typep t nil t))
\f
;;;; WITH-FOO i/o-related macros
named-type
member-type
array-type
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented out
+ ; cons-type
sb!xc:built-in-class)
(values (%typep obj type) t))
(sb!xc:class
:complexp (not (typep x 'simple-array))
:element-type etype
:specialized-element-type etype)))
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented
+ ; (cons
+ ; (make-cons-type))
(t
(sb!xc:class-of x))))
(dolist (type (union-type-types type))
(when (%%typep object type)
(return t))))
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented out
+; (cons-type
+; (and (consp object)
+; (%%typep (car object) (cons-type-car-type type))
+; (%%typep (cdr object) (cons-type-cdr-type type))))
(unknown-type
;; dunno how to do this ANSIly -- WHN 19990413
#+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
(+ 1
(if (numeric-type-low type) 1 0)
(if (numeric-type-high type) 1 0))))
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented out
+; (cons-type
+; (+ (type-test-cost (specifier-type 'cons))
+; (function-cost 'car)
+; (type-test-cost (cons-type-car-type type))
+; (function-cost 'cdr)
+; (type-test-cost (cons-type-cdr-type type))))
(t
(function-cost 'typep)))))
\f
(close (fasl-file-stream file) :abort abort-p)
(values))
\f
+
+;;; MNA dump-circular hack
+(defun circular-list-p (list)
+ (and (listp list)
+ (multiple-value-bind (res condition)
+ (ignore-errors (list-length list))
+ (if condition
+ nil
+ (null res)))))
+
;;;; main entries to object dumping
;;; This function deals with dumping objects that are complex enough so that
(typecase x
(symbol (dump-symbol x file))
(list
+ ;; MNA dump-circular hack
+ (if (circular-list-p x)
+ (progn
+ (dump-list x file)
+ (eq-save-object x file))
(unless (equal-check-table x file)
(dump-list x file)
- (equal-save-object x file)))
+ (equal-save-object x file))))
(layout
(dump-layout x file)
(eq-save-object x file))
(part-of function))
(base-char
(exactly base-char))
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented out
+; (cons-type
+; (part-of list))
(cons
(part-of list))
(t
;;;; mutator accessors
(defknown mutator-self () system-area-pointer (flushable movable))
+
+;;; MNA: open-coded-simple-array patch
+(defun %array-simp (a) a)
+(defknown %array-simp (simple-array) simple-array (movable foldable flushable))
+
+(defknown %array-data-vector (simple-array) simple-array (movable foldable flushable))
+(defknown %array-simp (simple-array) simple-array (movable foldable flushable))
(declare (type (simple-array ,element-type-specifier 1) array))
(data-vector-ref array index)))))
+;;; MNA: open-coded-simple-array patch
(deftransform data-vector-ref ((array index)
(simple-array t))
(let ((array-type (continuation-type array)))
(unless (array-type-p array-type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions array-type)))
- (when (or (atom dims) (= (length dims) 1))
+ (when (and (consp dims) (= (length dims) 1))
(give-up-ir1-transform))
- (let ((el-type (array-type-element-type array-type))
- (total-size (if (member '* dims)
+ (let* ((el-type (array-type-element-type array-type))
+ (total-size (if (or (atom dims) (member '* dims))
'*
- (reduce #'* dims))))
- `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
- (,total-size))
- (%array-data-vector array))
- index)))))
+ (reduce #'* dims)))
+ (type-sp `(simple-array ,(type-specifier el-type)
+ (,total-size))))
+ (if (atom dims)
+ `(let ((a (truly-the ,type-sp (%array-simp array))))
+ (data-vector-ref a index))
+ `(let ((a (truly-the ,type-sp (%array-data-vector array))))
+ (data-vector-ref a index)))))))
(deftransform hairy-data-vector-set ((array index new-value)
(array t t)
index
new-value)))))
+;;; MNA: open-coded-simple-array patch
(deftransform data-vector-set ((array index new-value)
(simple-array t t))
(let ((array-type (continuation-type array)))
(unless (array-type-p array-type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions array-type)))
- (when (or (atom dims) (= (length dims) 1))
+ (when (and (consp dims) (= (length dims) 1))
(give-up-ir1-transform))
- (let ((el-type (array-type-element-type array-type))
- (total-size (if (member '* dims)
+ (let* ((el-type (array-type-element-type array-type))
+ (total-size (if (or (atom dims) (member '* dims))
'*
- (reduce #'* dims))))
- `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
- (,total-size))
- (%array-data-vector array))
- index
- new-value)))))
+ (reduce #'* dims)))
+ (type-sp `(simple-array ,(type-specifier el-type)
+ (,total-size))))
+ (if (atom dims)
+ `(let ((a (truly-the ,type-sp (%array-simp array))))
+ (data-vector-set a index new-value))
+ `(let ((a (truly-the ,type-sp (%array-data-vector array))))
+ (data-vector-set a index new-value)))))))
;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
;;;
(deftransform eql ((x y) (double-float double-float))
'(and (= (double-float-low-bits x) (double-float-low-bits y))
(= (double-float-high-bits x) (double-float-high-bits y))))
+
(defun hairy-type-check-template-name (type)
(declare (type ctype type))
(typecase type
+ ;; MNA: cons compound-type
+ ;; FIXIT: all commented out
+; (cons-type
+; (if (type= type (specifier-type 'cons))
+; 'sb!c:check-cons
+; nil))
+; (built-in-class
+; (if (type= type (specifier-type 'symbol))
+; 'sb!c:check-symbol
+; nil))
(named-type
(case (named-type-name type)
(cons 'sb!c:check-cons)
(string= (symbol-name what) "CLASS"))) ; pcl hack
(or (info :type :kind what)
(and (consp what) (info :type :translator (car what)))))
- (unless (policy nil (= brevity 3))
+;;; MNA - abbreviated declaration bug
+;; (unless (policy nil (= brevity 3))
;; FIXME: Is it ANSI to warn about this? I think not.
- (compiler-note "abbreviated type declaration: ~S." spec))
+;; (compiler-note "abbreviated type declaration: ~S." spec))
(process-type-declaration spec res vars))
((info :declaration :recognized what)
res)
(let ((n-supplied (gensym "N-SUPPLIED-")))
(temps n-supplied)
(arg-vals n-value n-supplied)
- (tests `((eq ,n-key ,keyword)
+ ;; MNA: non-self-eval-keyword patch
+ (tests `((eq ,n-key ',keyword)
(setq ,n-supplied t)
(setq ,n-value ,n-value-temp)))))
(t
(arg-vals n-value)
- (tests `((eq ,n-key ,keyword)
+ ;; MNA: non-self-eval-keyword patch
+ (tests `((eq ,n-key ',keyword)
(setq ,n-value ,n-value-temp)))))))
(unless allowp
(setf (entry-cleanup entry) cleanup)
(prev-link entry start)
(use-continuation entry dummy)
- (let ((*lexenv* (make-lexenv :blocks (list (cons name (list entry cont)))
+
+ ;; MNA - Re: two obscure bugs in CMU CL
+ (let* ((env-entry (list entry cont))
+ (*lexenv*
+ (make-lexenv :blocks (list (cons name env-entry))
:cleanup cleanup)))
+ (push env-entry (continuation-lexenv-uses cont))
(ir1-convert-progn-body dummy cont forms))))
+
;;; We make Cont start a block just so that it will have a block
;;; assigned. People assume that when they pass a continuation into
;;; IR1-Convert as Cont, it will have a block when it is done.
(conts))
(starts dummy)
(dolist (segment (rest segments))
- (let ((tag-cont (make-continuation)))
+ ;; MNA - Re: two obscure bugs
+ (let* ((tag-cont (make-continuation))
+ (tag (list (car segment) entry tag-cont)))
(conts tag-cont)
(starts tag-cont)
(continuation-starts-block tag-cont)
- (tags (list (car segment) entry tag-cont))))
+ (tags tag)
+ (push (cdr tag) (continuation-lexenv-uses tag-cont))
+ ))
(conts cont)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
the Declarations have effect. If LOCALLY is a top-level form, then
the Forms are also processed as top-level forms."
(multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (let* ((*lexenv* (process-decls decls nil nil cont)))
- (ir1-convert-aux-bindings start cont forms nil nil nil))))
+ (let ((*lexenv* (process-decls decls nil nil cont)))
+ ;;; MNA: locally patch - #'ir1-convert-progn-body gets called anyway!
+ (ir1-convert-progn-body start cont forms))))
\f
;;;; FLET and LABELS
(ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
(when sb!xc:*compile-print*
- (compiler-mumble "converted ~S~%" name))))
+ ;; MNA compiler message patch
+ (compiler-mumble "~&; converted ~S~%" name))))
(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
start cont
(ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
(when sb!xc:*compile-print*
- (compiler-mumble "converted ~S~%" name))))
+ ;; MNA compiler message patch
+ (compiler-mumble "~&; converted ~S~%" name))))
;;; Update the global environment to correspond to the new definition.
(def-ir1-translator %defconstant ((name value doc) start cont
;; FIXME: ANSI says EQL, not EQUALP. Perhaps make a special
;; variant of this warning for the case where they're EQUALP,
;; since people seem to be confused about this.
- (unless (equalp newval (info :variable :constant-value name))
+
+ ;; MNA: re-defconstant patch
+ (when (or (and (listp newval)
+ (or (null (list-length newval))
+ (not (tree-equal newval
+ (info :variable
+ :constant-value name)
+ :test #'equalp))))
+ (not (equalp newval (info :variable
+ :constant-value name))))
(compiler-warning "redefining constant ~S as:~% ~S" name newval)))
(:global)
(t
,@(when save-expansion `(',save-expansion)))))
(when sb!xc:*compile-print*
- (compiler-mumble "converted ~S~%" name))))))
+ ;; MNA compiler message patch
+ (compiler-mumble "~&; converted ~S~%" name))))))
(do-uses (node old)
(delete-continuation-use node)
(add-continuation-use node new))
+ ;; MNA: Re: two obscure bugs in CMU CL
+ (dolist (lexenv-use (continuation-lexenv-uses old))
+ (setf (cadr lexenv-use) new))
(reoptimize-continuation new)
(values))
(*print-lines* *compiler-error-print-lines*)
(*print-pretty* pretty))
(if pretty
- (format nil " ~S~%" form)
+ ;;; MNA: compiler message patch
+ ;;; (format nil " ~S~%" form)
+ (format nil "~<~@; ~S~:>" (list form))
(prin1-to-string form))))
;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error
(cond ((= *last-message-count* 1)
(when terpri (terpri *error-output*)))
((> *last-message-count* 1)
- (format *error-output* "[Last message occurs ~D times.]~2%"
+ ;; MNA: compiler message patch
+ (format *error-output* "~&; [Last message occurs ~D times]~2%"
*last-message-count*)))
(setq *last-message-count* 0))
(when (pathnamep file)
(note-message-repeats)
(setq last nil)
- (format stream "~2&file: ~A~%" (namestring file))))
+ ;; MNA: compiler message patch
+ (format stream "~2&; file: ~A~%" (namestring file))))
(unless (and last
(equal in (compiler-error-context-context last)))
(note-message-repeats)
(setq last nil)
- (format stream "~2&in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" in))
+ ;; MNA: compiler message patch
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
+ (format stream "~%"))
+
(unless (and last
(string= form
(compiler-error-context-original-source last)))
(note-message-repeats)
(setq last nil)
- (write-string form stream))
+ ;; MNA: compiler message patch
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream " ~A" form))
+ (format stream "~&"))
(unless (and last
(equal enclosing
(when enclosing
(note-message-repeats)
(setq last nil)
- (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
+ ;; MNA: compiler message patch
+ (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
(unless (and last
(equal source (compiler-error-context-source last)))
(when source
(note-message-repeats)
(dolist (src source)
- (write-line "==>" stream)
- (write-string src stream))))))
+ ;; MNA: compiler message patch
+ (format stream "~&")
+ (write-string "; ==>" stream)
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (write-string src stream)))))))
(t
+ (format stream "~&")
(note-message-repeats)
(setq *last-format-string* nil)
- (format stream "~2&")))
+ (format stream "~&")))
(setq *last-error-context* context)
(let ((*print-level* *compiler-error-print-level*)
(*print-length* *compiler-error-print-length*)
(*print-lines* *compiler-error-print-lines*))
- (format stream "~&~?~&" format-string format-args))))
+ ;; MNA: compiler message patch
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "~&~?" format-string format-args))
+ (format stream "~&"))))
(incf *last-message-count*)
(values))
;;; Mumble conditional on *COMPILE-PROGRESS*.
(defun maybe-mumble (&rest foo)
(when *compile-progress*
- (apply #'compiler-mumble foo)))
+ ;; MNA: compiler message patch
+ (compiler-mumble "~&")
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+ (apply #'compiler-mumble foo))))
(deftype object () '(or fasl-file core-object null))
(zerop *compiler-warning-count*)
(zerop *compiler-style-warning-count*)
(zerop *compiler-note-count*)))
+ ;; MNA: compiler message patch
+ (format *error-output* "~&")
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
(compiler-mumble
- "~2&compilation unit ~:[finished~;aborted~]~
+ "compilation unit ~:[finished~;aborted~]~
~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~
~[~:;~:*~& caught ~D ERROR condition~:P~]~
~[~:;~:*~& caught ~D WARNING condition~:P~]~
~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~
- ~[~:;~:*~& printed ~D note~:P~]~2%"
+ ~[~:;~:*~& printed ~D note~:P~]"
abort-p
*aborted-compilation-unit-count*
*compiler-error-count*
*compiler-warning-count*
*compiler-style-warning-count*
- *compiler-note-count*)))
+ *compiler-note-count*))))
;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
(return nil)))))))
(when sb!xc:*compile-print*
- (compiler-mumble "~&~:[~;byte ~]compiling ~A: "
+ ;; MNA: compiler message patch
+ (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: "
*byte-compiling*
(component-name component)))
(compiler-error "bad FILE-COMMENT form: ~S" form))
(let ((file (first (source-info-current-file *source-info*))))
(cond ((file-info-comment file)
- (compiler-warning "ignoring extra file comment:~% ~S" form))
+ ;; MNA: compiler message patch
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+ (compiler-warning "Ignoring extra file comment:~% ~S." form)))
(t
(let ((comment (coerce (second form) 'simple-string)))
(setf (file-info-comment file) comment)
(when sb!xc:*compile-verbose*
- (compiler-mumble "~&FILE-COMMENT: ~A~2&" comment)))))))
+ ;; MNA: compiler message patch
+ (compiler-mumble "~&; FILE-COMMENT: ~A~2&" comment)))))))
;;; Force any pending top-level forms to be compiled and dumped so that they
;;; will be evaluated in the correct package environment. Dump the form to be
(*compiler-error-bailout*
#'(lambda ()
(compiler-mumble
- "~2&fatal error, aborting compilation~%")
+ ;; MNA: compiler message patch
+ "~2&; fatal error, aborting compilation~%")
(return-from sub-compile-file (values nil t t))))
(*current-path* nil)
(*last-source-context* nil)
(defun start-error-output (source-info)
(declare (type source-info source-info))
(dolist (x (source-info-files source-info))
- (compiler-mumble "compiling file ~S (written ~A):~%"
+ ;; MNA: compiler message patch
+ (compiler-mumble "~&; compiling file ~S (written ~A):~%"
(namestring (file-info-name x))
(sb!int:format-universal-time nil
(file-info-write-date x)
:style :government
:print-weekday nil
:print-timezone nil)))
- (compiler-mumble "~%")
(values))
+
(defun finish-error-output (source-info won)
(declare (type source-info source-info))
- (compiler-mumble "~&compilation ~:[aborted after~;finished in~] ~A~&"
+ ;; MNA: compiler message patch
+ (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
won
(elapsed-time-to-string
(- (get-universal-time)
(close-fasl-file fasl-file (not compile-won))
(setq output-file-name (pathname (fasl-file-stream fasl-file)))
(when (and compile-won sb!xc:*compile-verbose*)
- (compiler-mumble "~2&~A written~%" (namestring output-file-name))))
+ ;; MNA: compiler message patch
+ (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
(when sb!xc:*compile-verbose*
(finish-error-output source-info compile-won)))
;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor.
(%type-check t :type (member t nil :deleted :no-check :error))
;; Something or other that the back end annotates this continuation with.
- (info nil))
+
+ ;; MNA: Re: two obscure bugs in CMU CL
+ (info nil)
+ ;;
+ ;; Uses of this continuation in the lexical environment. They are recorded
+ ;; so that when one continuation is substituted for another the environment
+ ;; may be updated properly.
+ ;; MNAFIX
+ (lexenv-uses nil :type list)
+)
+
(def!method print-object ((x continuation) stream)
(print-unreadable-object (x stream :type t :identity t)))
`(cdr ,(frob (1- n))))))
(frob n))))
\f
+;;; MNA: cons compound-type patch
+;;; FIXIT: all commented out
+
+; ;;;; CONS assessor derive type optimizers.
+
+; (defoptimizer (car derive-type) ((cons))
+; (let ((type (continuation-type cons)))
+; (cond ((eq type (specifier-type 'null))
+; (specifier-type 'null))
+; ((cons-type-p type)
+; (cons-type-car-type type)))))
+
+; (defoptimizer (cdr derive-type) ((cons))
+; (let ((type (continuation-type cons)))
+; (cond ((eq type (specifier-type 'null))
+; (specifier-type 'null))
+; ((cons-type-p type)
+; (cons-type-cdr-type type)))))
+
+\f
;;;; arithmetic and numerology
(def-source-transform plusp (x) `(> ,x 0))
(frob logior)
(frob logxor))
+;; MNA: defoptimizer for integer-length patch
+(defoptimizer (integer-length derive-type) ((x))
+ (let ((x-type (continuation-type x)))
+ (when (and (numeric-type-p x-type)
+ (csubtypep x-type (specifier-type 'integer)))
+ ;; If the X is of type (INTEGER LO HI), then the integer-length
+ ;; of X is (INTEGER (min lo hi) (max lo hi), basically. Be
+ ;; careful about LO or HI being NIL, though. Also, if 0 is
+ ;; contained in X, the lower bound is obviously 0.
+ (flet ((null-or-min (a b)
+ (and a b (min (integer-length a)
+ (integer-length b))))
+ (null-or-max (a b)
+ (and a b (max (integer-length a)
+ (integer-length b)))))
+ (let* ((min (numeric-type-low x-type))
+ (max (numeric-type-high x-type))
+ (min-len (null-or-min min max))
+ (max-len (null-or-max min max)))
+ (when (ctypep 0 x-type)
+ (setf min-len 0))
+ (specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
) ; PROGN
\f
;;;; miscellaneous derive-type methods
(fresh-line stream)
+ ;; MNA: compiler message patch
+ (setf location-column-width (+ 2 location-column-width))
+ (princ "; " stream)
+
;; print the location
;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
;; usually avoids any consing]
(with-print-restrictions
(dolist (note (dstate-notes dstate))
(format stream "~Vt; " *disassem-note-column*)
+ ;; MNA: compiler message patch
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
(etypecase note
(string
(write-string note stream))
(function
- (funcall note stream)))
+ (funcall note stream))))
(terpri stream))
(fresh-line stream)
(setf (dstate-notes dstate) nil)))
(declare (type (or function symbol cons) object)
(type (or (member t) stream) stream)
(type (member t nil) use-labels))
+ (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
(let ((fun (compiled-function-or-lose object)))
(if (typep fun 'sb!kernel:byte-function)
(sb!c:disassem-byte-fun fun)
(disassemble-function (fun-self fun)
:stream stream
:use-labels use-labels)))
- (values))
+ (values)))
(defun disassemble-memory (address
length
`(typep ,n-obj ',(type-specifier x)))
types)))))))
+;;; MNA: cons compound-type patch
+;;; FIXIT: all commented out
+; ;;; Source-Transform-Cons-Typep
+; ;;;
+; ;;; If necessary recurse to check the cons type.
+; ;;;
+; (defun source-transform-cons-typep (object type)
+; (let* ((car-type (cons-type-car-type type))
+; (cdr-type (cons-type-cdr-type type)))
+; (let ((car-test-p (not (or (type= car-type *wild-type*)
+; (type= car-type (specifier-type t)))))
+; (cdr-test-p (not (or (type= cdr-type *wild-type*)
+; (type= cdr-type (specifier-type t))))))
+; (if (and (not car-test-p) (not cdr-test-p))
+; `(consp ,object)
+; (once-only ((n-obj object))
+; `(and (consp ,n-obj)
+; ,@(if car-test-p
+; `((typep (car ,n-obj)
+; ',(type-specifier car-type))))
+; ,@(if cdr-test-p
+; `((typep (cdr ,n-obj)
+; ',(type-specifier cdr-type))))))))))
+
;;; Return the predicate and type from the most specific entry in
;;; *TYPE-PREDICATES* that is a supertype of TYPE.
(defun find-supertype-predicate (type)
`(%instance-typep ,object ,spec))
(array-type
(source-transform-array-typep object type))
+ ;; MNA: cons compound-type patch
+ ;; FIXIT: all commented
+; (cons-type
+; (source-transform-cons-typep object type))
(t nil)))
`(%typep ,object ,spec)))
(values nil t)))
(cadar var))
(values (make-keyword (car var))
(car var)))
- `((,key (get-key-arg1 ,keyword ,args-tail))
+ ;; MNA: non-self-eval-keyword patch
+ `((,key (get-key-arg1 ',keyword ,args-tail))
(,variable (if (consp ,key)
(car ,key)
,(cadr var))))))
(cadar var))
(values (make-keyword (car var))
(car var)))
- `((,key (get-key-arg1 ,keyword ,args-tail))
+ ;; MNA: non-self-eval-keyword patch
+ `((,key (get-key-arg1 ',keyword ,args-tail))
(,(caddr var) ,key)
(,variable (if (consp ,key)
(car ,key)
* seems to be no point in doing that, since we're just
* going to lose(..) anyway. */
fake_foreign_function_call(context);
- lose("%%primitive halt called; the party is over.");
+ lose("%%PRIMITIVE HALT called; the party is over.");
case trap_Error:
case trap_Cerror:
(cl:in-package :cl-user)
-;;; Exercise a compiler bug by (crashing the compiler).
+;;; Exercise a compiler bug (by crashing the compiler).
;;;
;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
;;; (2000-09-06 on cmucl-imp).
(fun1)
nil))))
+
+;;; Exercise a compiler bug (by crashing the compiler).
+;;;
+;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
+;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
+(funcall (compile nil
+ '(lambda (x)
+ (or (integerp x)
+ (block used-by-some-y?
+ (flet ((frob (stk)
+ (dolist (y stk)
+ (unless (rejected? y)
+ (return-from used-by-some-y? t)))))
+ (declare (inline frob))
+ (frob (rstk x))
+ (frob (mrstk x)))
+ nil))))
+ 13)
;;; 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.8.5"
+"0.6.8.6"
projects / sbcl.git / commitdiff