(setf (car args) nil)))
(values))
+(defun recognize-dynamic-extent-lvars (call fun)
+ (declare (type combination call) (type clambda fun))
+ (loop for arg in (basic-combination-args call)
+ and var in (lambda-vars fun)
+ when (and arg
+ (lambda-var-dynamic-extent var)
+ (not (lvar-dynamic-extent arg)))
+ collect arg into dx-lvars
+ and do (let ((use (lvar-uses arg)))
+ ;; Stack analysis wants DX value generators to end
+ ;; their blocks. Uses of mupltiple used LVARs already
+ ;; end their blocks, so we just need to process
+ ;; used-once LVARs.
+ (when (node-p use)
+ (node-ends-block use)))
+ finally (when dx-lvars
+ (binding* ((before-ctran (node-prev call))
+ (nil (ensure-block-start before-ctran))
+ (block (ctran-block before-ctran))
+ (new-call-ctran (make-ctran :kind :inside-block
+ :next call
+ :block block))
+ (entry (with-ir1-environment-from-node call
+ (make-entry :prev before-ctran
+ :next new-call-ctran)))
+ (cleanup (make-cleanup :kind :dynamic-extent
+ :mess-up entry
+ :info dx-lvars)))
+ (setf (node-prev call) new-call-ctran)
+ (setf (ctran-next before-ctran) entry)
+ (setf (ctran-use new-call-ctran) entry)
+ (setf (entry-cleanup entry) cleanup)
+ (setf (node-lexenv call)
+ (make-lexenv :default (node-lexenv call)
+ :cleanup cleanup))
+ (push entry (lambda-entries (node-home-lambda entry)))
+ (dolist (lvar dx-lvars)
+ (setf (lvar-dynamic-extent lvar) cleanup)))))
+ (values))
+
;;; This function handles merging the tail sets if CALL is potentially
;;; tail-recursive, and is a call to a function with a different
;;; TAIL-SET than CALL's FUN. This must be called whenever we alter
(when arg
(flush-lvar-externally-checkable-type arg))))
(pushnew fun (lambda-calls-or-closes (node-home-lambda call)))
+ (recognize-dynamic-extent-lvars call fun)
(merge-tail-sets call fun)
(change-ref-leaf ref fun)
(values))
(with-ir1-environment-from-node (lambda-bind (main-entry fun))
(let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
:debug-name (debug-namify
- "XEP for ~A"
+ "XEP for "
(leaf-debug-name fun)))))
(setf (functional-kind res) :external
(leaf-ever-used res) t
(return))
(let ((kind (functional-kind functional)))
(cond ((or (functional-somewhat-letlike-p functional)
- (eql kind :deleted))
+ (memq kind '(:deleted :zombie)))
(values)) ; nothing to do
((and (null (leaf-refs functional)) (eq kind nil)
(not (functional-entry-fun functional)))
(ir1-convert-lambda
(functional-inline-expansion original-functional)
:debug-name (debug-namify
- "local inline ~A"
+ "local inline "
(leaf-debug-name
original-functional)))))))
(cond (losing-local-functional
(let ((*compiler-error-context* call))
(compiler-notify "couldn't inline expand because expansion ~
- calls this LET-converted local function:~
- ~% ~S"
+ calls this LET-converted local function:~
+ ~% ~S"
(leaf-debug-name losing-local-functional)))
(loop for block = (block-next pred) then (block-next block)
until (eq block end)
(cond ((= n-call-args nargs)
(convert-call ref call fun))
(t
- ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
- ;; Compiler" that calling a function with "the wrong number of
- ;; arguments" be only a STYLE-ERROR. I think, though, that this
- ;; should only apply when the number of arguments is inferred
- ;; from a previous definition. If the number of arguments
- ;; is DECLAIMed, surely calling with the wrong number is a
- ;; real WARNING. As long as SBCL continues to use CMU CL's
- ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here,
- ;; but as long as we continue to use that policy, that's the
- ;; not our biggest problem.:-| When we fix that policy, this
- ;; should come back into compliance. (So fix that policy!)
- ;; ..but..
- ;; FIXME, continued: Except that section "3.2.2.3 Semantic
- ;; Constraints" says that if it's within the same file, it's
- ;; wrong. And we're in locall.lisp here, so it's probably
- ;; (haven't checked this..) a call to something in the same
- ;; file. So maybe it deserves a full warning anyway.
- (compiler-warn
+ (warn
+ 'local-argument-mismatch
+ :format-control
"function called with ~R argument~:P, but wants exactly ~R"
- n-call-args nargs)
+ :format-arguments (list n-call-args nargs))
(setf (basic-combination-kind call) :error)))))
\f
;;;; &OPTIONAL, &MORE and &KEYWORD calls
(max-args (optional-dispatch-max-args fun))
(call-args (length (combination-args call))))
(cond ((< call-args min-args)
- ;; FIXME: See FIXME note at the previous
- ;; wrong-number-of-arguments warnings in this file.
- (compiler-warn
+ (warn
+ 'local-argument-mismatch
+ :format-control
"function called with ~R argument~:P, but wants at least ~R"
- call-args min-args)
+ :format-arguments (list call-args min-args))
(setf (basic-combination-kind call) :error))
((<= call-args max-args)
(convert-call ref call
((optional-dispatch-more-entry fun)
(convert-more-call ref call fun))
(t
- ;; FIXME: See FIXME note at the previous
- ;; wrong-number-of-arguments warnings in this file.
- (compiler-warn
+ (warn
+ 'local-argument-mismatch
+ :format-control
"function called with ~R argument~:P, but wants at most ~R"
- call-args max-args)
+ :format-arguments
+ (list call-args max-args))
(setf (basic-combination-kind call) :error))))
(values))
`(lambda ,vars
(declare (ignorable ,@ignores))
(%funcall ,entry ,@args))
- :debug-name (debug-namify "hairy function entry ~S"
+ :debug-name (debug-namify "hairy function entry "
(lvar-fun-name
(basic-combination-fun call)))))))
(convert-call ref call new-fun)
(when (optional-dispatch-keyp fun)
(when (oddp (length more))
(compiler-warn "function called with odd number of ~
- arguments in keyword portion")
-
+ arguments in keyword portion")
(setf (basic-combination-kind call) :error)
(return-from convert-more-call))
(progn
(ignores dummy val)
(unless (eq name :allow-other-keys)
- (setq loser name))))
+ (setq loser (list name)))))
(let ((info (lambda-var-arg-info var)))
(when (eq (arg-info-key info) name)
(ignores dummy)
(when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
(compiler-warn "function called with unknown argument keyword ~S"
- loser)
+ (car loser))
(setf (basic-combination-kind call) :error)
(return-from convert-more-call)))
;; FIXME: Replace the call with unsafe CAST. -- APD, 2003-01-26
(do-uses (use result)
(derive-node-type use call-type)))
- (substitute-lvar-uses lvar result)))
+ (substitute-lvar-uses lvar result
+ (and lvar (eq (lvar-uses lvar) call)))))
(values))
;;; We are converting FUN to be a LET when the call is in a non-tail
projects / sbcl.git / blobdiff