;; Emacs mode for PostScript (still very much in development [$Exp$])
;; $Id$

(setq debug-on-error 't)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;  PostScript mode  ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; global variables

(defvar ps-mode-map nil
  "Keymap for PostScript major mode")
(defvar ps-mode-syntax-table nil
  "Main syntax table for PostScript major mode")

;;;; syntax tables setup

(defun ps-syntax-table (comments parens angle square braces)
  "Make a syntax table with certain options turned on or off."
  (let ((syntax-table (make-syntax-table))
	(char ?!))
    (while (< char ?\177)
      (modify-syntax-entry char "w" syntax-table)
      (setq char (1+ char)) )
    ;; whitespace
    (modify-syntax-entry ?\000 " " syntax-table)
    (modify-syntax-entry ?\t   " " syntax-table)
    (modify-syntax-entry ?\n   " " syntax-table)
    (modify-syntax-entry ?\f   " " syntax-table)
    (modify-syntax-entry ?\r   " " syntax-table)
    (modify-syntax-entry ?\    " " syntax-table)
    ;; comments
    (if comments
	(progn
	  (modify-syntax-entry ?%   "<"  syntax-table)
	  (modify-syntax-entry ?\n  ">"  syntax-table) ))
    ;; grouping: strings, ...
    (if parens
	(progn
	  (modify-syntax-entry ?\(  "()" syntax-table)
	  (modify-syntax-entry ?\)  ")(" syntax-table) ))
    ;; ... encoded strings and dictionaries, ...
    (if angle
	(progn
	  (modify-syntax-entry ?<   "(>" syntax-table)
	  (modify-syntax-entry ?>   ")<" syntax-table) ))
    ;; ... arrays, ...
    (if square
	(progn
	  (modify-syntax-entry ?\[   "(]" syntax-table)
	  (modify-syntax-entry ?\]   ")[" syntax-table) ))
    ;; ... and procedures.
    (if braces
	(progn
	  (modify-syntax-entry ?{   "(}" syntax-table)
	  (modify-syntax-entry ?}   "){" syntax-table) ))
    ;; other stuff
    (modify-syntax-entry ?\\  "/"  syntax-table)
    (modify-syntax-entry ?/   "'"  syntax-table)
    syntax-table ))

;;;; set up mode variables

(if (not ps-mode-map)
    (progn
      (setq ps-mode-map (make-keymap))
;     (define-key ps-mode-map "\C-x\C-e" 'gs-exec-buffer)
      (define-key ps-mode-map "\M-\C-f" 'psp-show-token)
      (define-key ps-mode-map "\C-x\C-e" 'ps-send-token)))
(if (not ps-mode-syntax-table)
    (setq ps-mode-syntax-table (ps-syntax-table t t t t t)))

;;;; mode-related functions

(defun ps-mode ()
  "It's broken.  Go away."
  (interactive)
  (setq major-mode 'ps-mode
	mode-name "PostScript")
  (use-local-map ps-mode-map)
  (set-syntax-table ps-mode-syntax-table))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;  parsing stuff  ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; more global variables

(defvar psp-string-syntax-table nil
  "Syntax table used while parsing a literal string.")
(if (not psp-string-syntax-table)
    (setq psp-string-syntax-table (ps-syntax-table nil t nil nil nil)))

(defvar psp-parse-token-alist nil
  "Associative list mapping token-starting characters to
token-extracting functions.")
(if (not psp-parse-token-alist)
    (setq psp-parse-token-alist '((?\( psp-parse-string)
				  (?\) psp-parse-end  ?\) )
				  (?<  psp-parse-list ?< ?> )
				  (?>  psp-parse-end  ?> )
				  (?\[ psp-parse-list ?\[ ?\] )
				  (?\] psp-parse-end  ?\] )
				  (?{  psp-parse-proc)
				  (?}  psp-parse-end  ?} )
				  (?%  psp-skip-comment 'rescan))) )

(defvar psp-recursive-parsing-stack nil
  "List of expected ps-sexp endings.")
(defvar psp-parsing-recursively nil
  "Non-nil if parsing the contents of a sexp is in progress.")

;;;; parsing functions

(defun psp-show-token ()
  (interactive)
  (message "%s" (prin1-to-string
		 (psp-remove-newlines (psp-parse-current-token)))))

(defun psp-parse-current-token ()
  (skip-syntax-backward "w/'")
  (psp-next-token-beginning (psp-parse-token)))

(defun psp-parse-token ()
  (let (parser
	(result 'rescan))
    (while (and (equal result 'rescan) (not (eobp)))
      (psp-next-token-beginning)
      (setq parser (assoc (char-after (point)) psp-parse-token-alist))
      (setq result
	    (if parser
		(eval (cdr parser))
	      (psp-parse-word) ) ))
    (if (eq result 'rescan) nil
      result) ))

(defun psp-next-token-beginning (&optional return)
  (skip-syntax-forward " >")
  return)

(defun psp-parse-word ()
  (let ((start (point)))
    (forward-word 1)
    (buffer-substring start (point)) ))

(defun psp-parse-string ()
  (let ((st (syntax-table))
	(start (point)))
    (unwind-protect
	(progn (set-syntax-table psp-string-syntax-table)
	       (forward-sexp))
      (set-syntax-table st))
    (buffer-substring start (point)) ))    

;; grrrr.  forward-sexp is broken wrt comments.
;(defun psp-parse-list (&optional junk)
;  (let ((start (point)))
;    (forward-sexp)
;    (buffer-substring start (point)) ))

(defun psp-parse-list (beginning ending)
  (let ((start (point))
	(ret (char-to-string beginning)))
    (let ((psp-parsing-recursively 't)
	  (psp-recursive-parsing-stack (cons ending
					     psp-recursive-parsing-stack))
	  (psp-parsed-region-extractor nil))
      (forward-char)
      (while (and psp-parsing-recursively (not (eobp)))
	(let ((token (psp-parse-token)))
	  (if (stringp token)
	      (setq ret (concat ret " " token))
	    (error "psp: parser returned %s" (prin1-to-string token))) ))
      (if psp-parsing-recursively
	  (error "psp: Unexpected end of file.")) )
;;;    (buffer-substring start (point))
    ret))

(defun psp-parse-proc ()
  (psp-parse-list ?{ ?} ))

(defun psp-skip-comment (&optional rescan)
  (forward-comment 1)
  rescan)

(defun psp-parse-end (&optional expected rescan)
  (forward-char)
  (if psp-parsing-recursively
      (progn (setq psp-parsing-recursively nil)
	     (if (equal expected (car psp-recursive-parsing-stack))
		 (char-to-string expected)
	       (error "psp: Mismatched parentheses!")
	       nil))
    (error "psp: Missing parenthesis!")
    rescan) )

(defun psp-remove-newlines (string)
  (if (stringp string)
      (let ((start 0))
	(while (string-match "[ \t\n]+" string start)
	  (setq start (match-end 0))
	  (setq string (replace-match " " nil nil string)) )
	string)
    string))

;;;; trivial GS interface

(defun ps-send-token ()
  (interactive)
  (gs-run-gs)
  (gs-send-token (psp-remove-newlines (psp-parse-current-token))))