cgit.sxemacs.org Git - packages/blob - xemacs-packages/psgml/psgml-debug.el

   1 ;;;;\filename psgml-debug.el
   2 ;;;\Last edited: 2001-03-10 00:32:00 lenst
   3 ;;;\RCS $Id: psgml-debug.el,v 2.31 2005/03/02 19:43:45 lenst Exp $
   4 ;;;\author {Lennart Staflin}
   5 ;;;\maketitle
   6
   7 ;;\begin{codeseg}
   8 (provide 'psgml-debug)
   9 (require 'psgml)
  10 (require 'psgml-parse)
  11 (require 'psgml-edit)
  12 (require 'psgml-dtd)
  13 (autoload 'sgml-translate-model "psgml-dtd" "" nil)
  14 (eval-when-compile
  15   (require 'cl)
  16   (require 'elp)
  17   (require 'edebug))
  18 \f
  19 ;;;; Debugging
  20
  21 (define-key sgml-mode-map "\C-c," 'sgml-goto-cache)
  22 (define-key sgml-mode-map "\C-c\C-x" 'sgml-dump-tree)
  23 (define-key sgml-mode-map "\C-c."   'sgml-shortref-identify)
  24
  25 (defun sgml-this-element ()
  26   (interactive)
  27   (let ((tree (sgml-find-element-of (point))))
  28     (sgml-dump-rec tree)))
  29
  30 (defun sgml-goto-cache ()
  31   (interactive)
  32   (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state)
  33         sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
  34   (sgml-goto-start-point (point))
  35   (message "%s" (sgml-dump-node sgml-current-tree)))
  36
  37 (defun sgml-dump-tree (arg)
  38   (interactive "P")
  39   (when arg
  40     (sgml-parse-to-here))
  41   (with-output-to-temp-buffer "*Dump*"
  42     (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state))))
  43
  44 (defun sgml-auto-dump ()
  45   (let ((standard-output (get-buffer-create "*Dump*"))
  46         (cb (current-buffer)))
  47
  48     (when sgml-buffer-parse-state
  49       (unwind-protect
  50           (progn (set-buffer standard-output)
  51                  (erase-buffer))
  52         (set-buffer cb))
  53
  54       (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state))
  55
  56       ))
  57   )
  58
  59 (defun sgml-start-auto-dump ()
  60   (interactive)
  61   (add-hook 'post-command-hook
  62             (function sgml-auto-dump)
  63             'append))
  64
  65 (defun sgml-comepos (epos)
  66   (if (sgml-strict-epos-p epos)
  67       (format "%s:%s"
  68               (sgml-entity-name (sgml-eref-entity (sgml-epos-eref epos)))
  69               (sgml-epos-pos epos))
  70     (format "%s" epos)))
  71
  72 (defun sgml-dump-node (u)
  73   (format
  74    "%s%s start:%s(%s) end:%s(%s) epos:%s/%s net:%s\n"
  75    (make-string (sgml-tree-level u) ?. )
  76    (sgml-element-gi u)
  77    (sgml-element-start u) (sgml-tree-stag-len u)
  78    (if (sgml-tree-etag-epos u) (sgml-tree-end u)) (sgml-tree-etag-len u)
  79    (sgml-comepos (sgml-tree-stag-epos u))
  80    (sgml-comepos (sgml-tree-etag-epos u))
  81    (sgml-tree-net-enabled u)))
  82
  83 (defun sgml-dump-rec (u)
  84   (while u
  85     (princ (sgml-dump-node u))
  86     (sgml-dump-rec (sgml-tree-content u))
  87     (setq u (sgml-tree-next u))))
  88
  89 (defun sgml-shortref-identify ()
  90   (interactive)
  91   (sgml-find-context-of (point))
  92   (let* ((nobol (eq (point) sgml-rs-ignore-pos))
  93          (tem (sgml-deref-shortmap sgml-current-shortmap nobol)))
  94     (message "%s (%s)" tem nobol)))
  95
  96 (defun sgml-lookup-shortref-name (table map)
  97   (car (rassq map (cdr table))))
  98
  99 (defun sgml-show-current-map ()
 100   (interactive)
 101   (sgml-find-context-of (point))
 102   (let ((name (sgml-lookup-shortref-name
 103                (sgml-dtd-shortmaps sgml-dtd-info)
 104                sgml-current-shortmap)))
 105     (message "Current map: %s"
 106              (or name "#EMPTY"))))
 107 \f
 108 ;;;; For edebug
 109
 110 ;;(put 'when 'edebug-form-hook t)
 111 ;;(put 'unless 'edebug-form-hook t)
 112 ;;(put 'push 'edebug-form-hook '(form sexp))
 113 ;;(put 'setf 'edebug-form-hook '(sexp form))
 114
 115 (setq edebug-print-level 3
 116       edebug-print-length 5
 117       edebug-print-circle nil
 118 )
 119
 120 (eval-when (load)
 121   (unless running-xemacs ;; XEmacs change
 122     (def-edebug-spec sgml-with-parser-syntax (&rest form))
 123     (def-edebug-spec sgml-with-parser-syntax-ro (&rest form))
 124     (def-edebug-spec sgml-skip-upto (sexp))
 125     (def-edebug-spec sgml-check-delim (sexp &optional sexp))
 126     (def-edebug-spec sgml-parse-delim (sexp &optional sexp))
 127     (def-edebug-spec sgml-is-delim (sexp &optional sexp sexp sexp))))
 128 \f
 129 ;;;; dump
 130
 131 (defun sgml-dump-dtd (&optional dtd)
 132   (interactive )
 133   (unless dtd
 134     (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state)))
 135   (with-output-to-temp-buffer "*DTD dump*"
 136     (princ (format "Dependencies: %S\n"
 137                    (sgml-dtd-dependencies dtd)))
 138     (loop for et being the symbols of (sgml-dtd-eltypes dtd)
 139           do (sgml-dp-element et))))
 140
 141 (defun sgml-dump-element (el-name)
 142   (interactive
 143    (list (completing-read "Element: "
 144                           (sgml-dtd-eltypes
 145                            (sgml-pstate-dtd sgml-buffer-parse-state))
 146                           nil t)))
 147   (with-output-to-temp-buffer "*Element dump*"
 148     (sgml-dp-element (sgml-lookup-eltype el-name))))
 149
 150 (defun sgml-dp-element (el)
 151   (cond
 152    ((sgml-eltype-defined el)
 153     (princ (format "Element %s %s %s%s:\n"
 154                    (sgml-eltype-name el)
 155                    (if (sgml-eltype-stag-optional el) "O" "-")
 156                    (if (sgml-eltype-etag-optional el) "O" "-")
 157                    (if (sgml-eltype-mixed el) " mixed" "")))
 158     (cond
 159      ((sgml-model-group-p (sgml-eltype-model el))
 160       (sgml-dp-model (sgml-eltype-model el)))
 161      (t
 162       (prin1 (sgml-eltype-model el))
 163       (terpri)))
 164     (princ (format "Exeptions: +%S -%S\n"
 165                    (sgml-eltype-includes el)
 166                    (sgml-eltype-excludes el)))
 167     (princ (format "Attlist: %S\n" (sgml-eltype-attlist el)))
 168     (princ (format "Plist: %S\n" (symbol-plist el))))
 169    (t
 170     (princ (format "Undefined element %s\n" (sgml-eltype-name el)))))
 171   (terpri))
 172
 173
 174 (defun sgml-dp-model (model &optional indent)
 175   (or indent (setq indent 0))
 176   (let ((sgml-code-xlate (sgml-translate-model model)))
 177     (loop
 178      for i from 0
 179      for x in sgml-code-xlate do
 180      (cond ((sgml-normal-state-p (car x))
 181             (princ (format "%s%d: opts=%s reqs=%s\n"
 182                            (make-string indent ? ) i
 183                            (sgml-untangel-moves (sgml-state-opts (car x)))
 184                            (sgml-untangel-moves (sgml-state-reqs (car x))))))
 185            (t                           ; and-node
 186             (princ (format "%s%d: and-node next=%d\n"
 187                            (make-string indent ? ) i
 188                            (sgml-code-xlate (sgml-and-node-next (car x)))))
 189             (loop for m in (sgml-and-node-dfas (car x))
 190                   do (sgml-dp-model m (+ indent 2))))))))
 191
 192 (defun sgml-untangel-moves (moves)
 193   (loop for m in moves
 194         collect (list (sgml-move-token m)
 195                       (sgml-code-xlate (sgml-move-dest m)))))
 196
 197 \f
 198 ;;;; Dump state
 199
 200 (defun sgml-dump-state ()
 201   (interactive)
 202   (with-output-to-temp-buffer "*State dump*"
 203     (sgml-dp-state sgml-current-state)))
 204
 205 (defun sgml-dp-state (state &optional indent)
 206   (or indent (setq indent 0))
 207   (cond
 208    ((sgml-normal-state-p state)
 209     (sgml-dp-model state indent))
 210    (t
 211     (princ (format "%sand-state\n" (make-string indent ? )))
 212     (sgml-dp-state (sgml-and-state-substate state) (+ 2 indent))
 213     (princ (format "%s--next\n" (make-string indent ? )))
 214     (sgml-dp-state (sgml-and-state-next state)     (+ 2 indent))
 215     (princ (format "%s--dfas\n" (make-string indent ? )))
 216     (loop for m in (sgml-and-state-dfas state)
 217           do (sgml-dp-model m (+ indent 2))
 218           (princ (format "%s--\n" (make-string indent ? )))))))
 219
 220 \f
 221 ;;;; Build autoloads for all interactive functions in psgml-parse
 222
 223 (defun sgml-build-autoloads ()
 224   (interactive)
 225   (with-output-to-temp-buffer "*autoload*"
 226     (loop
 227      for file in '("psgml-parse" "psgml-edit" "psgml-dtd"
 228                    "psgml-info" "psgml-charent")
 229      do
 230      (set-buffer (find-file-noselect (concat file ".el")))
 231      (goto-char (point-min))
 232      (while (and
 233              (not (eobp))
 234              (re-search-forward "^(defun +\\([^ ]+\\)" nil t))
 235        (let ((name (buffer-substring (match-beginning 1)
 236                                      (match-end 1)))
 237              doc)
 238          (forward-sexp 1)               ; skip argument list
 239          (skip-chars-forward " \n\t")
 240          (when (eq ?\" (following-char)) ; doc string
 241                (setq doc (buffer-substring (point)
 242                                            (progn (forward-sexp 1)
 243                                                   (point)))))
 244          (skip-chars-forward " \n\t")
 245          (when (looking-at "(interactive")
 246                (if (null doc)
 247                    (message "No doc for %s" name))
 248                (princ (format
 249                        "(autoload '%s \"%s\" %s t)\n"
 250                        name file doc))))))))
 251 \f
 252 ;;;; Test psgml with sgmls test cases
 253
 254 (defun test-sgml (start)
 255   (interactive "p")
 256   (let (file
 257         (sgml-show-warnings t))
 258     (with-output-to-temp-buffer "*Testing psgml*"
 259       (while
 260           (progn
 261             (setq file (format "/u2/src/sgmls-1.1/test/test%03d.sgm"
 262                                start))
 263             (file-exists-p file))
 264         (princ (format "*** File test%03d ***\n" start))
 265         (find-file file)
 266         (condition-case errcode
 267             (progn
 268               (sgml-parse-prolog)
 269               ;;(sgml-next-trouble-spot)
 270               (sgml-parse-until-end-of nil))
 271           (error
 272            (princ errcode)
 273            (terpri)))
 274         (if (get-buffer sgml-log-buffer-name)
 275             (princ (save-excursion
 276                      (set-buffer sgml-log-buffer-name)
 277                      (buffer-string))))
 278         (terpri)
 279         (terpri)
 280         (sit-for 0)
 281         (kill-buffer (current-buffer))
 282         (setq start (1+ start))))))
 283
 284 \f
 285 ;;;; Profiling
 286
 287 (defun profile-sgml (&optional file)
 288   (interactive)
 289   (or file (setq file (expand-file-name "~/work/sigmalink/BBB/config/configspec.xml")))
 290   (find-file file)
 291   (sgml-need-dtd)
 292   (sgml-instrument-parser)
 293   (elp-reset-all)
 294   (dotimes (i 5)
 295     (garbage-collect)
 296     (sgml-reparse-buffer (function sgml-handle-shortref)))
 297   (elp-results))
 298
 299 (defun sgml-instrument-parser ()
 300   (interactive)
 301   (require 'elp)
 302   (setq elp-function-list nil)
 303   (elp-restore-all)
 304   (setq elp-function-list
 305         '(
 306           sgml-parse-to
 307           sgml-parser-loop
 308           sgml-parse-markup-declaration
 309           sgml-do-processing-instruction
 310           sgml-pop-entity
 311           sgml-tree-net-enabled
 312           sgml-do-end-tag
 313           sgml-do-data
 314           sgml-deref-shortmap
 315           sgml-handle-shortref
 316           sgml-do-start-tag
 317           sgml-do-general-entity-ref
 318           sgml-set-face-for
 319           sgml-pcdata-move
 320           sgml-shortmap-skipstring
 321           ;;
 322           sgml-parse-attribute-specification-list
 323           sgml-check-tag-close
 324           sgml-do-move
 325           sgml-open-element
 326           sgml-list-implications
 327           sgml-move-current-state
 328           sgml-do-empty-start-tag
 329           sgml-lookup-eltype
 330           sgml-startnm-char-next
 331           sgml-eltype-defined
 332           sgml-execute-implied
 333           sgml-next-sub-and
 334           sgml-get-and-move
 335           format
 336           ))
 337   (elp-instrument-list))
 338
 339
 340 (defun sgml-instrument-dtd-parser ()
 341   (interactive)
 342   (require 'elp)
 343   (setq elp-function-list nil)
 344   (elp-restore-all)
 345   (setq elp-function-list
 346         '(
 347           sgml-parse-prolog
 348           sgml-skip-ds
 349           sgml-parse-markup-declaration
 350           sgml-check-doctype-body
 351           ;;
 352           sgml-check-dtd-subset
 353           sgml-parse-ds
 354           sgml-declare-attlist
 355           sgml-declare-entity
 356           sgml-declare-element
 357           sgml-declare-shortref
 358           ;;
 359           sgml-parse-parameter-literal
 360           sgml-check-element-type
 361           sgml-check-primitive-content-token
 362           sgml-check-model-group
 363           ;; In sgml-check-model-group
 364           sgml-parse-modifier
 365           sgml-make-pcdata
 366           sgml-skip-ts
 367           sgml-make-opt
 368           sgml-make-*
 369           sgml-make-+
 370           sgml-reduce-,
 371           sgml-reduce-|
 372           sgml-make-&
 373           sgml-make-conc
 374           sgml-copy-moves
 375           ;; is ps*
 376           sgml-do-parameter-entity-ref
 377           ;;
 378           sgml-make-primitive-content-token
 379           sgml-push-to-entity
 380           sgml-lookup-entity
 381           sgml-lookup-eltype
 382           sgml-one-final-state
 383           sgml-remove-redundant-states-1
 384           ))
 385   (elp-instrument-list))
 386 \f
 387 ;\end{codeseg}