(setq file-order '(
		  SYSTEM K32machine K32baseTypes K32conf K32types K32excep
		  K32calls K32callp Exceptions IOform KIO
		  IOEform IOE IOFform IOF IOpack IOFsys Unknown
		  ))
(setq max-lisp-eval-depth 400)
(setq version-control t)

(defun build-head ()
  "Generate an IMPORT list from a list of identifiers."
  (interactive "*")
  (setq real-buf (current-buffer))
  (initialize)
  (goto-char (point-min))
  (skip-chars-forward "\n" (point-max))
  (narrow-to-region (point) (point-max))
  (if (search-forward "EXPORT" nil 'end)
      (beginning-of-line))
  (skip-chars-backward "\n" (point-min))
  (beginning-of-line 2)
  (narrow-to-region (point-min) (point))
  (goto-char (point-min))
  (message "scanning...")
  (while (setq symbol (pick-symbol))
    (cond ((equal symbol "FROM")
	   (forward-word 2))
	  ((equal symbol "ifdef")
	   (beginning-of-line 2))
	  ((equal symbol "endif")
	   (beginning-of-line 2))
	  (t
	   (setq file (symbol-lookup symbol))
	   (set file (append (eval file) (list symbol)))
	   )
	  )
    )
  (delete-region (point-min) (point-max))
  (message "reconstructing...")
  (create-import-lists file-order real-buf)
  (switch-to-buffer real-buf)
  (delete-region (1- (point-max)) (point-max))	; trailing newline
  (widen)
  )

(defun rebuild-port-lists ()
  "Sort and rebuild the import and export lists of a ksos-32 source file."
  (interactive "*")
  (goto-char (point-min))
  (if (search-forward "IMPORT" nil t)
      (progn (initialize)
	     (beginning-of-line)
	     (narrow-to-region (point) (point-max))
	     (search-forward ";")
	     (while (search-forward "IMPORT" (+ (point) 100) t)
	       (search-forward ";"))
	     (beginning-of-line 2)
	     (if (search-forward "#endif PROF" (+ (point) 12) t)
		 (beginning-of-line 2))
	     (narrow-to-region (point-min) (point))
	     (setq real-buf (current-buffer))
	     (message "scanning IMPORT lists...")
	     (goto-char (point-min))
	     (while (setq symbol (pick-symbol))
	       (cond ((equal symbol "FROM")
		      (forward-word 2))
		     ((equal symbol "ifdef")
		      (beginning-of-line 2))
		     ((equal symbol "endif")
		      (beginning-of-line 2))
		     (t
		      (setq file (symbol-lookup symbol))
		      (set file (cons symbol (eval file)))
		      )
		     )
	       )
	     (delete-region (point-min) (point-max))
	     (message "reconstructing IMPORT lists...")
	     (create-import-lists file-order real-buf)
	     (switch-to-buffer real-buf)
	     (delete-region (1- (point-max)) (point-max))	; trailing newline
	     (widen)
	     )
    (message "no IMPORT list")
    )
  (if (search-forward "EXPORT QUALIFIED" nil t)
      (progn (setq exports '())
	     (beginning-of-line)
	     (narrow-to-region (point) (point-max))
	     (search-forward ";")
	     (beginning-of-line 2)
	     (if (search-forward "#endif PROF" (+ (point) 12) t)
		 (beginning-of-line 2))
	     (narrow-to-region (point-min) (point))
	     (message "scanning EXPORT list...")
	     (goto-char (point-min))
	     (while (setq symbol (pick-symbol))
	       (cond ((or (equal symbol "EXPORT") (equal symbol "QUALIFIED"))
		      nil)
		     ((or (equal symbol "ifdef") (equal symbol "endif"))
		      (beginning-of-line 2))
		     (t
		      (setq exports (cons symbol exports))
		      )
		     )
	       )
	     (delete-region (point-min) (point-max))
	     (message "reconstructing EXPORT list...")
	     (setq exports (sort exports 'caseless-string-lessp))
	     (setq exports (move-to-beginning exports '("XOK" "exceptionType" "profileTable")))
	     (insert "EXPORT QUALIFIED\n\n")
	     (if (equal (car exports) "profileTable")
		 (progn (insert "#ifdef PROF\n\t" (car exports) ",\n#endif PROF\n")
			(setq exports (cdr exports))
			)
	       )
	     (while exports
	       (insert (car exports))
	       (if (setq exports (cdr exports))
		   (insert ", ")
		 (insert ";\n")
		 )
	       )
	     (beginning-of-line 0)
	     (while (< (point) (point-max))
	       (insert "\t")
	       (fill-paragraph nil)
	       (beginning-of-line 2)
	       )
	     (widen)
	     )
    (message "no EXPORT list")
    )
  )

(defun initialize ()
  (interactive)
  (setq files file-order)
  (setq file-names '())
  (make-local-variable 'file-names)
  (while (not (equal files nil))
    (setq file (car files))
    (setq file-names (append file-names (list (symbol-name file))))
    (set file '())
    (make-local-variable file)
    (setq files (cdr files))
    )
  )

(defun create-import-lists (modules buf)
  (interactive "*SList of modules: \nbTarget buffer: ")
  (while modules
    (if (setq symbols (eval (car modules)))
	(progn
	  (setq symbols (sort symbols 'caseless-string-lessp))
	  (setq symbols (move-to-beginning symbols '("XOK" "exceptionType" "profileTable")))
	  (if (equal (car symbols) "profileTable")
	      (if (cdr symbols)
		  (setq PROF 'extras)
		(setq PROF 'one)
		)
	    (setq PROF nil)
	    )
	  (if (equal PROF 'one)
	      (insert "#ifdef PROF\n"))
	  (insert "FROM " (symbol-name (car modules)) " IMPORT\n\n")
	  (if (equal PROF 'extras)
	      (progn (insert "#ifdef PROF\n\t" (car symbols) ",\n#endif PROF\n")
		     (setq symbols (cdr symbols))
		     )
	    )
	  (while symbols
	    (insert (car symbols))
	    (if (setq symbols (cdr symbols))
		(insert ", ")
	      (insert ";\n")
	      )
	    )
	  (beginning-of-line 0)
	  (while (< (point) (point-max))
	    (insert "\t")
	    (fill-paragraph nil)
	    (beginning-of-line 2)
	    )
	  (if (equal PROF 'one)
	      (insert "#endif PROF\n"))
	  (insert "\n")
	  )
      )
    (kill-local-variable (car modules))
    (setq modules (cdr modules))
    )
  )

(defun pick-symbol ()
  (interactive)
  (if (forward-word 1)
      (progn (forward-word -1)
	     (setq bow (point))
	     (forward-word 1)
	     (buffer-substring bow (point)))
    nil
    )
  )

(defun symbol-lookup (symbol)
  (interactive "S")
  (setq real-buf (current-buffer))
  (if (get-buffer "symbol-index")
      (switch-to-buffer "symbol-index")
    (find-file-read-only "~ksos/kernel/symbol-index")
    (setq case-fold-search nil)
    )
  (goto-char 0)
  (setq module (if (search-forward (concat "\n" symbol " ") nil t)
		   (buffer-substring (progn (search-forward ": ") (point))
				     (progn (end-of-line) (point))
				     )
		 ))
  (switch-to-buffer real-buf)
  (if (setq module (car (corresponding-member module file-names file-order)))
      module
    'Unknown
    )
  )

(defun move-to-beginning (target string-list)
  (interactive "STarget: \nSString list: ")
  (while string-list
    (setq sym (car string-list))
    (setq new (remove sym target))
    (if (< (length new) (length target))
	(setq target (cons sym new)))
    (setq string-list (cdr string-list))
    )
  target
  )

(defun remove (symbol list)
  "Remove all occurrences of SYMBOL from LIST and return what remains."
  (interactive "SSymbol: \nSList: ")
  (if list
      (if (equal symbol (car list))
	  (remove symbol (cdr list))
	(cons (car list) (remove symbol (cdr list)))
	)
    )
  )

(defun member (symbol list)
  "Return the longest sublist -- that begins with SYMBOL -- of LIST."
  (interactive "SSymbol: \nSList: ")
  (if list
      (if (equal symbol (car list))
	  list
	(member symbol (cdr list))
	)
    )
  )

(defun corresponding-member (symbol list1 list2)
  (interactive "SSymbol: \nSList1: \nSList2: ")
  (if list1
      (if (equal symbol (car list1))
	  list2
	(corresponding-member symbol (cdr list1) (cdr list2))
	)
    nil
    )
  )

(defun caseless-string-lessp (string1 string2)
  "T if first arg string is less than second in dictionary order.
The case of characters is not important unless the caseless strings
are equal."
  (interactive "s\ns")
  (setq s1 (downcase string1))
  (setq s2 (downcase string2))
  (if (string-equal s1 s2)
      (string-lessp string1 string2)
    (string-lessp s1 s2)
    )
  )
