;  Twenex-like tags package for Modula-2 libraries: based on J Gosling's
;  "tags.ml". A tag file is a sequence of lines of the following forms:

;  ^_filename
;  ^Atagsymbol^Bposition

;  Strategy is as follows: we make a list of objects declared EXPORT in the
;  .def module. Exported CONSTS, TYPES and VARS are found in the .def module.
;  PROCEDURES are found in the .mod module. 

;  Recursive functions attempt to deal with declarations of
;  exported structured types (enumerations, arrays). This means that
;  values of enumerated types and fields of records and variants are
;  tagged if the type is exported.

;  As an added extra, we can check an implementation module to ensure that
;  it implements everything expected of it. 

;  BUGS:
; 	 Complicated exported CONSTS will result in spurious tags
; 	 Comments which contain END ; | etc may possibly confuse me
; 	 Incompatible with tags.ml: can't mix languages
; 	 Overloading of identifiers not resolved
; 	 Qualified identifiers not supported
; 	 Assumes correct syntax
; 	 Will be confused by local modules declaring expected exports locally
; 	 "make-tag-table" is VERY slow

;  Written by Malcolm Crowe, 8 February 1983

(declare-global last-search-tag)    

(defun
    (tag-file fn more crsym proc mess
	(setq case-fold-search 0)
	(setq fn (arg 1 ": tag-file (filename) "))
	(if (is-def-file) 
	    (save-window-excursion	
		(message (concat "Tagging " fn))
		(sit-for 0)
		(position-tag-buffer)
		(switch-to-buffer "DEF")
		(read-file fn)
		(setq mess "Definition module tags")
		(setq proc 1)
		(peruse-export-list)
		(construct-mod-name)
		(switch-to-buffer "MOD")
		(error-occured (read-file fn))
		(position-tag-buffer)
		(switch-to-buffer "DEF")
		(setq proc 2)
		(setq mess "Implementation module tags")
		(peruse-export-list)
	    )
	)
    )
    
    (peruse-export-list
	(beginning-of-file)
	(search-forward "QUALIFIED")
	(setq more 1)
	(while more
	    (next-token)
	    (set-mark)
	    (message mess)
	    (sit-for 0)	; Reassure not in loop (v. slow)
	    (forward-word)
	    (setq crsym (region-to-string))
	    (next-token)
	    (setq more (= (following-char) ','))
	    (forward-character)		    
	    (if (= proc 1)(get-def-tag)
		(= proc 2)(get-mod-tag)
	    )
	)
    )
		
    (next-token
	(re-search-forward "[ \n\t]*")
	(while (looking-at "(\\*")
	    (re-search-forward "\\*)[ \n\t]*")
	)
    )
    
    (construct-mod-name
	(save-excursion
	    (temp-use-buffer "Hack")
	    (delete-to-killbuffer)
	    (insert-string ".mod")
	    (set-mark)
	    (beginning-of-file)
	    (setq fn (region-to-string))
	)
    )
    
    (position-tag-buffer
	(save-excursion
	    (to-tag-buffer)
	    (if (error-occured (search-forward (concat "\^_" fn "\n")))
		(progn
		    (beginning-of-file)
		    (insert-character '^_')
		    (insert-string fn)
		    (newline))
		(progn
		    (set-mark)
		    (while (= (following-char) '^A')
			(next-line))
		    (erase-region))
	    )
	)
    )
    
    (get-def-tag more esym
	(setq esym (concat "\\W" crsym "\\W"))
	(save-excursion
	    (setq more 
		(! 
		    (error-occured 
			(re-search-forward ",\\|;\\|TYPE\\|VAR\\CONST")
		    )
		)
	    )
	    (while more
		(next-token) (backward-character)
		(if (looking-at esym)
		    (progn
			(setq more 0)
			(search-forward crsym)
			(add-tag*)
			(next-token)
			(if (looking-at "=")
			    (type-decl-tag)
			)
		    )
		    (setq more
			(! 
			    (error-occured 
				(forward-character)
				(re-search-forward ",\\|;\\|TYPE\\|VAR\\|CONST")
			    )
			)
		    )
		)
	    )
	)
    )
    
    (type-decl-tag
	(forward-character)
	(next-token)
	(if (looking-at "(")    ;  enumerated type
	    (list-decl-tag)
	    (if (looking-at "RECORD") ;  RECORD type
		(progn
		    (forward-word)
		    (next-token)
		    (while (! (looking-at "END"))
			(if (looking-at "CASE")
			    (variant-decl-tag)
			)
			(list-decl-tag)
			(type-decl-tag)
			(re-search-forward ";\\|END")
			(re-search-reverse ";\\|END")
			(if (looking-at ";")
			    (forward-character)
			)
			(next-token)
		    )
		)
	    )
	)
    )
    
    (list-decl-tag more
	(forward-character)
	(setq more 1)
	(while more
	    (next-token)
	    (forward-word)
	    (add-tag*)
	    (next-token)
	    (setq more (= (following-char) ','))
	    (forward-character)
	)
    )
    
    (variant-decl-tag
	(forward-word)
	(forward-word)
	(if (looking-at "[ \n\t]*:")
	    (add-tag*)
	)
	(search-forward "OF")
	(next-token)
	(while (! (looking-at "END"))
	    (search-forward ":")
	    (next-token)
	    (list-decl-tag)
	    (type-decl-tag)
	    (re-search-forward "|\\|ELSE\\|END")
	    (re-search-reverse "|\\|ELSE\\|END")
	    (if (looking-at "|")
		(forward-character)
		(if (looking-at "ELSE")
		    (progn
			(forward-word)
			(list-decl-tag)
			(type-decl-tag)
		    )
		)
	    )
	)
    )
    
    (get-mod-tag gotit esym
	(setq esym (concat "\\W" crsym "\\W"))
	(save-excursion
	    (switch-to-buffer "MOD")
	    (beginning-of-file)
	    (while (! (error-occured (re-search-forward esym)))
		(backward-character)
		(save-excursion
		    (backward-word)
		    (backward-word)
		    (setq gotit (looking-at "PROCEDURE"))
		)
		(if gotit (add-tag*))
	    )
	    (switch-to-buffer "DEF")
	)
    )
    
    (is-def-file
	(save-excursion
	    (temp-use-buffer "Hack")
	    (erase-buffer)
	    (insert-string fn)
	    (set-mark)
	    (error-occured (search-reverse "."))
	    (looking-at ".def")
	)
    )
    
    (find-pos-str
	(set-mark)
	(backward-word)
	(setq pos (+ (dot) 0))
	(setq str (region-to-string))
	(forward-word)
    )
    
    (store-pos-str
	(insert-character '^A')
	(insert-string str)
	(insert-character '^B')
	(insert-string pos)
	(newline))
    
    (recompute-all-tags
	(message "Not available for Modula-2: use make-tag-table instead")
	(illegal-operation)
    )
    
    (goto-tag fn str pos restart
	(setq restart 0)
	(if (! prefix-argument-provided)
	    (progn
		(setq last-search-tag
		    (concat "\^A\\(" 
			(quote (arg 1 ": goto-tag ")) 
			"\\)\^B\\(.*\\)"))
		(setq restart 1)))
	(save-excursion
	    (to-tag-buffer)
	    (if restart (beginning-of-file))
	    (re-search-forward last-search-tag)
	    (region-around-match 1)
	    (setq str (region-to-string))
	    (region-around-match 2)
	    (setq pos (- (region-to-string) 300))
	    (save-excursion
		(re-search-reverse "\^_\\(.*\\)")
		(region-around-match 1)
		(setq fn (region-to-string)))
	)
	(visit-file fn)
	(goto-character pos)
	(if (error-occured (search-forward str))
	    (search-reverse ""))
	(beginning-of-line)
	(line-to-top-of-window)
    )
    
    (add-tag* pos str
	(find-pos-str)
	(save-excursion
	    (temp-use-buffer "*TAG*")
	    (store-pos-str)))
    
    (to-tag-buffer
	(temp-use-buffer "*TAG*")
	(if (& (= (buffer-size) 0) (= (current-file-name) ""))
	    (progn
		(if (error-occured (read-file ".tags"))
		    (progn
			(write-named-file ".tags")
			(message "New tag file")))
		(beginning-of-file)))
    )
    
    (check-implementation fn crsym
	(setq fn (arg 1 ": check-implementation (for definition file) "))
	(if (! (is-def-file))
	    (illegal-operation)
	)
	(message (concat "Checking " fn))
	(sit-for 10)
	(save-excursion
	    (temp-use-buffer "DEF")
	    (read-file fn)
	    (construct-mod-name)
	    (temp-use-buffer "MOD")
	    (read-file fn)
	    (temp-use-buffer "Hack")
	    (erase-buffer)
	    (setq mode-line-format
	        (concat "    Unimplemented procedures in " fn)
	    )
	    (temp-use-buffer "DEF")
	    (beginning-of-file)
	    (while (! (error-occured
			  (re-search-forward "PROCEDURE[ \n\t]*\\(\\w\\w*\\)")
		      ))
		(region-around-match 1)
		(setq crsym (region-to-string))
		(save-excursion
		    (temp-use-buffer "MOD")
		    (beginning-of-file)
		    (if (error-occured (re-search-forward
			    (concat "PROCEDURE[ \n\t]*" crsym)))
			(save-excursion
			   (temp-use-buffer "Hack")
			   (insert-string (concat crsym "\n"))
			)
		    )
		)
	    )
	)
	(pop-to-buffer "Hack")
	(novalue)
    )
    
    (make-tag-table fns
	   (setq fns (arg 1 ": make-tag-table (from filenames) "))
	   (save-window-excursion
	       (temp-use-buffer "*TEMP*")
	       (erase-buffer)
	       (set-mark)
	       (filter-region (concat "ls " fns))
	       (beginning-of-file)
	       (while (! (eobp))
		      (set-mark)
		      (end-of-line)
		      (tag-file (region-to-string))
		      (next-line)
		      (beginning-of-line))
	       (delete-buffer "*TEMP*")
	       (temp-use-buffer "*TAG*")
	       (write-named-file ".tags"))
	   (novalue)
       )
   )

)

(bind-to-key "goto-tag" "\^X\^G")
