xemacs-beta: lisp/psgml/psgml-parse.el comparison

comparison lisp/psgml/psgml-parse.el @ 2:ac2d302a0011 r19-15b2

Import from CVS: tag r19-15b2

author	cvs
date	Mon, 13 Aug 2007 08:46:35 +0200
parents	376386a54a3c
children	bcdc7deadc19

comparison

equal deleted inserted replaced

-:c0c6a60d29db
+:ac2d302a0011
 ;;;; psgml-parse.el --- Parser for SGML-editing mode with parsing support
-;; $Id: psgml-parse.el,v 1.1.1.1 1996/12/18 03:35:21 steve Exp $
+;; $Id: psgml-parse.el,v 1.1.1.2 1996/12/18 03:47:15 steve Exp $
 ;; Copyright (C) 1994, 1995 Lennart Staflin
 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
 ;; Acknowledgment:
 (defvar sgml-current-localcat nil
 "Value of `sgml-local-catalogs' in main buffer. Valid during parsing.")
 (defvar sgml-current-local-ecat nil
 "Value of `sgml-local-ecat-files' in main buffer. Valid during parsing.")
+(defvar sgml-current-top-buffer nil
+"The buffer of the document entity, the main buffer.
+Valid during parsing. This is used to find current directory for
+catalogs.")
 (defvar sgml-current-state nil
 "Current state in content model or model type if CDATA, RCDATA or ANY.")
 (defvar sgml-current-shortmap nil
 ;; 1. moves for required tokens, 2. moves for optional tokens.
 ;; By design these are keept in two different sets.
 ;; [Alt: they could perhaps have been keept in one set but
 ;; marked in different ways.]
-;; The &-model groups creates too big state machines, therefor
+;; The and-model groups creates too big state machines, therefor
-;; there is a datastruture called &-node.
+;; there is a datastruture called and-node.
-;; A &-node is a specification for a dfa that has not been computed.
+;; A and-node is a specification for a dfa that has not been computed.
 ;; It contains a set of dfas that all have to be traversed befor going
-;; to the next state.  The &-nodes are only stored in moves and are
+;; to the next state.  The and-nodes are only stored in moves and are
-;; not seen by the parser.  When a move is taken the &-node is converted
+;; not seen by the parser.  When a move is taken the and-node is converted
-;; to a &-state.
+;; to a and-state.
-;; A &-state keeps track of which dfas still need to be
+;; A and-state keeps track of which dfas still need to be
 ;; traversed and the state of the current dfa.
 ;; move = <token, node>
-;; node = normal-state | &-node
+;; node = normal-state | and-node
-;; &-node = <dfas, next>
+;; and-node = <dfas, next>
 ;; where: dfas is a set of normal-state
 ;;        next is a normal-state
-;; State = normal-state | &-state
+;; State = normal-state | and-state
 ;; The parser only knows about the state type.
 ;; normal-state = <opts, reqs>
 ;; where: opts is a set of moves for optional tokens
 ;; 	  reqs is a set of moves for required tokens
-;; &-state = <substate, dfas, next>
+;; and-state = <substate, dfas, next>
 ;; where: substate is a normal-state
 ;;        dfas is a set of states
 ;;        next is the next state
-;; The &-state is only used during the parsing.
+;; The and-state is only used during the parsing.
 ;; Primitiv functions to get data from parse state need
-;; to know both normal-state and &-state.
+;; to know both normal-state and and-state.
 ;;; Representations:
 ;;move: (token . node)
 (let ((s1 (sgml-make-state))
 	(s2 (sgml-make-state)))
 (sgml-add-req-move s1 token s2)
 s1))
-;;&-state: (state next . dfas)
+;;and-state: (state next . dfas)
-(defsubst sgml-make-&state (state dfas next)
+(defsubst sgml-make-and-state (state dfas next)
 (cons state (cons next dfas)))
-(defsubst sgml-step-&state (state &state)
+(defsubst sgml-step-and-state (state and-state)
-(cons state (cdr &state)))
+(cons state (cdr and-state)))
-(defsubst sgml-&state-substate (s)
+(defsubst sgml-and-state-substate (s)
 (car s))
-(defsubst sgml-&state-dfas (s)
+(defsubst sgml-and-state-dfas (s)
 (cddr s))
-(defsubst sgml-&state-next (s)
+(defsubst sgml-and-state-next (s)
 (cadr s))
-;;&-node:  (next . dfas)
+;;and-node:  (next . dfas)
-(defsubst sgml-make-&node (dfas next)
+(defsubst sgml-make-and-node (dfas next)
 (cons next dfas))
-(defmacro sgml-&node-next (n)
+(defmacro sgml-and-node-next (n)
 (` (car (, n))))
-(defmacro sgml-&node-dfas (n)
+(defmacro sgml-and-node-dfas (n)
 (` (cdr (, n))))
 ;;; Using states
 		 (sgml-moves-lookup token (sgml-state-reqs state)))))
 (if c
 	  (let ((dest (sgml-move-dest c)))
 	    (if (sgml-normal-state-p dest)
 		dest
-	      ;; dest is a &-node
+	      ;; dest is a and-node
-	      (sgml-next-sub& (sgml-&node-dfas dest)
+	      (sgml-next-sub-and (sgml-and-node-dfas dest)
+				 token
+				 (sgml-and-node-next dest)))))))
+(t					;state is a and-state
+(sgml-get-and-move state token))))
+(defun sgml-get-and-move (state token)
+;; state is a and-state
+(let ((m (sgml-get-move (sgml-and-state-substate state) token)))
+(cond (m (cons m (cdr state)))
+	  ((sgml-final (sgml-and-state-substate state))
+	   (sgml-next-sub-and (sgml-and-state-dfas state)
 			      token
-			      (sgml-&node-next dest)))))))
+			      (sgml-and-state-next state))))))
-(t					;state is a &-state
-(sgml-get-&move state token))))
+(defun sgml-next-sub-and (dfas token next)
-(defun sgml-get-&move (state token)
-;; state is a &-state
-(let ((m (sgml-get-move (sgml-&state-substate state) token)))
-(cond (m (cons m (cdr state)))
-	  ((sgml-state-final-p (sgml-&state-substate state))
-	   (sgml-next-sub& (sgml-&state-dfas state)
-			   token
-			   (sgml-&state-next state))))))
-(defun sgml-next-sub& (dfas token next)
 "Compute the next state, choosing from DFAS and moving by TOKEN.
 If this is not possible, but all DFAS are final, move by TOKEN in NEXT."
 (let ((allfinal t)
 	(l dfas)
 	(res nil)
 	s1 s2)
 (while (and l (not res))
 (setq s1 (car l)
 	    allfinal (and allfinal (sgml-state-final-p s1))
 	    s2 (sgml-get-move s1 token)
-	    res (and s2 (sgml-make-&state s2 (remq s1 dfas) next))
+	    res (and s2 (sgml-make-and-state s2 (remq s1 dfas) next))
 	    l (cdr l)))
 (cond (res)
 	  (allfinal (sgml-get-move next token)))))
 (defsubst sgml-tokens-of-moves (moves)
 	  moves))
 (defun sgml-required-tokens (state)
 (if (sgml-normal-state-p state)
 (sgml-tokens-of-moves (sgml-state-reqs state))
-(or (sgml-required-tokens (sgml-&state-substate state))
+(or (sgml-required-tokens (sgml-and-state-substate state))
-(loop for s in (sgml-&state-dfas state)
+(loop for s in (sgml-and-state-dfas state)
 nconc (sgml-tokens-of-moves (sgml-state-reqs s)))
-(sgml-tokens-of-moves (sgml-state-reqs (sgml-&state-next state))))))
+(sgml-tokens-of-moves (sgml-state-reqs (sgml-and-state-next state))))))
 (defsubst sgml-final (state)
 (if (sgml-normal-state-p state)
 (sgml-state-final-p state)
-(sgml-final& state)))
+(sgml-final-and state)))
-(defun sgml-final& (state)
+(defun sgml-final-and (state)
-(and (sgml-final (sgml-&state-substate state))
+(and (sgml-final (sgml-and-state-substate state))
-(loop for s in (sgml-&state-dfas state)
+(loop for s in (sgml-and-state-dfas state)
 	     always (sgml-state-final-p s))
-(sgml-state-final-p (sgml-&state-next state))))
+(sgml-state-final-p (sgml-and-state-next state))))
 (defun sgml-optional-tokens (state)
 (if (sgml-normal-state-p state)
 (sgml-tokens-of-moves (sgml-state-opts state))
 (nconc
-(sgml-optional-tokens (sgml-&state-substate state))
+(sgml-optional-tokens (sgml-and-state-substate state))
-(if (sgml-final (sgml-&state-substate state))
+(if (sgml-final (sgml-and-state-substate state))
-	 (loop for s in (sgml-&state-dfas state)
+	 (loop for s in (sgml-and-state-dfas state)
 	       nconc (sgml-tokens-of-moves (sgml-state-opts s))))
-(if (loop for s in (sgml-&state-dfas state)
+(if (loop for s in (sgml-and-state-dfas state)
 always (sgml-state-final-p s))
-	 (sgml-tokens-of-moves (sgml-state-opts (sgml-&state-next state)))))))
+	 (sgml-tokens-of-moves
+	  (sgml-state-opts (sgml-and-state-next state)))))))
 ;;;; Attribute Types
 ;;; Basic Types
 (sgml-dtd-eltypes dtd))
 (nreverse *res*)))
 ;;;; Load a saved dtd
+;;; Wing addition
 (defmacro sgml-char-int (ch)
 (if (fboundp 'char-int)
 (` (char-int (, ch)))
 ch))
 (defsubst sgml-read-octet ()
+;; Wing change
 (prog1 (sgml-char-int (following-char))
 (forward-char)))
 (defsubst sgml-read-number ()
 "Read a number.
 (defun sgml-read-model ()
 (let* ((n (sgml-read-number))
 	 (sgml-read-nodes (make-vector n nil)))
 (loop for i below n do (aset sgml-read-nodes i (sgml-make-state)))
 (loop for e across sgml-read-nodes do
-	  (cond ((eq 255 (sgml-read-peek))	; a &node
+	  (cond ((eq 255 (sgml-read-peek))	; a and-node
 		 (sgml-read-octet)		; skip
-		 (setf (sgml-&node-next e) (sgml-read-node-ref))
+		 (setf (sgml-and-node-next e) (sgml-read-node-ref))
-		 (setf (sgml-&node-dfas e) (sgml-read-model-seq)))
+		 (setf (sgml-and-node-dfas e) (sgml-read-model-seq)))
 		(t			; a normal-state
 		 (setf (sgml-state-opts e) (sgml-read-moves))
 		 (setf (sgml-state-reqs e) (sgml-read-moves)))))
 (aref sgml-read-nodes 0)))
 	  do (sgml-entity-declare name parameters 'text val))
 (sgml-push-to-entity dtd-file)
 (sgml-check-dtd-subset)
 (sgml-pop-entity)
 (erase-buffer)
+;; For XEmacs-20.0/Mule
+(setq file-coding-system 'noconv)
 (sgml-write-dtd sgml-dtd-info to-file)
 t))
 (defun sgml-check-entities (params1 params2)
 "Check that PARAMS1 is compatible with PARAMS2."
 (defun sgml-bdtd-merge ()
 "Merge the binary coded dtd in the current buffer with the current dtd.
 The current dtd is the variable sgml-dtd-info.  Return t if mereged
 was successfull or nil if failed."
+(setq file-coding-system 'noconv)
 (goto-char (point-min))
 (sgml-read-sexp)			; skip filev
 (let ((dependencies (sgml-read-sexp))
 	(parameters (sgml-read-sexp))
 	(gc-cons-threshold (max gc-cons-threshold 500000))
 (not (eq (sgml-entity-type entity) 'text)))
 (defun sgml-entity-marked-undefined-p (entity)
 (cdddr entity))
-(defun sgml-entity-insert-text (entity &optional ptype)
-"Insert the text of ENTITY.
-PTYPE can be 'param if this is a parameter entity."
-(let ((text (sgml-entity-text entity)))
-(cond
-((stringp text)
-(insert text))
-(t
-(unless (sgml-insert-external-entity text
-				   (or ptype
-				       (sgml-entity-type entity))
-				   (sgml-entity-name entity))
-	;; Mark entity as not found
-	(setcdr (cddr entity) t)	;***
-	)))))
-(defun sgml-entity-file (entity &optional ptype)
-(sgml-external-file (sgml-entity-text entity)
-		      (or ptype (sgml-entity-type entity))
-		      (sgml-entity-name entity)))
 ;;; Entity tables
 ;; Represented by a cons-cell whose car is the default entity (or nil)
 ;; and whose cdr is as an association list.
 (defun sgml-merge-entity-tables (tab1 tab2)
 "Merge entity table TAB2 into TAB1.  TAB1 is modified."
 (nconc tab1 (cdr tab2))
 (setcar tab1 (or (car tab1) (car tab2))))
+(defun sgml-entity-insert-text (entity &optional ptype)
+"Insert the text of ENTITY.
+PTYPE can be 'param if this is a parameter entity."
+(let ((text (sgml-entity-text entity)))
+(cond
+((stringp text)
+(insert text))
+(t
+(sgml-insert-external-entity text
+				   (or ptype
+				       (sgml-entity-type entity))
+				   (sgml-entity-name entity))))))
 ;;;; External identifyer resolve
-(defun sgml-cache-catalog (file cache-var parser-fun)
+(defun sgml-cache-catalog (file cache-var parser-fun
+				&optional default-dir)
 "Return parsed catalog.
 FILE is the file containing the catalog.  Maintains a cache of parsed
 catalog files in variable CACHE-VAR. The parsing is done by function
 PARSER-FUN that should parse the current buffer and return the parsed
 repreaentation of the catalog."
-(setq file (expand-file-name file))
+(setq file (file-truename (expand-file-name file default-dir)))
 (and
 (file-readable-p file)
 (let ((c (assoc file (symbol-value cache-var)))
 	 (modtime (elt (file-attributes file) 5)))
 (if (and c (equal (second c) modtime))
 	 (sgml-pop-entity)
 	 (push (cons file (cons modtime new)) (symbol-value cache-var))
 	 (message "Loading %s ... done" file)
 	 new)))))
+(defun sgml-main-directory ()
+"Directory of the document entity."
+(let ((cb (current-buffer)))
+(set-buffer sgml-current-top-buffer)
+(prog1 default-directory
+(set-buffer cb))))
+(defun sgml-trace-lookup (&rest args)
+"Log a message like `sgml-log-message', but only if `sgml-trace-entity-lookup' is set."
+(when sgml-trace-entity-lookup
+(apply (function sgml-log-message) args)))
 (defun sgml-catalog-lookup (files pubid type name)
 "Look up the public identifier/entity name in catalogs.
 FILES is a list of catalogs to use. PUBID is the public identifier
 \(if any). TYPE is the entity type and NAME is the entity name."
 (cond ((eq type 'param)
 	 (setq name (format "%%%s" name)
 	       type 'entity))
 	((eq type 'dtd)
 	 (setq type 'doctype)))
+;;(sgml-trace-lookup "  [pubid='%s' type=%s name='%s']" pubid type name)
 (loop
 for f in files thereis
 (let ((cat (sgml-cache-catalog f 'sgml-catalog-assoc
-				  (function sgml-parse-catalog-buffer))))
+				  (function sgml-parse-catalog-buffer)
+				  (sgml-main-directory))))
+(sgml-trace-lookup "  catalog: %s %s"
+			(expand-file-name f (sgml-main-directory))
+			(if (null cat) "empty/non existent" "exists"))
 (or
 ;; Giv PUBLIC entries priority over ENTITY and DOCTYPE
 (if pubid
 	  (loop for (key cname file) in cat
-		thereis (and (eq 'public key)
+		thereis (if (and (eq 'public key)
-			     (string= pubid cname)
+				 (string= pubid cname))
-			     (file-readable-p file)
+			    (if (file-readable-p file)
-			     file)))
+				(progn
+				  (sgml-trace-lookup "  >> %s [by pubid]" file)
+				  file)
+			      (progn
+				(sgml-trace-lookup "   !unreadable %s" file)
+				nil)))))
 (loop for (key cname file) in cat
-	    thereis (and (eq type key)
+	    ;;do (sgml-trace-lookup "    %s %s" key cname)
-			 (or (null cname)
+	    thereis (if (and (eq type key)
-			     (string= name cname))
+			     (or (null cname)
-			 (file-readable-p file)
+				 (string= name cname)))
-			 file))))))
+			(if (file-readable-p file)
+			    (progn
-(defun sgml-search-catalog (func filter)
+			      (sgml-trace-lookup "  >> %s [by %s %s]"
-(loop
+						 file key cname)
-for files in (list sgml-local-catalogs sgml-catalog-files)
+			      file)
-thereis
+			  (progn
-(loop for file in files thereis
+			    (sgml-trace-lookup "   !unreadable %s" file)
-	 (loop for entry in (sgml-cache-catalog
+			    nil))))))))
-			     file 'sgml-catalog-assoc
-			     (function sgml-parse-catalog-buffer))
-	       when (or (null filter)
-			(memq (car entry) filter))
-	       thereis (funcall func entry)))))
 (defun sgml-path-lookup (extid type name)
 (let* ((pubid (sgml-extid-pubid extid))
 	 (sysid (sgml-extid-sysid extid))
 	 (subst (list '(?% ?%))))
 Optional argument TYPE should be the type of entity and NAME should be
 the entity name."
 ;; extid is (pubid . sysid)
 (let ((pubid (sgml-extid-pubid extid)))
 (when pubid (setq pubid (sgml-canonize-pubid pubid)))
+(sgml-trace-lookup "Start looking for %s entity %s public %s system %s"
+		       (or type "-")
+		       (or name "?")
+		       pubid
+		       (sgml-extid-sysid extid))
 (or (if sgml-system-identifiers-are-preferred
 	    (sgml-lookup-sysid-as-file extid))
 	(sgml-catalog-lookup sgml-current-localcat pubid type name)
 	(sgml-catalog-lookup sgml-catalog-files pubid type name)
 	(if (not sgml-system-identifiers-are-preferred)
 ;; Parse a buffer full of catalogue entries.
 (defun sgml-parse-catalog-buffer ()
 "Parse all entries in a catalogue."
+(sgml-trace-lookup "  (Parsing catalog)")
 (loop
 while (sgml-skip-cs)
 for type = (downcase (sgml-check-cat-literal))
 for class = (cdr (assoc type '(("public" . public) ("dtddecl" . public)
 				  ("entity" . name)   ("linktype" . name)
 (defun sgml-epos-eref (epos)
 (if (consp epos)
 (car epos)))
 (defun sgml-epos-pos (epos)
+"The buffer position of EPOS withing its entity."
 (if (consp epos)
 (cdr epos)
 epos))
 (defun sgml-bpos-p (epos)
+"True if EPOS is a position in the main buffer."
 (numberp epos))
 (defun sgml-strict-epos-p (epos)
+"True if EPOS is a position in an entity other then the main buffer."
 (consp epos))
 (defun sgml-epos (pos)
 "Convert a buffer position POS into an epos."
 (if sgml-current-eref
 (sgml-make-epos sgml-current-eref pos)
 pos))
-(defun sgml-epos-erliest (epos)
+(defun sgml-epos-before (epos)
+"The last position in buffer not after EPOS.
+If EPOS is a buffer position this is the same. If EPOS is in an entity
+this is the buffer position before the entity reference."
 (while (consp epos)
 (setq epos (sgml-eref-start (sgml-epos-eref epos))))
 epos)
-(defun sgml-epos-latest (epos)
+(defun sgml-epos-after (epos)
+"The first position in buffer after EPOS.
+If EPOS is in an other entity, buffer position is after
+entity reference leading to EPOS."
 (while (consp epos)
 (setq epos (sgml-eref-end (sgml-epos-eref epos))))
 epos)
 (defun sgml-epos-promote (epos)
+"Convert position in entity structure EPOS to a buffer position.
+If EPOS is in an entity, the buffer position will be the position
+before the entity reference if EPOS is first character in entity
+text. Otherwise buffer position will be after entity reference."
 (while (and (consp epos)
 	      (= (cdr epos) 1))
 (setq epos (sgml-eref-start (car epos))))
-(sgml-epos-latest epos))
+(sgml-epos-after epos))
 ;;;; DTD repository
 ;;compiled-dtd: extid -> Compiled-DTD?
 ;;extid-cdtd-name: extid -> file?
 (defun sgml-try-merge-compiled-dtd (pubid file)
 (when pubid (setq pubid (sgml-canonize-pubid pubid)))
 (when file (setq file (expand-file-name file)))
 (sgml-debug "Find compiled dtd for %s %s" pubid file)
 (let ((ce (or (sgml-ecat-lookup sgml-current-local-ecat pubid file)
-		(sgml-ecat-lookup sgml-ecat-files pubid file)))
+		(sgml-ecat-lookup sgml-ecat-files pubid file))))
-	cfile dtd ents)
 (and ce
 	 (let ((cfile (car ce))
 	       (ents  (cdr ce)))
 	   (sgml-debug "Found %s" cfile)
 	   (if (sgml-use-special-case)
 (defun sgml-push-to-entity (entity &optional ref-start type)
 "Set current buffer to a buffer containing the entity ENTITY.
 ENTITY can also be a file name.  Optional argument REF-START should be
 the start point of the entity reference.  Optional argument TYPE,
 overrides the entity type in entity look up."
+(sgml-debug "Push to %s"
+	      (cond ((stringp entity)
+		     (format "string '%s'" entity))
+		    (t
+		     (sgml-entity-name entity))))
 (when ref-start
+;; don't consider a RS shortref here again
 (setq sgml-rs-ignore-pos ref-start))
 (unless (and sgml-scratch-buffer
 	       (buffer-name sgml-scratch-buffer))
 (setq sgml-scratch-buffer (generate-new-buffer " *entity*")))
 (let ((cb (current-buffer))
 				  (sgml-make-entity entity nil nil)
 				entity)
 			      (sgml-epos (or ref-start (point)))
 			      (sgml-epos (point)))))
 (set-buffer sgml-scratch-buffer)
+;; For MULE to not misinterpret binary data set the mc-flag
+;; (reported by Jeffrey Friedl <jfriedl@nff.ncl.omron.co.jp>)
+(setq mc-flag nil)
+;; For XEmacs 20.0/Mule
+(setq file-coding-system 'noconv)
 (when (eq sgml-scratch-buffer (default-value 'sgml-scratch-buffer))
 (make-local-variable 'sgml-scratch-buffer)
 (setq sgml-scratch-buffer nil))
+(when after-change-function		;***
+(message "OOPS: after-change-function not NIL in scratch buffer %s: %s"
+	       (current-buffer)
+	       after-change-function)
+(setq before-change-function nil
+	    after-change-function nil))
 (setq sgml-last-entity-buffer (current-buffer))
 (erase-buffer)
 (setq default-directory dd)
 (make-local-variable 'sgml-current-eref)
 (setq sgml-current-eref eref)
 					; as #RS if internal entity.
 	  (if (or (stringp entity)
 		  (stringp (sgml-entity-text entity)))
 	      (point)
 	    0))
+(when sgml-buffer-parse-state
+(sgml-debug "-- pstate set in scratch buffer")
+(setq sgml-buffer-parse-state nil))
 (cond
 ((stringp entity)			; a file name
 (save-excursion (insert-file-contents entity))
 (setq default-directory (file-name-directory entity)))
-((and sgml-parsing-dtd
+((consp (sgml-entity-text entity)) ; external id?
-	   (consp (sgml-entity-text entity))) ; external id?
+(let* ((extid (sgml-entity-text entity))
-(let ((file (sgml-entity-file entity type)))
+	     (file
-	(sgml-debug "Push to %s = %s" (sgml-entity-text entity) file)
+	      (sgml-external-file extid
+				  (or type (sgml-entity-type entity))
+				  (sgml-entity-name entity))))
+	(when sgml-parsing-dtd
+	  (push (or file t)
+		(sgml-dtd-dependencies sgml-dtd-info)))
+	(sgml-debug "Push to %s = %s" extid file)
 	(cond
-	 ((and file
+	 ((and file sgml-parsing-dtd
-	       (sgml-try-merge-compiled-dtd (car (sgml-entity-text entity))
+	       (sgml-try-merge-compiled-dtd (sgml-extid-pubid extid)
 					    file))
 	  (goto-char (point-max)))
 	 (file
 	  ;; fifth arg not available in early v19
 	  (erase-buffer)
 	  (insert-file-contents file nil nil nil)
 	  (setq default-directory (file-name-directory file))
-	  (goto-char (point-min))
+	  (goto-char (point-min)))
-	  (push file (sgml-dtd-dependencies sgml-dtd-info)))
+	 (t ;; No file for entity
-	 (t
+	  (save-excursion
-	  (push t (sgml-dtd-dependencies sgml-dtd-info))
+	    (let* ((pubid (sgml-extid-pubid extid))
-	  (save-excursion (sgml-entity-insert-text entity type))))))
+		   (sysid (sgml-extid-sysid extid)))
-(t
+	      (or (if sysid		; try the sysid hooks
-(save-excursion (sgml-entity-insert-text entity type))))))
+		      (loop for fn in sgml-sysid-resolve-functions
+			    thereis (funcall fn sysid)))
+		  (progn
+		    ;; Mark entity as not found
+		    (setcdr (cddr entity) t) ;***
+		    (sgml-log-warning "External entity %s not found"
+				      (sgml-entity-name entity))
+		    (when pubid
+		      (sgml-log-warning "  Public identifier %s" pubid))
+		    (when sysid
+		      (sgml-log-warning "  System identfier %s" sysid))
+		    nil))))))))
+(t ;; internal entity
+(save-excursion
+	(insert (sgml-entity-text entity)))))))
 (defun sgml-pop-entity ()
 (cond ((and (boundp 'sgml-previous-buffer)
 	      (bufferp sgml-previous-buffer))
 	 (sgml-debug "Exit entity")
 	    (:constructor sgml-make-tree
 			  (eltype stag-epos stag-len  parent level
 				  excludes includes pstate net-enabled
 				  conref &optional shortmap pshortmap asl)))
 eltype				; element object
-;;start					; start point in buffer
+;;start				; start point in buffer
 ;;end					; end point in buffer
 stag-epos				; start-tag entity position
 etag-epos				; end-tag entity position
 stag-len				; length of start-tag
 etag-len				; length of end-tag
 pshortmap				; parents shortmap
 asl					; attribute specification list
 )
-;;element-end (e):
-;;     If bpos-p (etag-epos (e)):
-;;          return etag-epos (e) + etag-len (e)
-;;     If etag-len (e) = 0: return promote (etag-epos (e))
-;;     else: return latest (etag-epos (e))
 (defun sgml-tree-end (tree)
-"Buffer position after end of TREE"
+"Buffer position after end of TREE."
 (let ((epos (sgml-tree-etag-epos tree))
 	(len (sgml-tree-etag-len tree)))
 (cond ((sgml-bpos-p epos)
 	   (+ epos len))
 	  ((zerop len)
 	   (sgml-epos-promote epos))
 	  (t
-	   (sgml-epos-latest epos)))))
+	   (sgml-epos-after epos)))))
 ;;;; (text) Element view of parse tree
 (defmacro sgml-alias-fields (orig dest &rest fields)
 (cond ((sgml-bpos-p epos)
 	   (+ epos len))
 	  ((zerop len)
 	   (sgml-epos-promote epos))
 	  (t
-	   (sgml-epos-latest epos)))))
+	   (sgml-epos-after epos)))))
 (defun sgml-element-empty (element)
 "True if ELEMENT is empty."
 (or (eq sgml-empty (sgml-element-model element))
 (sgml-tree-conref element)))
 (if (memq this-command '(backward-char previous-line backward-word))
 	  (goto-char (or (previous-single-property-change (point) 'invisible)
 			 (point-min)))
 	(goto-char (or (next-single-property-change (point) 'invisible)
 		       (point-max)))))
-(when (and (not (input-pending-p))
+(when (and (not executing-macro)
 	       (or sgml-live-element-indicator
-		   sgml-set-face))
+		   sgml-set-face)
-(let ((deactivate-mark nil)
+	       (not (null sgml-buffer-parse-state))
-	    (sgml-suppress-warning t)
+	       (sit-for 0))
-	    (oldname sgml-current-element-name))
+(let ((deactivate-mark nil))
-	(condition-case nil
+	(sgml-need-dtd)
-	    (save-excursion
+	(let ((start
+	       (save-excursion (sgml-find-start-point (point))
+			       (sgml-pop-all-entities)
+			       (point)))
+	      (eol-pos
+	       (save-excursion (end-of-line 1) (point))))
+	  (let ((quiet (< (- (point) start) 500)))
+	    ;;(message "Should parse %s to %s => %s" start (point) quiet)
+	    (when (if quiet
+		      t
+		    (setq sgml-current-element-name "?")
+		    (sit-for 1))
+	      ;; Find current element
 	      (cond ((and (memq this-command sgml-users-of-last-element)
 			  sgml-last-element)
 		     (setq sgml-current-element-name
 			   (sgml-element-gi sgml-last-element)))
 		    (sgml-live-element-indicator
-		     (setq sgml-current-element-name "*error*")
 		     (save-excursion
-		       (sgml-parse-to (point) (function input-pending-p)))
+		       (condition-case nil
-		     (unless (input-pending-p)
+			   (sgml-parse-to
-		       (setq sgml-current-element-name
+			    (point) (function input-pending-p) quiet)
-			     (sgml-element-gi sgml-current-tree)))))
+			 (error
-	      (unless (input-pending-p)
+			  (setq sgml-current-element-name "*error*")))
-		(force-mode-line-update)
+		       (unless (input-pending-p)
-		(when (and sgml-set-face
+			 (setq sgml-current-element-name
-			   (null
+			       (sgml-element-gi sgml-current-tree))))))
-			    (sgml-tree-etag-epos
+	      ;; Set face on current line
-			     (sgml-pstate-top-tree sgml-buffer-parse-state))))
+	      (when (and sgml-set-face (not (input-pending-p)))
-		  (sit-for 0)
+		(save-excursion
-		  (sgml-parse-until-end-of nil nil
+		  (condition-case nil
-					   (function input-pending-p)
+		      (sgml-parse-to
-					   t))))
+		       eol-pos (function input-pending-p) quiet)
-	  (error nil))))))
+		    (error nil)))))))
+	;; Set face in rest of buffer
+	(sgml-fontify-buffer 6)		;*** make option for delay
+	))))
+(defun sgml-fontify-buffer (delay)
+(and
+sgml-set-face
+(null (sgml-tree-etag-epos
+	  (sgml-pstate-top-tree sgml-buffer-parse-state)))
+(sit-for delay)
+(condition-case nil
+(save-excursion
+	 (message "Fontifying...")
+	 (sgml-parse-until-end-of nil nil
+				  (function input-pending-p)
+				  t)
+	 (message "Fontifying...done"))
+(error nil))))
 (defun sgml-set-active-dtd-indicator (name)
 (set (make-local-variable 'sgml-active-dtd-indicator)
 (list (format " [%s" name)
 	     '(sgml-live-element-indicator ("/" sgml-current-element-name))
 (defstruct (sgml-pstate
 	    (:constructor sgml-make-pstate (dtd top-tree)))
 dtd
 top-tree)
-(defsubst sgml-excludes ()
+;(defsubst sgml-excludes ()
-(sgml-tree-excludes sgml-current-tree))
+;  (sgml-tree-excludes sgml-current-tree))
-(defsubst sgml-includes ()
+;(defsubst sgml-includes ()
-(sgml-tree-includes sgml-current-tree))
+;  (sgml-tree-includes sgml-current-tree))
 (defsubst sgml-current-mixed-p ()
 (sgml-element-mixed sgml-current-tree))
 (defun sgml-set-initial-state (dtd)
 "Set initial state of parsing"
 (make-local-variable 'before-change-function)
 (setq before-change-function 'sgml-note-change-at)
-(set (make-local-variable 'after-change-function)
+(make-local-variable 'after-change-function)
-'sgml-set-face-after-change)
+(setq after-change-function 'sgml-set-face-after-change)
 (sgml-set-active-dtd-indicator (sgml-dtd-doctype dtd))
 (let ((top-type			; Fake element type for the top
 					; node of the parse tree
 	 (sgml-make-eltype "#DOC")	; was "Document (no element)"
 	 ))
 (defun sgml-set-parse-state (tree where)
 "Set parse state from TREE, either from start of TREE if WHERE is start
 or from after TREE if WHERE is after."
 (setq sgml-current-tree tree
-	sgml-markup-tree tree)
+	sgml-markup-tree tree
+	sgml-rs-ignore-pos 0 )
 (let ((empty
 	 (sgml-element-empty tree)))
 (cond ((and (eq where 'start)
 		(not empty))
 	   (setq sgml-current-state (sgml-element-model sgml-current-tree)
 	      eltype
 	      (sgml-promoted-epos before-tag after-tag) ; stag-epos
 	      (- after-tag before-tag)	; stag-len
 	      sgml-current-tree		; parent
 	      (1+ (sgml-tree-level sgml-current-tree)) ; level
-	      (append (sgml-eltype-excludes eltype) (sgml-excludes))
+	      (append (sgml-eltype-excludes eltype)
-	      (append (sgml-eltype-includes eltype) (sgml-includes))
+		      (sgml-tree-excludes sgml-current-tree))
+	      (append (sgml-eltype-includes eltype)
+		      (sgml-tree-includes sgml-current-tree))
 	      sgml-current-state
 	      (if (sgml-tree-net-enabled sgml-current-tree) 1)
 	      conref
 	      newmap
 	      sgml-current-shortmap
 ;;	     (setf (sgml-tree-next u) nt))
 ;;	    (t
 ;;	     (setf (sgml-tree-content sgml-current-tree) nt))))
 ;; Install new node in tree
 (cond (sgml-previous-tree
+	   (sgml-debug "Open element %s: after %s"
+		       eltype (sgml-tree-eltype sgml-previous-tree))
 	   (setf (sgml-tree-next sgml-previous-tree) nt))
 	  (t
+	   (sgml-debug "Open element %s: first in %s"
+		       eltype (sgml-tree-eltype sgml-current-tree))
 	   (setf (sgml-tree-content sgml-current-tree) nt)))
 ;; Prune tree
 ;; *** all the way up?  tree-end = nil?
 (setf (sgml-tree-next sgml-current-tree) nil)
 ;; Set new state
 (when (or (eq sgml-close-element-trap t)
 	    (eq sgml-close-element-trap sgml-current-tree))
 (setq sgml-goal (point)))
 (when sgml-throw-on-element-change
 (throw sgml-throw-on-element-change 'end))
+(sgml-debug "Close element %s" (sgml-tree-eltype sgml-current-tree))
 (setf (sgml-tree-etag-epos sgml-current-tree)
 	;;(sgml-promoted-epos before-tag after-tag)
 	(sgml-epos before-tag))
 (setf (sgml-tree-etag-len sgml-current-tree) (- after-tag before-tag))
 (run-hooks 'sgml-close-element-hook)
 (sgml-tree-parent tree))
 (defun sgml-note-change-at (at &optional end)
 ;; Inform the cache that there have been some changes after AT
 (when sgml-buffer-parse-state
+(sgml-debug "sgml-note-change-at %s" at)
 (let ((u (sgml-pstate-top-tree sgml-buffer-parse-state)))
 (when u
 	;;(message "%d" at)
 	(while
 	    (cond
 (while				; Until token accepted
 	(cond
 	 ;; Test if accepted in state
 	 ((or (eq state sgml-any)
 	      (and (sgml-model-group-p state)
-		   (not (memq token (sgml-excludes)))
+		   (not (memq token (sgml-tree-excludes tree)))
-		   (or (memq token (sgml-includes))
+		   (or (memq token (sgml-tree-includes tree))
 		       (sgml-get-move state token))))
 	  nil)
 	 ;; Test if end tag implied
 	 ((or (eq state sgml-empty)
 	      (and (sgml-final-p state)
 		   (not (eq tree sgml-top-tree))))
 	  (unless (eq state sgml-empty)	; not realy implied
 	    (push t imps))
 	  (setq state (sgml-tree-pstate tree)
 (nconc table (list (cons name map))))
 (defun sgml-lookup-shortref-map (table name)
 (cdr (assoc name (cdr table))))
+(defun sgml-lookup-shortref-name (table map)
+(car (rassq map (cdr table))))
 (defun sgml-merge-shortmaps (tab1 tab2)
 "Merge tables of short reference maps TAB2 into TAB1, modifying TAB1."
 (nconc tab1 (cdr tab2)))
 ;;;; Parse markup declarations
 (sgml-setup-doctype (sgml-check-name)
 			  (sgml-parse-external))
 (message "Parsing doctype...done"))))
 (setq sgml-markup-type 'doctype))
+(defun sgml-check-end-of-entity (type)
+(unless (eobp)
+(sgml-parse-error "Illegal character '%c' in %s"
+		      (following-char)
+		      type)))
 (defun sgml-setup-doctype (docname external)
 (let ((sgml-parsing-dtd t))
 (setq sgml-no-elements 0)
 (setq sgml-dtd-info (sgml-make-dtd docname))
 ;;(setq sgml-dtd-shortmaps nil)
 (sgml-skip-ps)
 (cond
 ((sgml-parse-delim "DSO")
-(sgml-check-dtd-subset)
+(let ((original-buffer (current-buffer)))
-(sgml-check-delim "DSC")))
+	(sgml-check-dtd-subset)
+	(if (eq (current-buffer) original-buffer)
+	    (sgml-check-delim "DSC")
+	  (sgml-parse-error "Illegal character '%c' in doctype declaration"
+			    (following-char))))))
 (cond (external
 	   (sgml-push-to-entity (sgml-make-entity docname 'dtd external))
-	   (unless (eobp)
+	   (sgml-check-dtd-subset)
-	     (sgml-check-dtd-subset)
+	   (sgml-check-end-of-entity "DTD subset")
-	     (unless (eobp)
-	       (sgml-parse-error "DTD subset ended")))
 	   (sgml-pop-entity)))
 ;;;    (loop for map in sgml-dtd-shortmaps do
 ;;;	  (sgml-add-shortref-map
 ;;;	   (sgml-dtd-shortmaps sgml-dtd-info)
 ;;;	   (car map)
 	   ;;(search-forward "[")
 	   (sgml-skip-marked-section))
 	  (t (forward-char 1)))))
 (defun sgml-do-usemap ()
-(let (mapname associated)
+(let (mapname)
 ;;(setq sgml-markup-type 'usemap)
 (unless (sgml-parse-rni "empty")
 (setq mapname (sgml-check-name)))
 (sgml-skip-ps)
 (cond
 ;; trap is used the parser is usually called with the end of the
 ;; buffer as the goal point.
 (defun sgml-need-dtd ()
 "Make sure that an eventual DTD is parsed or loaded."
+(sgml-pop-all-entities)
 (sgml-cleanup-entities)
 (when (null sgml-buffer-parse-state)	; first parse in this buffer
 ;;(sgml-set-initial-state)		; fall back DTD
 (add-hook 'pre-command-hook 'sgml-reset-log)
 (make-local-variable 'sgml-auto-fill-inhibit-function)
 (setq sgml-auto-fill-inhibit-function (function sgml-in-prolog-p))
 (if sgml-default-dtd-file
 	(sgml-load-dtd sgml-default-dtd-file)
 (sgml-load-doctype)))
+(sgml-debug "Need dtd getting state from %s" (buffer-name))
 (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state)
 	sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
 (sgml-set-global))
 (defun sgml-modify-dtd (modifier)
 (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state)
 	sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
 (sgml-set-global)
+;;*** what is sgml-current-tree now?
 (while (stringp (cadr modifier))	; Loop thru the context elements
 (let ((et (sgml-lookup-eltype (car modifier))))
 (sgml-open-element et nil (point-min) (point-min))
 (setq modifier (cdr modifier))))
 	    do (setq sgml-current-state
 		     (sgml-get-move sgml-current-state
 				    (sgml-lookup-eltype seenel))))))
 (let ((top (sgml-pstate-top-tree sgml-buffer-parse-state)))
-(setf (sgml-tree-includes top) (sgml-includes))
+(setf (sgml-tree-includes top) (sgml-tree-includes sgml-current-tree))
-(setf (sgml-tree-excludes top) (sgml-excludes))
+(setf (sgml-tree-excludes top) (sgml-tree-excludes sgml-current-tree))
 (setf (sgml-tree-shortmap top) sgml-current-shortmap)
 (setf (sgml-eltype-model (sgml-tree-eltype top))
 	  sgml-current-state)))
 (defun sgml-set-global ()
 (setq sgml-current-omittag sgml-omittag
 	sgml-current-shorttag sgml-shorttag
 	sgml-current-localcat sgml-local-catalogs
-	sgml-current-local-ecat sgml-local-ecat-files))
+	sgml-current-local-ecat sgml-local-ecat-files
+	sgml-current-top-buffer (current-buffer)))
 (defun sgml-parse-prolog ()
 "Parse the document prolog to learn the DTD."
 (interactive)
-(sgml-clear-log)
+(sgml-debug "Parse prolog in buffer %s" (buffer-name))
+(unless sgml-debug
+(sgml-clear-log))
 (message "Parsing prolog...")
 (sgml-cleanup-entities)
 (sgml-set-global)
 (setq	sgml-dtd-info nil)
 (goto-char (point-min))
 	 (sgml-setup-doctype docname '(nil))))))
 (unless sgml-dtd-info
 (error "No document type defined by prolog"))
 (sgml-message "Parsing prolog...done"))
 (defun sgml-parse-until-end-of (sgml-close-element-trap &optional
 							cont extra-cond quiet)
 "Parse until the SGML-CLOSE-ELEMENT-TRAP has ended,
 or if it is t, any additional element has ended,
 or if nil, until end of buffer."
 "Parse until (at least) SGML-GOAL.
 Optional argument EXTRA-COND should be a function.  This function is
 called in the parser loop, and the loop is exited if the function returns t.
 If third argument QUIT is non-nil, no \"Parsing...\" message will be displayed."
 (sgml-need-dtd)
+(unless before-change-function
+(message "WARN: before-change-function has been lost, restoring (%s)"
+	     (current-buffer))
+(setq before-change-function 'sgml-note-change-at)
+(setq after-change-function 'sgml-set-face-after-change)
+)
 (sgml-find-start-point (min sgml-goal (point-max)))
 (assert sgml-current-tree)
 (let ((bigparse (and (not quiet) (> (- sgml-goal (point)) 10000))))
 (when bigparse
 (sgml-message "Parsing..."))
 (sgml-with-parser-syntax
 (sgml-parser-loop extra-cond))
 (when bigparse
 (sgml-message ""))))
-(defun sgml-parse-continue (sgml-goal)
+(defun sgml-parse-continue (sgml-goal &optional extra-cond quiet)
 "Parse until (at least) SGML-GOAL."
 (assert sgml-current-tree)
-(sgml-message "Parsing...")
+(unless quiet
+(sgml-message "Parsing..."))
 (sgml-with-parser-syntax
-(sgml-parser-loop nil))
+(sgml-parser-loop extra-cond))
-(sgml-message ""))
+(unless quiet
+(sgml-message "")))
 (defun sgml-reparse-buffer (shortref-fun)
 "Reparse the buffer and let SHORTREF-FUN take care of short references.
 SHORTREF-FUN is called with the entity as argument and `sgml-markup-start'
 pointing to start of short ref and point pointing to the end."
 						(eq (point)
 						    sgml-rs-ignore-pos)))
 		 ;; Restore position, to consider the delim for S+ or data
 		 (progn (goto-char sgml-markup-start)
 			nil)))
-	(setq sgml-rs-ignore-pos (point))
+	(setq sgml-rs-ignore-pos sgml-markup-start) ; don't reconsider RS
 	(funcall sgml-shortref-handler tem))
 ((and (not (sgml-current-mixed-p))
 	     (sgml-parse-s sgml-current-shortmap)))
 ((or (sgml-parse-delim "ETAGO" gi)
 	    (sgml-is-enabled-net))
 (defun sgml-do-start-tag ()
 ;; Assume point after STAGO
 (when sgml-throw-on-element-change
 (throw sgml-throw-on-element-change 'start))
 (setq sgml-conref-flag nil)
-(let (temp net-enabled et asl)
+(let (net-enabled et asl)
 (setq et (if (sgml-is-delim "TAGC")	; empty start-tag
 		 (sgml-do-empty-start-tag)
 	       (sgml-lookup-eltype (sgml-check-name))))
 (unless (sgml-parse-delim "TAGC")	; optimize common case
 (setq asl (sgml-parse-attribute-specification-list et))
 				sgml-markup-start sgml-markup-start)))
 (sgml-close-element sgml-markup-start (point)))))
 (defun sgml-is-goal-after-start (goal tree)
 (and tree
-;;(not (zerop (sgml-tree-stag-len tree)))
+(if (sgml-bpos-p (sgml-tree-stag-epos tree))
-(> goal (sgml-element-start tree))))
+	   (> goal (sgml-tree-stag-epos tree))
+	 (>= goal (sgml-epos-after (sgml-tree-stag-epos tree))))))
 (defun sgml-find-start-point (goal)
 (let ((u sgml-top-tree))
 (while
 	(cond
 ;;;; Provide
 (provide 'psgml-parse)
+;; Local variables:
+;; byte-compile-warnings:(free-vars unresolved callargs redefine)
+;; End:
 ;;; psgml-parse.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-parse.el @ 2:ac2d302a0011 r19-15b2