minor tweaks while hunting bug 138...
...gave PREV-LINK a painfully explicitly mnemonic name
...s/with-ir1-environment/with-belated-ir1-environment/
to do without explicit wildcards, e.g. (DIRECTORY "/tmp/"),
now needs explicit wildcards, e.g. (DIRECTORY "/tmp/*.*").
+140:
+ (reported by Alexey Dejneka sbcl-devel 2002-01-03)
+
+ SUBTYPEP does not work well with redefined classes:
+ ---
+ * (defclass a () ())
+ #<STANDARD-CLASS A>
+ * (defclass b () ())
+ #<STANDARD-CLASS B>
+ * (subtypep 'b 'a)
+ NIL
+ T
+ * (defclass b (a) ())
+ #<STANDARD-CLASS B>
+ * (subtypep 'b 'a)
+ T
+ T
+ * (defclass b () ())
+ #<STANDARD-CLASS B>
+
+ ;;; And now...
+ * (subtypep 'b 'a)
+ T
+ T
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
;;; guts of complex systems anyway, I replaced it too.)
(defmacro aver (expr)
`(unless ,expr
- (%failed-aver ,(let ((*package* (find-package :keyword)))
- (format nil "~S" expr)))))
+ (%failed-aver ,(format nil "~A" expr))))
(defun %failed-aver (expr-as-string)
(error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
(defmacro enforce-type (value type)
;;; passes them on to CONT.
(defun convert-type-check (cont types)
(declare (type continuation cont) (type list types))
- (with-ir1-environment (continuation-dest cont)
+ (with-belated-ir1-environment (continuation-dest cont)
;; Ensuring that CONT starts a block lets us freely manipulate its uses.
(ensure-block-start cont)
;; said that somewhere in here we
;; Set the new block's start and end cleanups to the *start*
;; cleanup of PREV's block. This overrides the incorrect
- ;; default from WITH-IR1-ENVIRONMENT.
+ ;; default from WITH-BELATED-IR1-ENVIRONMENT.
;; Unfortunately I can't find any code which corresponds to this.
;; Perhaps it was a stale comment? Or perhaps I just don't
;; understand.. -- WHN 19990521
;; initial component tail (due NIL function terminated blocks)
;; are moved to the appropriate new component tail.
(dolist (toplevel-lambda toplevel-lambdas)
- (let* ((block (lambda-block toplevel-lambda))
- (old-component (block-component block))
+ (let* ((old-component (lambda-component toplevel-lambda))
(old-component-lambdas (component-lambdas old-component))
(new-component nil))
(aver (member toplevel-lambda old-component-lambdas))
:alternative else-block)))
(setf (continuation-dest pred) node)
(ir1-convert start pred test)
- (prev-link node pred)
+ (link-node-to-previous-continuation node pred)
(use-continuation node dummy-cont)
(let ((start-block (continuation-block pred)))
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
+ (link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(let* ((env-entry (list entry cont))
(push exit (entry-exits entry))
(setf (continuation-dest value-cont) exit)
(ir1-convert start value-cont value)
- (prev-link exit value-cont)
+ (link-node-to-previous-continuation exit value-cont)
(let ((home-lambda (continuation-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
+ (link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(collect ((tags)
(entry (first found))
(exit (make-exit :entry entry)))
(push exit (entry-exits entry))
- (prev-link exit start)
+ (link-node-to-previous-continuation exit start)
(let ((home-lambda (continuation-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
(setf (continuation-dest dest) res)
(setf (leaf-ever-used var) t)
(push res (basic-var-sets var))
- (prev-link res dest)
+ (link-node-to-previous-continuation res dest)
(use-continuation res cont))))
\f
;;;; CATCH, THROW and UNWIND-PROTECT
(ir1-convert this-start this-cont arg)
(setq this-start this-cont)
(arg-conts this-cont)))
- (prev-link node this-start)
+ (link-node-to-previous-continuation node this-start)
(use-continuation node cont)
(setf (basic-combination-args node) (arg-conts))))))
;;; become unreachable, resulting in a spurious note.
(defun convert-if-if (use node)
(declare (type node use) (type cif node))
- (with-ir1-environment node
+ (with-belated-ir1-environment node
(let* ((block (node-block node))
(test (if-test node))
(cblock (if-consequent node))
:consequent cblock
:alternative ablock))
(new-block (continuation-starts-block new-cont)))
- (prev-link new-node new-cont)
+ (link-node-to-previous-continuation new-node new-cont)
(setf (continuation-dest new-cont) new-node)
(add-continuation-use new-node dummy-cont)
(setf (block-last new-block) new-node)
(change-ref-leaf ref res))))
(if ir1-p
(frob)
- (with-ir1-environment call
+ (with-belated-ir1-environment call
(frob)
(locall-analyze-component *current-component*))))
;;; integrated into the control flow.
(defun transform-call (node res)
(declare (type combination node) (list res))
- (with-ir1-environment node
+ (with-belated-ir1-environment node
(let ((new-fun (ir1-convert-inline-lambda
res
:debug-name "<something inlined in TRANSFORM-CALL>"))
min)
(t nil))))
(when count
- (with-ir1-environment node
+ (with-belated-ir1-environment node
(let* ((dums (make-gensym-list count))
(ignore (gensym))
(fun (ir1-convert-lambda
(mapc #'flush-dest (subseq vals nvars))
(setq vals (subseq vals 0 nvars)))
((< nvals nvars)
- (with-ir1-environment use
+ (with-belated-ir1-environment use
(let ((node-prev (node-prev use)))
(setf (node-prev use) nil)
(setf (continuation-next node-prev) nil)
do (reference-constant prev cont nil)
(res cont))
(setq vals (res)))
- (prev-link use (car (last vals)))))))
+ (link-node-to-previous-continuation use
+ (car (last vals)))))))
(setf (combination-args use) vals)
(flush-dest (combination-fun use))
(let ((fun-cont (basic-combination-fun call)))
;;; This function sets up the back link between the node and the
;;; continuation which continues at it.
-#!-sb-fluid (declaim (inline prev-link))
-(defun prev-link (node cont)
+(defun link-node-to-previous-continuation (node cont)
(declare (type node node) (type continuation cont))
(aver (not (continuation-next cont)))
(setf (continuation-next cont) node)
(let* ((leaf (find-constant value))
(res (make-ref (leaf-type leaf) leaf)))
(push res (leaf-refs leaf))
- (prev-link res start)
+ (link-node-to-previous-continuation res start)
(use-continuation res cont)))
(values)))
leaf)))
(push res (leaf-refs leaf))
(setf (leaf-ever-used leaf) t)
- (prev-link res start)
+ (link-node-to-previous-continuation res start)
(use-continuation res cont)))
;;; Convert a reference to a symbolic constant or variable. If the
(ir1-convert this-start this-cont arg)
(setq this-start this-cont)
(arg-conts this-cont)))
- (prev-link node this-start)
+ (link-node-to-previous-continuation node this-start)
(use-continuation node cont)
(setf (combination-args node) (arg-conts))))
node))
(let ((cont1 (make-continuation))
(cont2 (make-continuation)))
(continuation-starts-block cont1)
- (prev-link bind cont1)
+ (link-node-to-previous-continuation bind cont1)
(use-continuation bind cont2)
(ir1-convert-special-bindings cont2 result body aux-vars aux-vals
(svars)))
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
(setf (block-last block) return)
- (prev-link return result)
+ (link-node-to-previous-continuation return result)
(use-continuation return dummy))
(link-blocks block (component-tail *current-component*))))))
(declare (type cblock block1 block2) (type node node)
(type (or cleanup null) cleanup))
(setf (component-reanalyze (block-component block1)) t)
- (with-ir1-environment node
+ (with-belated-ir1-environment node
(let* ((start (make-continuation))
(block (continuation-starts-block start))
(cont (make-continuation))
(aver (and succ (null (cdr succ))))
(cond
((member block succ)
- (with-ir1-environment node
+ (with-belated-ir1-environment node
(let ((exit (make-exit))
(dummy (make-continuation)))
(setf (continuation-next prev) nil)
- (prev-link exit prev)
+ (link-node-to-previous-continuation exit prev)
(add-continuation-use exit dummy)
(setf (block-last block) exit)))
(setf (node-prev node) nil)
(defun make-external-entry-point (fun)
(declare (type functional fun))
(aver (not (functional-entry-fun fun)))
- (with-ir1-environment (lambda-bind (main-entry fun))
+ (with-belated-ir1-environment (lambda-bind (main-entry fun))
(let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
:debug-name (debug-namify
"XEP for ~A"
(t
;; Fix/check FUN's relationship to COMPONENT-LAMDBAS.
(cond ((not (lambda-p fun))
- ;; Since FUN's not a LAMBDA, this doesn't apply: no-op.
+ ;; Since FUN isn't a LAMBDA, this doesn't apply: no-op.
(values))
(new-fun ; FUN came from NEW-FUNS, hence is new.
;; FUN becomes part of COMPONENT-LAMBDAS now.
;; expansions of local functions might in
;; COMPONENT-LAMBDAS?)
(values))
- (t ; FUN's old.
+ (t ; FUN is old.
;; FUN should be in COMPONENT-LAMBDAS already.
(aver (member fun (component-lambdas component)))))
(locall-analyze-fun-1 fun)
(and (>= speed space) (>= speed compilation-speed)))
(not (eq (functional-kind (node-home-lambda call)) :external))
(inline-expansion-ok call))
- (with-ir1-environment call
+ (with-belated-ir1-environment call
(let* ((*lexenv* (functional-lexenv fun))
(won nil)
(res (catch 'local-call-lossage
(declare (list vars ignores args) (type ref ref) (type combination call)
(type clambda entry))
(let ((new-fun
- (with-ir1-environment call
+ (with-belated-ir1-environment call
(ir1-convert-lambda
`(lambda ,vars
(declare (ignorable . ,ignores))
;;; after the main conversion pass has finished.
;;;
;;; The lexical environment is presumably already null...
-(defmacro with-ir1-environment (node &rest forms)
+(defmacro with-belated-ir1-environment (node &rest forms)
(let ((n-node (gensym)))
`(let* ((,n-node ,node)
(*current-component* (block-component (node-block ,n-node)))
,@forms)))
;;; Bind the hashtables used for keeping track of global variables,
-;;; functions, &c. Also establish condition handlers.
+;;; functions, etc. Also establish condition handlers.
(defmacro with-ir1-namespace (&body forms)
`(let ((*free-variables* (make-hash-table :test 'eq))
(*free-functions* (make-hash-table :test 'equal))
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.112"
+"0.pre7.113"
projects / sbcl.git / commitdiff