Anonymous committed ad365cb

XML support

Comments (0)

Files changed (6)

+1998-02-06  SL Baur  <>
+	* psgml.el:
+	* psgml-dtd.el:
+	* psgml-edit.el:
+	* psgml-parse.el: Add XML support from David Megginson
+	From John Mignault <>
 1998-02-01  SL Baur  <>
 	* Makefile (PRELOADS): Hardwire sgml-data-directory for building.
 # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 # Boston, MA 02111-1307, USA.
-VERSION = 1.02
+VERSION = 1.03
 MAINTAINER = XEmacs Development Team <>
 PACKAGE = psgml
 	((sgml-parse-delim "OR")
 	 (function sgml-reduce-|))
 	((sgml-parse-delim "AND")
-	 (function sgml-make-&))))
+	 (if sgml-xml-p
+	     (sgml-error "XML forbids AND connector.")
+	   (function sgml-make-&)))))
 (defun sgml-parse-name-group ()
   "Parse a single name or a name group (general name case) .
 ;;;                      |  [[119 ranked group]]
    ((sgml-parse-delim GRPO)
+    (when sgml-xml-p
+      (sgml-error "XML forbids name groups for the element type"))
     (let ((names (list (sgml-check-name))))
       (while (progn (sgml-skip-ts)
   (cond ((or (sgml-parse-char ?o)
 	     (sgml-parse-char ?O))
-	 t)
+	 (if sgml-xml-p
+	      (sgml-error "XML forbids omitted tag minimization.")
+	   t))
 	((sgml-parse-char ?-)
-	 nil)))
+	 (if sgml-xml-p
+	     (sgml-error "XML forbids omitted tag minimization.")
+	   nil))))
 (defun sgml-parse-modifier ()
   (cond ((sgml-parse-delim PLUS)
       (setq sgml-used-pcdata t)
       (setq el (sgml-make-pcdata)))
      ((sgml-parse-delim "DTGO")			; data tag group
+      (when sgml-xml-p
+	(sgml-error "XML forbids DATATAG."))
       (let ((tok (sgml-check-primitive-content-token)))
 	(sgml-skip-ts) (sgml-check-delim "SEQ")
 	 (let ((dc (intern (upcase (sgml-check-name))))) 
-	   (when (eq dc 'ANY)
-	     (setq sgml-used-pcdata t))
+	   (cond ((eq dc 'ANY)
+		  (setq sgml-used-pcdata t))
+		 ((eq dc 'CDATA)
+		  (when sgml-xml-p
+		    (sgml-error "XML forbids CDATA declared content.")))
+		 ((eq dc 'RCDATA)
+		  (when sgml-xml-p
+		    (sgml-error "XML forbids RCDATA declared content"))))
 (defun sgml-parse-exeption (type)
   (if (sgml-parse-char type)
-      (mapcar (function sgml-lookup-eltype)
-	      (sgml-check-name-group))))
+      (if sgml-xml-p
+	   (sgml-error "XML forbids inclusion and exclusion exceptions.")
+	(mapcar (function sgml-lookup-eltype)
+		(sgml-check-name-group)))))
 (defun sgml-before-eltype-modification ()
 ;;;  (let ((merged (sgml-dtd-merged sgml-dtd-info)))
 	    (let ((token (intern (sgml-check-name))))
+	      (when (and sgml-xml-p
+			 (memq token '(cdata sdata pi starttag endtag ms md)))
+		(sgml-error "XML forbids %s entities."
+			    (upcase (symbol-name token))))
 	       ((memq token '(cdata sdata)) ; data text ***
 		(setq type token)
   ;;                             149.2+ data attribute specification?)
   (let ((type (sgml-parse-name)))
     (when type
-      (setq type (intern (downcase type)))
+      (setq type (intern (sgml-check-case type)))
+      (when (and sgml-xml-p (memq type '(subdoc cdata sdata)))
+	(sgml-error "XML forbids %s entities."
+		    (upcase (symbol-name type))))
       (cond ((eq type 'subdoc))
 	    ((memq type '(cdata ndata sdata))
 (defun sgml-declare-attlist ()
   (let* ((assnot (cond ((sgml-parse-rni "notation")
+			(when sgml-xml-p
+			  (sgml-error "XML forbids data attribute declarations"))
 	 (assel (sgml-check-name-group))
 	 (attlist nil)			; the list
 	 (attdef nil))
+    (when (and sgml-xml-p (> (length assel) 1))
+      (sgml-error "XML forbids name groups for an associated element type."))
     (while (setq attdef (sgml-parse-attribute-definition))
       (push attdef attlist))
     (setq attlist (nreverse attlist))
       (loop for elname in assel do
 	    (setf (sgml-eltype-attlist (sgml-lookup-eltype elname))
-		  attlist)))))
+		  (sgml-merge-attlists
+		   (sgml-eltype-attlist
+		    (sgml-lookup-eltype elname))
+		   attlist))))))
+(defun sgml-merge-attlists (old new)
+  (loop for att in new do
+	(unless (assoc (car att) old)
+	  (setq old (cons att old))))
+  old)
 (defun sgml-parse-attribute-definition ()
   (let ((type 'name-token-group)
 	(names nil))
     (unless (eq (following-char) ?\()
-      (setq type (intern (sgml-check-name)))
+      (setq type (intern (sgml-check-case (sgml-check-name))))
+      (sgml-validate-declared-value type)
     (when (memq type '(name-token-group notation))
       (setq names (sgml-check-nametoken-group)))
     (sgml-make-declared-value type names)))
+(defun sgml-validate-declared-value (type)
+  (unless (memq type
+		'(cdata
+		  entity
+		  entities
+		  id
+		  idref
+		  idrefs
+		  name
+		  names
+		  nmtoken
+		  nmtokens
+		  notation
+		  number
+		  numbers
+		  nutoken
+		  nutokens))
+    (sgml-error "Invalid attribute declared value: %s" type))
+  (when (and sgml-xml-p (memq type
+			      '(name names number numbers nutoken nutokens)))
+    (sgml-error "XML forbids %s attributes." (upcase (symbol-name type)))))
 (defun sgml-check-default-value ()
   (let* ((rni (sgml-parse-rni))
-	 (key (if rni (intern (sgml-check-name)))))
+	 (key (if rni (intern (sgml-check-case (sgml-check-name))))))
+    (if rni (sgml-validate-default-value-rn key))
      (if (or (not rni) (eq key 'fixed))
+(defun sgml-validate-default-value-rn (rn)
+  (unless (memq rn '(required fixed current conref implied))
+    (sgml-error "Unknown reserved name: %s."
+		(upcase (symbol-name rn))))
+  (when (and sgml-xml-p (memq rn '(current conref)))
+    (sgml-error "XML forbids #%s attributes."
+		(upcase (symbol-name rn)))))
 ;;;; Parse doctype: Shortref
 ;;;150  short reference mapping declaration = MDO, "SHORTREF",
 	(sgml-show-warnings nil))
     (when (and name (not (equal name "")))
       (sgml-insert-tag (sgml-start-tag-of name) 'silent)
-      (forward-char -1)
+      (if (and sgml-xml-p (sgml-check-empty name))
+	  (forward-char -2)
+	(forward-char -1))
       (setq element (sgml-find-element-of (point)))
       (sgml-insert-attributes (funcall sgml-new-attribute-list-function
 			      (sgml-element-attlist element))
-      (forward-char 1)
+      (if (and sgml-xml-p (sgml-check-empty name))
+	  (forward-char 2)
+	(forward-char 1))
       (when (not (sgml-element-empty element))
 	(when (and sgml-auto-insert-required-elements
 		   (sgml-model-group-p sgml-current-state))
 (defun sgml-insert-start-tag (name asl attlist &optional net)
   (tempo-process-and-insert-string (concat "<" name))
   (sgml-insert-attributes asl attlist)
-  (insert (if net "/" ">")))
+  (if (and sgml-xml-p (sgml-check-empty name))
+      (insert "/>")
+    (insert (if net "/" ">"))))
 (defun sgml-change-start-tag (element asl)
   (let ((name (sgml-element-gi element))
 ;; Author: Lennart Staflin <>
 ;; Acknowledgment:
 ;;   The catalog parsing code was contributed by
-;;      David Megginson <dmeggins@aix1.uottawa.CA>
+;;      David Megginson <>
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU General Public License
 ;;       sysid = nil | string
 ;;       dir   = string
-(defun sgml-make-extid (pubid sysid &optional dir)
-  (cons pubid (cons sysid (or dir default-directory))))
+(defun sgml-make-extid (pubid sysid &optional pubid-ok)
+  (and sgml-xml-p (not pubid-ok) pubid (not sysid)
+    (sgml-error "XML requires a system ID after a public ID."))
+  (cons pubid (cons sysid default-directory)))
 (defun sgml-extid-pubid (extid)
   (car extid))
       ;; Some combinations
       "MS-START" "<!["			; MDO DSO
       "MS-END"   "]]>"			; MSC MDC
+      ;; XML stuff
+      "XML-ECOM"   "-->"		; end an XML comment
+      "XML-PIC"    "?>"			; end an XML processing instruction
+      "XML-SCOM"   "<!--"		; start an XML comment
+      "XML-TAGCE"  "/>"			; end an XML empty element
       ;; Pseudo
       "NULL"  ""
 (defun sgml-do-processing-instruction ()
   (let ((start (point)))
-    (sgml-skip-upto "PIC")
+    (if sgml-xml-p
+	(sgml-skip-upto "XML-PIC")
+      (sgml-skip-upto "PIC"))
     (when sgml-pi-function
 	  (funcall sgml-pi-function
 		   (buffer-substring-no-properties start (point)))))
-  (sgml-check-delim "PIC")
+  (if sgml-xml-p
+      (sgml-check-delim "XML-PIC")
+    (sgml-check-delim "PIC"))
   (sgml-set-markup-type 'pi)
 	    "Undefined entity %s" name))
 	  ((sgml-entity-data-p entity)
+	   (when sgml-xml-p
+	     (sgml-error
+	      "XML forbids data-entity references in data or DTD (%s)."
+	      name))
 	   (when sgml-signal-data-function
 	     (funcall sgml-signal-data-function))
 (defun sgml-parse-comment ()
   (if (sgml-parse-delim "COM")
-      (progn (sgml-skip-upto "COM")
-	     (sgml-check-delim "COM")
+      (if sgml-xml-p
+	  (sgml-parse-error "XML forbids nested comments.")
+	(progn (sgml-skip-upto "COM")
+	       (sgml-check-delim "COM")
+	       t))))
+(defun sgml-parse-xml-comment ()
+  (if (sgml-parse-delim "XML-SCOM")
+      (progn (sgml-skip-upto "XML-ECOM")
+	     (sgml-check-delim "XML-ECOM")
 (defun sgml-skip-cs ()
   (or (equal (sgml-check-name) name)
       (sgml-parse-error "Reserved name not expected")))
+(defun sgml-check-case (name)
+  "Convert the argument to lower case.
+If sgml-namecase-general is nil, then signal an error if the argument
+is not in upper case."
+  (or sgml-namecase-general
+      (equal name (upcase name))
+      (sgml-parse-error "Uppercase keyword expected."))
+  (downcase name))
 (defun sgml-parse-literal ()
   "Parse a literal and return a string, if no literal return nil."
   (let (lita start value)
   (or (eq sgml-empty (sgml-element-model element))
       (sgml-tree-conref element)))
+(defun sgml-check-empty (name)
+  "True if element with NAME is empty."
+  (let ((eltype (if (symbolp name) name (sgml-lookup-eltype name))))
+    (eq sgml-empty (sgml-eltype-model eltype))))
 (defun sgml-element-data-p (element)
   "True if ELEMENT can have data characters in its content."
   (or (sgml-element-mixed element)
 (defun sgml-skip-until-dsc ()
   (while (progn
-	   (sgml-skip-upto ("DSO" "DSC" "LITA" "LIT" "COM"))
+	   (if sgml-xml-p
+	       (sgml-skip-upto ("DSO" "DSC" "LITA" "LIT" "XML-SCOM" "COM"))
+	     (sgml-skip-upto ("DSO" "DSC" "LITA" "LIT" "COM")))
 	   (not (sgml-parse-delim "DSC")))
     (cond ((sgml-parse-literal))
 	  ((sgml-parse-delim "DSO")
-	  ((sgml-parse-comment))
+	  ((and sgml-xml-p (sgml-parse-xml-comment)))
+	  ((and (not sgml-xml-p) (sgml-parse-comment)))
 	  (t (forward-char 1)))))
 (defun sgml-skip-upto-mdc ()
 OPTION can be `prolog' if parsing the prolog or `dtd' if parsing the
 dtd or `ignore' if the declaration is to be ignored."
+   ((and sgml-xml-p (sgml-parse-xml-comment)))
    ((sgml-parse-delim "MDO" (nmstart "COM" "MDC"))
 (defun sgml-check-attribute-value-specification ()
   (or (sgml-parse-literal)
-      (sgml-parse-nametoken t)		; Not really a nametoken, but an
-					; undelimited literal
+      (prog1 (sgml-parse-nametoken t)	; Not really a nametoken, but an
+	(when sgml-xml-p		; undelimited literal
+	  (sgml-parse-error "XML forbids undelimited literals.")))
       (sgml-parse-error "Expecting an attribute value: literal or token")))
 (defun sgml-find-attdecl-for-value (value eltype)
     (unless (sgml-parse-delim "TAGC")	; optimize common case
       (setq asl (sgml-parse-attribute-specification-list et))
-       (if (sgml-parse-delim "NET")
+       (if (and (not sgml-xml-p) (sgml-parse-delim "NET"))
 	   (prog1 (setq net-enabled t)
 	     (or sgml-current-shorttag
 (defun sgml-check-tag-close ()
    (sgml-parse-delim "TAGC")
+   (and sgml-xml-p (sgml-parse-delim "XML-TAGCE"))
    (if (or (sgml-is-delim "STAGO" gi)
 	   (sgml-is-delim "ETAGO" gi))
        (or sgml-current-shorttag
 (defun sgml-start-tag-of (element)
   "Return the start-tag for ELEMENT."
-  (format "<%s>" (sgml-cohere-name element)))
+  (if (and sgml-xml-p (sgml-check-empty (sgml-cohere-name element)))
+      (format "<%s/>" (sgml-cohere-name element))
+    (format "<%s>" (sgml-cohere-name element))))
 (defun sgml-end-tag-of (element)
   "Return the end-tag for ELEMENT (token or element)."
 (defvar sgml-running-xemacs
   (not (not (string-match "Lucid\\|XEmacs" emacs-version))))
+(defvar sgml-xml-p nil
+  "Is this an XML document?")
+(make-variable-buffer-local 'sgml-xml-p)
 ;;; User settable options:
 (defgroup sgml nil
 (make-variable-buffer-local 'sgml-shorttag)
 (put 'sgml-shorttag 'sgml-desc "SHORTTAG")
+(defvar sgml-namecase-general t
+  "*Set to non-nil, if you use NAMECASE GENERAL YES.
+Setting this variable automatically makes it local to the current buffer.")
+(make-variable-buffer-local 'sgml-namecase-general)
+(put 'sgml-namecase-general 'sgml-desc "NAMECASE GENERAL")
 (defvar sgml-minimize-attributes nil
   "*Determines minimization of attributes inserted by edit-attributes.
 Actually two things are done
   :group 'psgml-dtd)
 (put 'sgml-declaration 'sgml-type 'string)
+(defvar sgml-xml-declaration nil
+  "*If non-nil, this is the name of the SGML declaration for XML files.")
+(put 'sgml-xml-declaration 'sgml-type 'string)
 (defcustom sgml-mode-hook nil
   "A hook or list of hooks to be run when entering sgml-mode"
   :type 'hook
+    sgml-namecase-general
+	 'sgml-namecase-general
 sgml-omittag  Set this to reflect OMITTAG in the SGML declaration.
 sgml-shortag  Set this to reflect SHORTTAG in the SGML declaration.
+sgml-namecase-general  Set this to reflect NAMECASE GENERAL in the SGML declaration.
 sgml-auto-insert-required-elements  If non-nil, automatically insert required 
 	elements in the content of an inserted element.
 sgml-balanced-tag-edit  If non-nil, always insert start-end tag pairs.
+  (setq sgml-xml-p nil)
   (setq local-abbrev-table sgml-mode-abbrev-table)
   (use-local-map sgml-mode-map)
   (setq mode-name "SGML")
   (easy-menu-add sgml-view-menu)
   (easy-menu-add sgml-dtd-menu))
+(define-derived-mode xml-mode sgml-mode "XML"
+  (setq sgml-xml-p t)
+  (setq sgml-omittag nil)
+  (setq sgml-shorttag nil)
+  (setq sgml-namecase-general nil)
+  (setq sgml-minimize-attributes nil)
+  (setq sgml-always-quote-attributes t)
+  (setq sgml-validate-command "nsgmls -wxml -s %s %s")
+  (unless sgml-declaration
+    (setq sgml-declaration sgml-xml-declaration)))
 (defun sgml-default-dtd-file ()
   (and (buffer-file-name)
        (let ((base (file-name-nondirectory (buffer-file-name))))