Skip to content
Snippets Groups Projects
Commit 9139f087 authored by ram's avatar ram
Browse files

Changed REQUIRED-ARGUMENTS to recognize closures and funcallable instances, and

to print a warning if there is no arg count information (due to low DEBUG
level.)
parent 6aa44bff
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.3 1992/01/30 17:04:45 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.4 1992/02/02 23:43:02 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -39,11 +39,6 @@ ...@@ -39,11 +39,6 @@
;;;; Implementation dependent interfaces: ;;;; Implementation dependent interfaces:
#+(and cmu (not new-compiler))
(eval-when (compile eval)
(defmacro fdefinition (x)
`(lisp::careful-symbol-function ,x))
(defsetf fdefinition lisp::set-symbol-function-carefully))
(progn (progn
#-cmu #-cmu
...@@ -71,46 +66,38 @@ ...@@ -71,46 +66,38 @@
;;; is the number of required arguments, and the second is T iff there are any ;;; is the number of required arguments, and the second is T iff there are any
;;; non-required arguments (e.g. &optional, &rest, &key). ;;; non-required arguments (e.g. &optional, &rest, &key).
#+cmu #+cmu (progn
(progn (defun required-arguments-aux (name function)
#-new-compiler (let ((type (kernel:%function-header-type function)))
(defun required-arguments (name) (typecase type
(let ((function (symbol-function name))) (cons
(if (eql (system:%primitive get-type function) system:%function-type) (let* ((args (cadr type))
(let ((min (ldb system:%function-min-args-byte (pos (position-if
(system:%primitive header-ref function #'(lambda (x)
system:%function-min-args-slot))) (and (symbolp x)
(max (ldb system:%function-max-args-byte (let ((name (symbol-name x)))
(system:%primitive header-ref function (and (>= (length name) 1)
system:%function-max-args-slot))) (char= (schar name 0) #\&)))))
(rest (ldb system:%function-rest-arg-byte args)))
(system:%primitive header-ref function (if pos
system:%function-rest-arg-slot))) (values pos t)
(key (ldb system:%function-keyword-arg-byte (values (length args) nil))))
(system:%primitive (t
header-ref function (warn "No argument count information available for:~% ~S~@
system:%function-keyword-arg-slot)))) Allow for &rest arg consing."
(values min (or (/= min max) (/= rest 0) (/= key 0)))) name)
(values 0 t)))) (values 0 t)))))
#+new-compiler
(defun required-arguments (name) (defun required-arguments (name)
(let* ((function (fdefinition name))) (let* ((function (fdefinition name)))
(if (eql (kernel:get-type function) vm:function-header-type) (case (kernel:get-type function)
(let ((type (kernel:%function-header-type function))) (#.vm:function-header-type (required-arguments-aux name function))
(if (consp type) ((#.vm:closure-header-type #.vm:funcallable-instance-header-type)
(let* ((args (cadr type)) (required-arguments-aux name (kernel:%closure-function function)))
(pos (position-if (t
#'(lambda (x) (values 0 t)))))
(and (symbolp x)
(let ((name (symbol-name x))) ); #+cmu progn
(and (>= (length name) 1)
(char= (schar name 0) #\&)))))
args)))
(if pos
(values pos t)
(values (length args) nil)))
(values 0 t)))
(values 0 t)))))
#-cmu #-cmu
(progn (progn
...@@ -397,7 +384,7 @@ ...@@ -397,7 +384,7 @@
;;; within this profiled function. This factor is the total profiling overhead ;;; within this profiled function. This factor is the total profiling overhead
;;; *minus the internal overhead*. We don't subtract out the internal ;;; *minus the internal overhead*. We don't subtract out the internal
;;; overhead, since it was already subtracted when the nested profiled ;;; overhead, since it was already subtracted when the nested profiled
;;; functions subtracted their running time from the time for the encolsing ;;; functions subtracted their running time from the time for the enclosing
;;; function. ;;; function.
;;; ;;;
(defun compensate-time (calls time profile) (defun compensate-time (calls time profile)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment