Source

psgml / psgml-info.el

Diff from to

psgml-info.el

 ;;;; psgml-info.el
-;;; Last edited: 1998-11-25 21:34:05 lenst
+;;; Last edited: 2000-11-09 19:23:50 lenst
 ;;; $Id$
 
 ;; Copyright (C) 1994, 1995 Lennart Staflin
 	   (loop for dfa in (sgml-and-node-dfas (car agenda)) do
 		 (sgml-add-last-unique dfa states))))
 	 (setq agenda (cdr agenda)))
-       (setq res (sort (set-difference
-			(union res (sgml-eltype-includes eltype))
-			(sgml-eltype-excludes eltype))
+       (setq res (sort (copy-seq (set-difference
+                                  (union res (sgml-eltype-includes eltype))
+                                  (sgml-eltype-excludes eltype)))
 		       (function string-lessp)))
        (setf (sgml-eltype-appdata eltype 're-cache) res)
        res)))))
 
 ;;;; Describe element type
 
-(defun sgml-princ-names (names)
+(defun sgml-princ-names (names &optional first sep)
+  (setq sep (or sep " "))
   (loop with col = 0
 	for name in names
+        for this-sep = (if first (prog1 first (setq first nil)) sep)
 	do
-	(when (and (> col 0) (> (+ col (length name) 1) fill-column))
-	  (princ "\n")
-	  (setq col 0))
-	(princ " ") (princ name)
-	(incf col (length name))
-	(incf col 1)))
+        (princ this-sep)
+	(incf col (length this-sep))
+	(when (and (> col 0) (> (+ col (length name)) fill-column))
+	  (princ "\n ")
+	  (setq col 1))
+        (princ name)
+	(incf col (length name))))
 
 (defun sgml-describe-element-type (et-name)
   "Describe the properties of an element type as declared in the current DTD."
 			 "optional" "required")))
       (princ "\nATTRIBUTES:\n")
       (loop for attdecl in (sgml-eltype-attlist et) do
-	    (let ((name (sgml-attdecl-name attdecl))
-		  (dval (sgml-attdecl-declared-value attdecl))
-		  (defl (sgml-attdecl-default-value attdecl)))
-	      (when (listp dval)
-		(setq dval (concat (if (eq (first dval)
-					   'NOTATION)
-				       "#NOTATION (" "(")
-				   (mapconcat (function identity)
-					      (second dval)
-					      "|")
-				   ")")))
-	      (cond ((sgml-default-value-type-p 'FIXED defl)
-		     (setq defl (format "#FIXED '%s'"
-					(sgml-default-value-attval defl))))
-		    ((symbolp defl)
-		     (setq defl (upcase (format "#%s" defl))))
-		    (t
-		     (setq defl (format "'%s'"
-					(sgml-default-value-attval defl)))))
-	      (princ (format " %-9s %-30s %s\n" name dval defl))))
+        (let ((name (sgml-attdecl-name attdecl))
+              (dval (sgml-attdecl-declared-value attdecl))
+              (defl (sgml-attdecl-default-value attdecl)))
+          (when (listp dval)
+            (setq dval (concat (if (eq (first dval)
+                                       'NOTATION)
+                                   "#NOTATION (" "(")
+                               (mapconcat (function identity)
+                                          (second dval)
+                                          "|")
+                               ")")))
+          (cond ((sgml-default-value-type-p 'FIXED defl)
+                 (setq defl (format "#FIXED '%s'"
+                                    (sgml-default-value-attval defl))))
+                ((symbolp defl)
+                 (setq defl (upcase (format "#%s" defl))))
+                (t
+                 (setq defl (format "'%s'"
+                                    (sgml-default-value-attval defl)))))
+          (princ (format " %-9s %-30s %s\n" name dval defl))))
       ;; ----
       (let ((s (sgml-eltype-shortmap et)))
 	(when s
       (cond ((symbolp (sgml-eltype-model et)) (princ (sgml-eltype-model et)))
 	    (t
 	     (princ (if (sgml-eltype-mixed et) "mixed\n\n"
-		       "element\n\n"))	     
+                      "element\n\n"))
 	     (sgml-princ-names
 	      (mapcar #'symbol-name (sgml-eltype-refrenced-elements et)))))
-
+      (let ((incl (sgml-eltype-includes et))
+            (excl (sgml-eltype-excludes et)))
+        (when (or incl excl)
+          (princ "\n\nEXCEPTIONS:"))
+        (when incl
+          (princ "\n + ")
+          (sgml-princ-names (mapcar #'symbol-name incl)))
+        (when excl
+          (princ "\n - ")
+          (sgml-princ-names (mapcar #'symbol-name excl))))
       ;; ----
       (princ "\n\nOCCURS IN:\n\n")
       (let ((occurs-in ()))
 		     (when (memq et (sgml-eltype-refrenced-elements cand))
 		       (push cand occurs-in))))
 	 (sgml-pstate-dtd sgml-buffer-parse-state))
-
-	(loop with col = 0
-	      for occur-et in (sort occurs-in (function string-lessp))
-	      for name = (sgml-eltype-name occur-et)
-	      do
-	      (when (and (> col 0) (> (+ col (length name) 1) fill-column))
-		(princ "\n")
-		(setq col 0))
-	      (princ " ") (princ name)
-	      (incf col (length name))
-	      (incf col 1))))))
+        (sgml-princ-names (mapcar 'sgml-eltype-name
+                                  (sort occurs-in (function string-lessp))))))))
 
 
 ;;;; Print general info about the DTD.
 	(entities 0)
 	(parameters 0)
 	(fmt "%20s %s\n")
-	(hdr "")
-	)
+	(hdr ""))
+
     (sgml-map-eltypes (function (lambda (e) (incf elements)))
 		      sgml-dtd-info)
     (sgml-map-entities (function (lambda (e) (incf entities)))