\f
;;;; operations on DEBUG-FUNCTIONs
+;;; Execute the forms in a context with block-var bound to each
+;;; debug-block in debug-function successively. Result is an optional
+;;; form to execute for return values, and DO-DEBUG-FUNCTION-BLOCKS
+;;; returns nil if there is no result form. This signals a
+;;; no-debug-blocks condition when the debug-function lacks
+;;; debug-block information.
(defmacro do-debug-function-blocks ((block-var debug-function &optional result)
&body body)
- #!+sb-doc
- "Executes the forms in a context with block-var bound to each debug-block in
- debug-function successively. Result is an optional form to execute for
- return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no
- result form. This signals a no-debug-blocks condition when the
- debug-function lacks debug-block information."
(let ((blocks (gensym))
(i (gensym)))
`(let ((,blocks (debug-function-debug-blocks ,debug-function)))
(let ((,block-var (svref ,blocks ,i)))
,@body)))))
+;;; Execute body in a context with var bound to each debug-var in
+;;; debug-function. This returns the value of executing result (defaults to
+;;; nil). This may iterate over only some of debug-function's variables or none
+;;; depending on debug policy; for example, possibly the compilation only
+;;; preserved argument information.
(defmacro do-debug-function-variables ((var debug-function &optional result)
&body body)
- #!+sb-doc
- "Executes body in a context with var bound to each debug-var in
- debug-function. This returns the value of executing result (defaults to
- nil). This may iterate over only some of debug-function's variables or none
- depending on debug policy; for example, possibly the compilation only
- preserved argument information."
(let ((vars (gensym))
(i (gensym)))
`(let ((,vars (debug-function-debug-vars ,debug-function)))
,@body))
,result))))
+;;; Return the Common Lisp function associated with the debug-function. This
+;;; returns nil if the function is unavailable or is non-existent as a user
+;;; callable function object.
(defun debug-function-function (debug-function)
- #!+sb-doc
- "Returns the Common Lisp function associated with the debug-function. This
- returns nil if the function is unavailable or is non-existent as a user
- callable function object."
(let ((cached-value (debug-function-%function debug-function)))
(if (eq cached-value :unparsed)
(setf (debug-function-%function debug-function)
(bogus-debug-function nil)))
cached-value)))
+;;; Return the name of the function represented by debug-function. This may
+;;; be a string or a cons; do not assume it is a symbol.
(defun debug-function-name (debug-function)
- #!+sb-doc
- "Returns the name of the function represented by debug-function. This may
- be a string or a cons; do not assume it is a symbol."
(etypecase debug-function
(compiled-debug-function
(sb!c::compiled-debug-function-name
(bogus-debug-function
(bogus-debug-function-%name debug-function))))
+;;; Return a debug-function that represents debug information for function.
(defun function-debug-function (fun)
- #!+sb-doc
- "Returns a debug-function that represents debug information for function."
(case (get-type fun)
(#.sb!vm:closure-header-type
(function-debug-function (%closure-function fun)))
(get-header-data component))
sb!vm:word-bytes)))))))
+;;; Return the kind of the function, which is one of :OPTIONAL,
+;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL.
(defun debug-function-kind (debug-function)
- #!+sb-doc
- "Returns the kind of the function which is one of :OPTIONAL, :EXTERNAL,
- :TOP-level, :CLEANUP, or NIL."
;; FIXME: This "is one of" information should become part of the function
;; declamation, not just a doc string
(etypecase debug-function
(bogus-debug-function
nil)))
+;;; Is there any variable information for DEBUG-FUNCTION?
(defun debug-var-info-available (debug-function)
- #!+sb-doc
- "Is there any variable information for DEBUG-FUNCTION?"
(not (not (debug-function-debug-vars debug-function))))
+;;; Return a list of debug-vars in debug-function having the same name
+;;; and package as symbol. If symbol is uninterned, then this returns
+;;; a list of debug-vars without package names and with the same name
+;;; as symbol. The result of this function is limited to the
+;;; availability of variable information in debug-function; for
+;;; example, possibly DEBUG-FUNCTION only knows about its arguments.
(defun debug-function-symbol-variables (debug-function symbol)
- #!+sb-doc
- "Returns a list of debug-vars in debug-function having the same name
- and package as symbol. If symbol is uninterned, then this returns a list of
- debug-vars without package names and with the same name as symbol. The
- result of this function is limited to the availability of variable
- information in debug-function; for example, possibly debug-function only
- knows about its arguments."
(let ((vars (ambiguous-debug-vars debug-function (symbol-name symbol)))
(package (and (symbol-package symbol)
(package-name (symbol-package symbol)))))
(stringp (debug-var-package-name var))))
vars)))
+;;; Return a list of debug-vars in debug-function whose names contain
+;;; name-prefix-string as an intial substring. The result of this
+;;; function is limited to the availability of variable information in
+;;; debug-function; for example, possibly debug-function only knows
+;;; about its arguments.
(defun ambiguous-debug-vars (debug-function name-prefix-string)
- "Returns a list of debug-vars in debug-function whose names contain
- name-prefix-string as an intial substring. The result of this function is
- limited to the availability of variable information in debug-function; for
- example, possibly debug-function only knows about its arguments."
(declare (simple-string name-prefix-string))
(let ((variables (debug-function-debug-vars debug-function)))
(declare (type (or null simple-vector) variables))
(string= x y :end1 name-len :end2 name-len))))
:end (or end (length variables)))))
+;;; Return a list representing the lambda-list for DEBUG-FUNCTION. The
+;;; list has the following structure:
+;;; (required-var1 required-var2
+;;; ...
+;;; (:optional var3 suppliedp-var4)
+;;; (:optional var5)
+;;; ...
+;;; (:rest var6) (:rest var7)
+;;; ...
+;;; (:keyword keyword-symbol var8 suppliedp-var9)
+;;; (:keyword keyword-symbol var10)
+;;; ...
+;;; )
+;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
+;;; it is unreferenced in DEBUG-FUNCTION. This signals a
+;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
+;;; information.
(defun debug-function-lambda-list (debug-function)
#!+sb-doc
- "Returns a list representing the lambda-list for debug-function. The list
- has the following structure:
- (required-var1 required-var2
- ...
- (:optional var3 suppliedp-var4)
- (:optional var5)
- ...
- (:rest var6) (:rest var7)
- ...
- (:keyword keyword-symbol var8 suppliedp-var9)
- (:keyword keyword-symbol var10)
- ...
- )
- Each VARi is a DEBUG-VAR; however it may be the symbol :deleted it
- is unreferenced in debug-function. This signals a lambda-list-unavailable
- condition when there is no argument list information."
(etypecase debug-function
(compiled-debug-function
(compiled-debug-function-lambda-list debug-function))
;;; call FUN (with no arguments).
;;;
;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top-level form processing code.
+;;; shared by the special-case top-level MACROLET processing code.
(defun funcall-in-macrolet-lexenv (definitions fun)
(declare (type list definitions) (type function fun))
- (let ((whole (gensym "WHOLE"))
- (environment (gensym "ENVIRONMENT")))
- (collect ((new-fenv))
- (dolist (def definitions)
- (let ((name (first def))
- (arglist (second def))
- (body (cddr def)))
- (unless (symbolp name)
- (compiler-error "The local macro name ~S is not a symbol." name))
- (when (< (length def) 2)
- (compiler-error
- "The list ~S is too short to be a legal local macro definition."
- name))
- (multiple-value-bind (body local-decs)
- (parse-defmacro arglist whole body name 'macrolet
- :environment environment)
- (new-fenv `(,(first def) macro .
- ,(coerce `(lambda (,whole ,environment)
- ,@local-decs (block ,name ,body))
- 'function))))))
- (let ((*lexenv* (make-lexenv :functions (new-fenv))))
- (funcall fun))))
+ (let* ((whole (gensym "WHOLE"))
+ (environment (gensym "ENVIRONMENT"))
+ (processed-definitions
+ (mapcar (lambda (definition)
+ (unless (list-of-length-at-least-p definition 2)
+ (compiler-error
+ "The list ~S is too short to be a legal ~
+ local macro definition."
+ definition))
+ (destructuring-bind (name arglist &body body) definition
+ (unless (symbolp name)
+ (compiler-error
+ "The local macro name ~S is not a symbol." name))
+ (multiple-value-bind (body local-decls)
+ (parse-defmacro arglist whole body name 'macrolet
+ :environment environment)
+ `(,name macro .
+ ,(compile nil
+ `(lambda (,whole ,environment)
+ ,@local-decls
+ (block ,name ,body)))))))
+ definitions))
+ (*lexenv* (make-lexenv :functions processed-definitions)))
+ (unless (= (length definitions)
+ (length (remove-duplicates definitions :key #'first)))
+ (compiler-style-warning
+ "duplicate macro names in MACROLET ~S" definitions))
+ (funcall fun))
(values))
(def-ir1-translator macrolet ((definitions &rest body) start cont)
;;; then call FUN (with no arguments).
;;;
;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top-level form processing code.
+;;; shared by the special-case top-level SYMBOL-MACROLET processing code.
(defun funcall-in-symbol-macrolet-lexenv (macrobindings fun)
(declare (type list macrobindings) (type function fun))
(let ((processed-macrobindings
(destructuring-bind (name expansion) macrobinding
(unless (symbolp name)
(compiler-error
- "The symbol macro name ~S is not a symbol." name))
+ "The local symbol macro name ~S is not a symbol."
+ name))
`(,name . (MACRO . ,expansion))))
macrobindings)))
(unless (= (length macrobindings)
(length (remove-duplicates macrobindings :key #'first)))
(compiler-style-warning
- "duplicate names in SYMBOL-MACROLET ~S" macrobindings))
+ "duplicate symbol macro names in SYMBOL-MACROLET ~S" macrobindings))
(let ((*lexenv* (make-lexenv :variables processed-macrobindings)))
(funcall fun)))
(values))
projects / sbcl.git / commitdiff