Commit 984032b3 authored by Helmut Eller's avatar Helmut Eller

Even more long line breaking.

parent 65e073ce
......@@ -7,6 +7,19 @@
* ChangeLog:
* swank-cmucl.lisp:
* swank-lispworks.lisp:
* contrib/ChangeLog
* hyperspec.el
* metering.lisp
* swank-abcl.lisp
* swank-allegro.lisp
* swank-backend.lisp
* swank-clisp.lisp
* swank-corman.lisp
* swank-ecl.lisp
* swank-sbcl.lisp
* swank-scl.lisp
* swank-source-path-parser.lisp
* xref.lisp
2012-04-06 Stas Boukarev <stassats@gmail.com>
......
This diff is collapsed.
......@@ -100,7 +100,8 @@ If you copy the HyperSpec to another location, customize the variable
t stripped-symbol
'common-lisp-hyperspec-history)))))
(maplist (lambda (entry)
(browse-url (concat common-lisp-hyperspec-root "Body/" (car entry)))
(browse-url (concat common-lisp-hyperspec-root "Body/"
(car entry)))
(if (cdr entry)
(sleep-for 1.5)))
(let ((symbol (intern-soft
......@@ -140,7 +141,8 @@ If you copy the HyperSpec to another location, customize the variable
;;; 20020213 Edi Weitz
(if common-lisp-hyperspec-symbol-table
(let ((index-buffer (find-file-noselect common-lisp-hyperspec-symbol-table)))
(let ((index-buffer (find-file-noselect
common-lisp-hyperspec-symbol-table)))
(labels ((get-one-line ()
(prog1
(delete* ?\n (thing-at-point 'line))
......@@ -153,7 +155,8 @@ If you copy the HyperSpec to another location, customize the variable
(relative-url (get-one-line)))
(intern-clhs-symbol symbol-name
(subseq relative-url
(1+ (position ?\/ relative-url :from-end t)))))))))
(1+ (position ?\/ relative-url
:from-end t)))))))))
(mapc (lambda (entry) (intern-clhs-symbol (car entry) (cadr entry)))
'(("&allow-other-keys" "03_da.htm")
("&aux" "03_da.htm")
......@@ -1247,8 +1250,9 @@ If you copy the HyperSpec to another location, customize the variable
nil nil 'common-lisp-hyperspec-format-history)))))
(maplist (lambda (entry)
(browse-url (common-lisp-hyperspec-section (car entry))))
(let ((symbol (intern-soft character-name
common-lisp-hyperspec-format-characters)))
(let ((symbol (intern-soft
character-name
common-lisp-hyperspec-format-characters)))
(if (and symbol (boundp symbol))
(symbol-value symbol)
(error "The symbol `%s' is not defined in Common Lisp"
......@@ -1347,7 +1351,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
(defvar common-lisp-hyperspec-issuex-symbols (make-vector 67 0))
(if common-lisp-hyperspec-issuex-table
(let ((index-buffer (find-file-noselect common-lisp-hyperspec-issuex-table)))
(let ((index-buffer (find-file-noselect
common-lisp-hyperspec-issuex-table)))
(labels ((get-one-line ()
(prog1
(delete* ?\n (thing-at-point 'line))
......@@ -1360,7 +1365,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
common-lisp-hyperspec-issuex-symbols))
(relative-url (get-one-line)))
(set symbol (subseq relative-url
(1+ (position ?\/ relative-url :from-end t)))))))))
(1+ (position ?\/ relative-url
:from-end t)))))))))
(mapcar
(lambda (entry)
(let ((symbol (intern (car entry) common-lisp-hyperspec-issuex-symbols)))
......@@ -1466,7 +1472,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
("defconstant-special:no" "iss099.htm")
("defgeneric-declare:allow-multiple" "iss100.htm")
("define-compiler-macro:x3j13-nov89" "iss101.htm")
("define-condition-syntax:incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm")
("define-condition-syntax:\
incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm")
("define-method-combination-behavior:clarify" "iss103.htm")
("defining-macros-non-top-level:allow" "iss104.htm")
("defmacro-block-scope:excludes-bindings" "iss105.htm")
......@@ -1637,7 +1644,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
("pretty-print-interface" "iss270.htm")
("princ-readably:x3j13-dec-91" "iss271.htm")
("print-case-behavior:clarify" "iss272.htm")
("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" "iss273.htm")
("print-case-print-escape-interaction:vertical-bar-rule-no-upcase"
"iss273.htm")
("print-circle-shared:respect-print-circle" "iss274.htm")
("print-circle-structure:user-functions-work" "iss275.htm")
("print-readably-behavior:clarify" "iss276.htm")
......
......@@ -61,6 +61,7 @@
;;; Purely to cut down on stale code (e.g. #+cltl2) in this
;;; version that is bundled with SLIME.
;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL.
;;; 07-Aug-12 heller Break lines at 80 columns
;;;
;;; ********************************
......@@ -447,27 +448,6 @@ Estimated total monitoring overhead: 0.88 seconds
;;; two lines with the commented out code.
#+openmcl
(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
;; #+openmcl
;; (progn
;; (in-package :ccl)
;; (defvar *bytes-consed-chkpt* 0)
;; (defun reset-consing () (setq *bytes-consed-chkpt* 0))
;; (let ((old-gc (symbol-function 'gc))
;; (ccl:*warn-if-redefine-kernel* nil))
;; (setf (symbol-function 'gc)
;; #'(lambda ()
;; (let ((old-consing (total-bytes-consed)))
;; (prog1
;; (funcall old-gc)
;; (incf *bytes-consed-chkpt*
;; (- old-consing (total-bytes-consed))))))))
;; (defun total-bytes-consed ()
;; "Returns number of conses (8 bytes each)"
;; (ccl::total-bytes-allocated))
;; (in-package "MONITOR")
;; (defun get-cons ()
;; (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*))))
#-(or clisp openmcl)
(progn
......@@ -520,11 +500,13 @@ Estimated total monitoring overhead: 0.88 seconds
(beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
(re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
`(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time)
,gc1 ,gc2 ,beg-cons1 ,beg-cons2)
(sys::%%time)
(declare (ignore ,re1 ,re2 ,gc1 ,gc2))
(multiple-value-prog1 ,form
(multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time)
,gc1 ,gc2 ,end-cons1 ,end-cons2)
(sys::%%time)
(declare (ignore ,re1 ,re2 ,gc1 ,gc2))
(let ((,delta-time (delta4-time ,end-time1 ,end-time2
,beg-time1 ,beg-time2))
......@@ -572,7 +554,8 @@ Estimated total monitoring overhead: 0.88 seconds
(progn
(eval-when (compile eval)
(warn
"You may want to add an implementation-specific Required-Arguments function."))
"You may want to add an implementation-specific ~
Required-Arguments function."))
(eval-when (load eval)
(defun required-arguments (name)
(declare (ignore name))
......@@ -1123,8 +1106,9 @@ functions set NAMES to be either NIL or :ALL."
*monitor-results*))))
(display-monitoring-results threshold key ignore-no-calls)))))
(defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time)
(ignore-no-calls t))
(defun display-monitoring-results (&optional (threshold 0.01)
(key :percent-time)
(ignore-no-calls t))
(let ((max-length 8) ; Function header size
(max-cons-length 8)
(total-time 0.0)
......@@ -1147,8 +1131,10 @@ functions set NAMES to be either NIL or :ALL."
(format *trace-output*
"~%~%~
~VT ~VA~
~% ~VT % % ~VA Total Total~
~%Function~VT Time Cons Calls Sec/Call ~VA Time Cons~
~% ~VT % % ~VA ~
Total Total~
~%Function~VT Time Cons Calls Sec/Call ~VA ~
Time Cons~
~%~V,,,'-A"
max-length
max-cons-length "Cons"
......
......@@ -80,7 +80,8 @@
standard-slot-definition ;;dummy
cl:method
cl:standard-class
#+#.(swank-backend:with-symbol 'compute-applicable-methods-using-classes 'mop)
#+#.(swank-backend:with-symbol 'compute-applicable-methods-using-classes
'mop)
mop::compute-applicable-methods-using-classes
;; standard-class readers
mop::class-default-initargs
......@@ -191,7 +192,8 @@
(defvar *external-format-to-coding-system*
'((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
((:iso-8859-1 :eol-style :lf) "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
((:iso-8859-1 :eol-style :lf)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
(:utf-8 "utf-8")
((:utf-8 :eol-style :lf) "utf-8-unix")
(:euc-jp "euc-jp")
......@@ -256,7 +258,8 @@
(sys::arglist fun)
(when (and (not present)
(fboundp fun)
(typep (symbol-function fun) 'standard-generic-function))
(typep (symbol-function fun)
'standard-generic-function))
(setq arglist
(mop::generic-function-lambda-list (symbol-function fun))
present
......@@ -629,22 +632,25 @@ part of *sysdep-pathnames* in swank.loader.lisp.
,@(if parts
(loop :for (label . value) :in parts
:appending (label-value-line label value))
(list "No inspectable parts, dumping output of CL:DESCRIBE:" '(:newline)
(list "No inspectable parts, dumping output of CL:DESCRIBE:"
'(:newline)
(with-output-to-string (desc) (describe o desc)))))))
(defmethod emacs-inspect ((slot mop::slot-definition))
`("Name: " (:value ,(mop::%slot-definition-name slot))
(:newline)
"Documentation:" (:newline)
,@(when (slot-definition-documentation slot)
`((:value ,(slot-definition-documentation slot)) (:newline)))
"Initialization:" (:newline)
" Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
" Form: " ,(if (mop::%slot-definition-initfunction slot)
`(:value ,(mop::%slot-definition-initform slot))
"#<unspecified>") (:newline)
" Function: " (:value ,(mop::%slot-definition-initfunction slot))
(:newline)))
`("Name: "
(:value ,(mop::%slot-definition-name slot))
(:newline)
"Documentation:" (:newline)
,@(when (slot-definition-documentation slot)
`((:value ,(slot-definition-documentation slot)) (:newline)))
"Initialization:" (:newline)
" Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
" Form: " ,(if (mop::%slot-definition-initfunction slot)
`(:value ,(mop::%slot-definition-initform slot))
"#<unspecified>") (:newline)
" Function: "
(:value ,(mop::%slot-definition-initfunction slot))
(:newline)))
(defmethod emacs-inspect ((f function))
`(,@(when (function-name f)
......@@ -652,10 +658,13 @@ part of *sysdep-pathnames* in swank.loader.lisp.
,(princ-to-string (function-name f)) (:newline)))
,@(multiple-value-bind (args present)
(sys::arglist f)
(when present `("Argument list: " ,(princ-to-string args) (:newline))))
(when present
`("Argument list: "
,(princ-to-string args) (:newline))))
(:newline)
#+nil,@(when (documentation f t)
`("Documentation:" (:newline) ,(documentation f t) (:newline)))
`("Documentation:" (:newline)
,(documentation f t) (:newline)))
,@(when (function-lambda-expression f)
`("Lambda expression:"
(:newline) ,(princ-to-string
......@@ -666,20 +675,21 @@ part of *sysdep-pathnames* in swank.loader.lisp.
;;; case, so make its computation a user interaction.
(defparameter *to-string-hashtable* (make-hash-table))
(defmethod emacs-inspect ((o java:java-object))
(let ((to-string (lambda ()
(handler-case
(setf (gethash o *to-string-hashtable*)
(java:jcall "toString" o))
(t (e)
(setf (gethash o *to-string-hashtable*)
(format nil "Could not invoke toString(): ~A"
e)))))))
(append
(if (gethash o *to-string-hashtable*)
(label-value-line "toString()" (gethash o *to-string-hashtable*))
`((:action "[compute toString()]" ,to-string) (:newline)))
(loop :for (label . value) :in (sys:inspected-parts o)
:appending (label-value-line label value)))))
(let ((to-string (lambda ()
(handler-case
(setf (gethash o *to-string-hashtable*)
(java:jcall "toString" o))
(t (e)
(setf (gethash o *to-string-hashtable*)
(format nil
"Could not invoke toString(): ~A"
e)))))))
(append
(if (gethash o *to-string-hashtable*)
(label-value-line "toString()" (gethash o *to-string-hashtable*))
`((:action "[compute toString()]" ,to-string) (:newline)))
(loop :for (label . value) :in (sys:inspected-parts o)
:appending (label-value-line label value)))))
;;;; Multithreading
......
......@@ -223,7 +223,8 @@
(car (debugger:frame-expression frame))))))))))
(defun function-source-location (fun)
(cadr (car (fspec-definition-locations (xref::object-to-function-name fun)))))
(cadr (car (fspec-definition-locations
(xref::object-to-function-name fun)))))
#+(version>= 8 2)
(defun pc-source-location (fun pc)
......@@ -533,7 +534,8 @@
(t
(find-definition-in-file fspec type file top-level)))))
((member :top-level)
(make-error-location "Defined at toplevel: ~A" (fspec->string fspec))))
(make-error-location "Defined at toplevel: ~A"
(fspec->string fspec))))
(error (e)
(make-error-location "Error: ~A" e))))
......@@ -646,7 +648,8 @@
;;;; Profiling
;; Per-function profiling based on description in
;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data-collection-control-2
;; http://www.franz.com/support/documentation/8.0/\
;; doc/runtime-analyzer.htm#data-collection-control-2
(defvar *profiled-functions* ())
(defvar *profile-depth* 0)
......
......@@ -160,7 +160,6 @@ Backends implement these functions using DEFIMPLEMENTATION."
,(if (null default-body)
`(pushnew ',name *unimplemented-interfaces*)
(gen-default-impl))
;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
(eval-when (:compile-toplevel :load-toplevel :execute)
(export ',name :swank-backend))
',name)))
......@@ -755,10 +754,12 @@ additional information on the specifiers defined in ANSI Common Lisp.")
(type '(type-specifier &rest args))
(ftype '(type-specifier &rest function-names))
(otherwise
(flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
(flet ((typespec-p (symbol)
(member :type (describe-symbol-for-emacs symbol))))
(cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
'(&rest variables))
((and (listp decl-identifier) (typespec-p (first decl-identifier)))
((and (listp decl-identifier)
(typespec-p (first decl-identifier)))
'(&rest variables))
(t :not-available)))))))
......@@ -781,7 +782,8 @@ additional information on the specifiers defined in ANSI Common Lisp.")
(definterface function-name (function)
"Return the name of the function object FUNCTION.
The result is either a symbol, a list, or NIL if no function name is available."
The result is either a symbol, a list, or NIL if no function name is
available."
(declare (ignore function))
nil)
......@@ -1066,7 +1068,8 @@ returns.")
(cond ((typep datum 'condition)
`(:error ,(format nil "Error: ~A" datum)))
((symbolp datum)
`(:error ,(format nil "Error: ~A" (apply #'make-condition datum args))))
`(:error ,(format nil "Error: ~A"
(apply #'make-condition datum args))))
(t
(assert (stringp datum))
`(:error ,(apply #'format nil datum args)))))
......
......@@ -330,20 +330,24 @@ Return NIL if the symbol is unbound."
(fspec-pathname fspec)
(list (if type (list name type) name)
(cond (file
(multiple-value-bind (truename c) (ignore-errors (truename file))
(multiple-value-bind (truename c)
(ignore-errors (truename file))
(cond (truename
(make-location (list :file (namestring truename))
(if (consp lines)
(list* :line lines)
(list :function-name (string name)))
(when (consp type)
(list :snippet (format nil "~A" type)))))
(make-location
(list :file (namestring truename))
(if (consp lines)
(list* :line lines)
(list :function-name (string name)))
(when (consp type)
(list :snippet (format nil "~A" type)))))
(t (list :error (princ-to-string c))))))
(t (list :error (format nil "No source information available for: ~S"
fspec)))))))
(t (list :error
(format nil "No source information available for: ~S"
fspec)))))))
(defimplementation find-definitions (name)
(mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file)))
(mapcar #'(lambda (e) (fspec-location name e))
(documentation name 'sys::file)))
(defun trim-whitespace (string)
(string-trim #(#\newline #\space #\tab) string))
......
......@@ -78,7 +78,8 @@
(defclass swank-mop:standard-slot-definition ()
()
(:documentation "Dummy class created so that swank.lisp will compile and load."))
(:documentation
"Dummy class created so that swank.lisp will compile and load."))
(defun named-by-gensym-p (c)
(null (symbol-package (class-name c))))
......@@ -168,10 +169,12 @@
(make-frame :function nil)
(loop for i from db::*debug-min-level*
upto db::*debug-max-level*
until (eq (db::get-frame-function i) cl::*top-level*)
until (eq (db::get-frame-function i)
cl::*top-level*)
collect
(make-frame :function (db::get-frame-function i)
:address (db::get-frame-address i))))
(make-frame
:function (db::get-frame-function i)
:address (db::get-frame-address i))))
:key #'frame-function)))))
(funcall fn)))
......@@ -280,8 +283,9 @@
(if (ccl::function-source-line fspec)
(list :line
(1+ (ccl::function-source-line fspec)))
(list :function-name (princ-to-string
(function-name fspec))))))
(list :function-name
(princ-to-string
(function-name fspec))))))
(error (c) (list :error (princ-to-string c))))
(list :error (format nil "No source information available for ~S"
fspec)))))
......@@ -396,56 +400,67 @@
collect ", ")))
(defmethod emacs-inspect ((class standard-class))
`("Name: " (:value ,(class-name class))
(:newline)
"Super classes: "
,@(comma-separated (swank-mop:class-direct-superclasses class))
(:newline)
"Direct Slots: "
,@(comma-separated
(swank-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))
(:newline)
"Effective Slots: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated
(swank-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string
(swank-mop:slot-definition-name slot)))))
'("#<N/A (class not finalized)>"))
(:newline)
,@(when (documentation class t)
`("Documentation:" (:newline) ,(documentation class t) (:newline)))
"Sub classes: "
,@(comma-separated (swank-mop:class-direct-subclasses class)
(lambda (sub)
`(:value ,sub ,(princ-to-string (class-name sub)))))
(:newline)
"Precedence List: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated (swank-mop:class-precedence-list class)
(lambda (class)
`(:value ,class ,(princ-to-string (class-name class)))))
'("#<N/A (class not finalized)>"))
(:newline)))
`("Name: "
(:value ,(class-name class))
(:newline)
"Super classes: "
,@(comma-separated (swank-mop:class-direct-superclasses class))
(:newline)
"Direct Slots: "
,@(comma-separated
(swank-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot
,(princ-to-string
(swank-mop:slot-definition-name slot)))))
(:newline)
"Effective Slots: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated
(swank-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string
(swank-mop:slot-definition-name slot)))))
'("#<N/A (class not finalized)>"))
(:newline)
,@(when (documentation class t)
`("Documentation:" (:newline) ,(documentation class t) (:newline)))
"Sub classes: "
,@(comma-separated (swank-mop:class-direct-subclasses class)
(lambda (sub)
`(:value ,sub ,(princ-to-string (class-name sub)))))
(:newline)
"Precedence List: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated
(swank-mop:class-precedence-list class)
(lambda (class)
`(:value ,class
,(princ-to-string (class-name class)))))
'("#<N/A (class not finalized)>"))
(:newline)))
(defmethod emacs-inspect ((slot cons))
;; Inspects slot definitions
(if (eq (car slot) :name)
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
`("Documentation:" (:newline)
(:value ,(swank-mop:slot-definition-documentation slot))
(:newline)))
"Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
"Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
(:newline))
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
`("Documentation:"
(:newline)
(:value
,(swank-mop:slot-definition-documentation slot))
(:newline)))
"Init args: " (:value
,(swank-mop:slot-definition-initargs slot))
(:newline)
"Init form: "
,(if (swank-mop:slot-definition-initfunction slot)
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: "
(:value ,(swank-mop:slot-definition-initfunction slot))
(:newline))
(call-next-method)))
(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
......
......@@ -476,7 +476,8 @@
(third (elt *backtrace* frame-number)))
(defimplementation frame-locals (frame-number)
(loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
(loop for (name . value) in (nth-value 2 (frame-decode-env
(elt *backtrace* frame-number)))
with i = 0
collect (list :name name :id (prog1 i (incf i)) :value value)))
......
This diff is collapsed.
......@@ -317,7 +317,8 @@
(funcall output-fn (make-string fill-size
:initial-element #\space))
(setf (slot-value stream 'position) target-position))
(setf (slot-value stream 'last-write) (get-internal-real-time))
(setf (slot-value stream 'last-write)
(get-internal-real-time))
t)
(t
nil))))
......@@ -556,7 +557,8 @@
(let ((file (c::compiler-error-context-file-name context))
(source (c::compiler-error-context-original-source context))
(path
(reverse (c::compiler-error-context-original-source-path context))))
(reverse
(c::compiler-error-context-original-source-path context))))
(or (locate-compiler-note file source path)
(note-error-location)))))
......@@ -1052,7 +1054,8 @@ Signal an error if no constructor can be found."
(name (clos:generic-function-name gf))
(specializers (clos:method-specializers method))
(qualifiers (clos:method-qualifiers method)))
`(method ,name ,@qualifiers ,specializers #+nil (clos::unparse-specializers specializers))))
`(method ,name ,@qualifiers ,specializers
#+nil (clos::unparse-specializers specializers))))
;; XXX maybe special case setters/getters
(defun method-location (method)
......@@ -1557,8 +1560,9 @@ Signal an error if no constructor can be found."
(list (1st sc)))))))))
(defun mv-function-end-breakpoint-values (sigcontext)
(let ((sym (find-symbol (symbol-name '#:function-end-breakpoint-values/standard)
:debug-internals)))
(let ((sym (find-symbol
(symbol-name '#:function-end-breakpoint-values/standard)
:debug-internals)))
(cond (sym (funcall sym sigcontext))
(t (di::get-function-end-breakpoint-values sigcontext)))))
......@@ -1952,7 +1956,8 @@ The `symbol-value' of each element is a type tag.")
(sys:without-interrupts
(thread:with-lock-held (*mailbox-lock*)
(or (getf (thread:thread-plist thread) 'mailbox)
(setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox))))))
(setf (getf (thread:thread-plist thread) 'mailbox)
(make-mailbox))))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
......
......@@ -48,7 +48,9 @@ before and after of calling FN in the hashtable SOURCE-MAP."
(let ((start (1- (file-position stream)))
(values (multiple-value-list (funcall fn stream char)))
(end (file-position stream)))
;(format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" start values end (char-code char) char)
#+(or)
(format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%"
start values end (char-code char) char)
(unless (null values)
(push (cons start end) (gethash (car values) source-map)))
(values-list values))))
......
......@@ -49,27 +49,27 @@
;;; Use and copying of this software and the preparation of derivative
;;; works based on this software are permitted, so long as the following
;;; conditions are met:
;;; o The copyright notice and this entire notice are included intact
;;; and prominently carried on all copies and supporting documentation.
;;; o No fees or compensation are charged for use, copies, or
;;; access to this software. You may charge a nominal
;;; distribution fee for the physical act of transferring a
;;; copy, but you may not charge for the program itself.
;;; o If you modify this software, you must cause the modified
;;; file(s) to carry prominent notices (a Change Log)
;;; describing the changes, who made the changes, and the date
;;; of those changes.
;;; o Any work distributed or published that in whole or in part
;;; contains or is a derivative of this software or any part
;;; thereof is subject to the terms of this agreement. The
;;; aggregation of another unrelated program with this software
;;; or its derivative on a volume of storage or distribution
;;; medium does not bring the other program under the scope
;;; of these terms.
;;; o Permission is granted to manufacturers and distributors of
;;; lisp compilers and interpreters to include this software
;;; with their distribution.
;;;
;;; o The copyright notice and this entire notice are included intact
;;; and prominently carried on all copies and supporting documentation.
;;; o No fees or compensation are charged for use, copies, or
;;; access to this software. You may charge a nominal
;;; distribution fee for the physical act of transferring a
;;; copy, but you may not charge for the program itself.
;;; o If you modify this software, you must cause the modified
;;; file(s) to carry prominent notices (a Change Log)
;;; describing the changes, who made the changes, and the date
;;; of those changes.
;;; o Any work distributed or published that in whole or in part
;;; contains or is a derivative of this software or any part
;;; thereof is subject to the terms of this agreement. The
;;; aggregation of another unrelated program with this software
;;; or its derivative on a volume of storage or distribution
;;; medium does not bring the other program under the scope
;;; of these terms.
;;; o Permission is granted to manufacturers and distributors of
;;; lisp compilers and interpreters to include this software
;;; with their distribution.
;;;
;;; This software is made available AS IS, and is distributed without
;;; warranty of any kind, either expressed or implied.
;;;
......@@ -141,6 +141,7 @@
;;; source is loaded.
;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself.
;;; The arg to macro-function must be a symbol.
;;; 7-APR-12 heller Break lines at 80 columns.
;;; ********************************
;;; To Do **************************
......@@ -589,17 +590,22 @@ Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp.
48 forms processed.
<cl> (xref:display-database :readers)
*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE.
*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE.
*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO.
*DIRECTION* is referenced by CREATE-POSITION-INFO.
*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT.
*ROOT-IS-SEQUENCE* is referenced by GRAPH.
*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE.
*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE.
*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO.
*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE.
*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE.
*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE.
*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE.
<cl> (xref:print-caller-trees :root-nodes '(display-graph))
......@@ -1229,8 +1235,8 @@ Rooted calling trees:
;;; Misc Utilities *****************
;;; ********************************
(defvar *types-to-ignore*
'(:lisp ; CLtL 1st Edition
:lisp2 ; CLtL 2nd Edition additional patterns
'(:lisp ; CLtL 1st Edition
:lisp2 ; CLtL 2nd Edition additional patterns
)
"Default set of caller types (as specified in the patterns) to ignore
in the database handling functions. :lisp is CLtL 1st edition,
......@@ -1906,7 +1912,8 @@ Rooted calling trees:
:lisp2)
(define-caller-pattern compiler-macro-function (form) :lisp2)