;;; $Header: /tmp_mnt/home/baobab/u/gauge/PCN/IF/el/RCS/cmupcn.el,v 1.11 90/11/08 14:15:18 carl Exp Locker: lee $
;; cmupcn.el -- Scheme process in a buffer. Adapted from pcnscheme.el.
;;; Copyright Olin Shivers (1988)
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;;
;;;    This is a customisation of comint-mode (see comint.el)
;;;
;;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces
;;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al..
;;; 8/88
;;;
;;; Please send me bug reports, bug fixes, and extensions, so that I can
;;; merge them into the master source.
;;;
;;; The changelog is at the end of this file.
;;;

;; YOUR .EMACS FILE
;;=============================================================================
;; Some suggestions for your .emacs file.
;;
;; ; If cmuscheme lives in some non-standard directory, you must tell emacs
;; ; where to get it. This may or may not be necessary.
;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
;;
;; ; Autoload run-scheme from file cmuscheme.el
;; (autoload 'run-scheme "cmuscheme"
;;           "Run an inferior Scheme process."
;;           t)
;;
;; ; Files ending in ".scm" are Scheme source, 
;; ; so put their buffers in scheme-mode.
;; (setq auto-mode-alist 
;;       (cons '("\\.scm$" . scheme-mode)  
;;             auto-mode-alist))
;;
;; ; Define C-c C-t to run my favorite command in inferior scheme mode:
;; (setq cmuscheme-load-hook
;;       '((lambda () (define-key inferior-scheme-mode-map "\C-c\C-t"
;;                                'favorite-cmd))))
;;;
;;; Unfortunately, scheme.el defines run-scheme to autoload from xscheme.el.
;;; This will womp your declaration to autoload run-scheme from cmuscheme.el
;;; if you haven't loaded cmuscheme in before scheme. Three fixes:
;;; - Put the autoload on your scheme mode hook and in your .emacs toplevel:
;;;   (setq scheme-mode-hook
;;;         '((lambda () (autoload 'run-scheme "cmuscheme"
;;;                                "Run an inferior Scheme" t))))
;;;   (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t)
;;;   Now when scheme.el autoloads, it will restore the run-scheme autoload.
;;; - Load cmuscheme.el in your .emacs: (load-library 'cmuscheme)
;;; - Change autoload declaration in scheme.el to point to cmuscheme.el:
;;;   (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t)
;;;   *or* just delete the autoload declaration from scheme.el altogether,
;;;   which will allow the autoload in your .emacs to have its say.

(provide 'cmupcn)
(require 'pcn-mode)
(require 'comint)

;;; INFERIOR SCHEME MODE STUFF
;;;============================================================================

(defvar inferior-pcn-mode-hook nil
  "*Hook for customising inferior-scheme mode.")
(defvar inferior-pcn-mode-map nil)
(defvar *pcn-disabled-commands*
  '(list-buffers list-directory eval-last-sexp find-file
		 toggle-read-only find-file-read-only save-buffer
		 find-alternate-file write-file  
		 delete-window split-window-vertically
		 split-window-horizontally switch-to-buffer
		 dired insert-file register-to-point kill-buffer
		 mail other-window copy-rectangle-to-register
		 save-some-buffers save-buffers-kill-emacs)
  )

(defun undefine-in-local-map (map function)
  (let ((key (where-is-internal function map t)))
    (if key (define-key map key (function undefined)))))

(defmacro epoch-running () '(boundp 'epoch::version))

(cond ((not inferior-pcn-mode-map)
       (setq inferior-pcn-mode-map
	     (full-copy-sparse-keymap comint-mode-map))
       (define-key inferior-pcn-mode-map "\M-\C-x" ;gnu convention
	           'pcn-send-definition)
       (define-key inferior-pcn-mode-map "\C-x\C-e" 'pcn-send-last-sexp)
       (define-key inferior-pcn-mode-map "\C-cl"    'pcn-load-file)
       (define-key inferior-pcn-mode-map "\C-ck"    'pcn-compile-file)
       (define-key inferior-pcn-mode-map "\t" 'comint-dynamic-complete)
       (define-key inferior-pcn-mode-map "\M-\t" 'comint-dynamic-complete)
       (define-key inferior-pcn-mode-map "\M-?"  'comint-dynamic-list-completions)

       (if (epoch-running)
	   (mapcar (function
		    (lambda (function)
		      (undefine-in-local-map inferior-pcn-mode-map function)))
		   *pcn-disabled-commands*))
       ) 
)

;; Install the process communication commands in the pcn-mode keymap.
(define-key pcn-mode-map "\M-\C-x" 'pcn-send-definition);gnu convention
(define-key pcn-mode-map "\C-x\C-e" 'pcn-send-last-sexp);gnu convention
(define-key pcn-mode-map "\C-ce"    'pcn-send-definition)
(define-key pcn-mode-map "\C-c\C-e" 'pcn-send-definition-and-go)
(define-key pcn-mode-map "\C-cr"    'pcn-send-region)
(define-key pcn-mode-map "\C-c\C-r" 'pcn-send-region-and-go)
(define-key pcn-mode-map "\C-cc"    'pcn-compile-definition)
(define-key pcn-mode-map "\C-c\C-c" 'pcn-compile-definition-and-go)
(define-key pcn-mode-map "\C-cz"    'switch-to-pcn)
(define-key pcn-mode-map "\C-cl"    'pcn-load-file)
(define-key pcn-mode-map "\C-ck"    'pcn-compile-file) ;k for "kompile"

(defun inferior-pcn-mode ()
  "Major mode for interacting with an inferior Pcn process.

The following commands are available:
\\{inferior-pcn-mode-map}

A Pcn process can be fired up with M-x run-pcn.

Customisation: Entry to this mode runs the hooks on comint-mode-hook and
inferior-pcn-mode-hook (in that order).

You can send text to the inferior Pcn process from other buffers containing
Pcn source.  
    switch-to-pcn switches the current buffer to the Pcn process buffer.
    pcn-send-definition sends the current definition to the Pcn process.
    pcn-compile-definition compiles the current definition.
    pcn-send-region sends the current region to the Pcn process.
    pcn-compile-region compiles the current region.

    pcn-send-definition-and-go, pcn-compile-definition-and-go,
        pcn-send-region-and-go, and pcn-compile-region-and-go
        switch to the Pcn process buffer after sending their text.
For information on running multiple processes in multiple buffers, see
documentation for variable pcn-buffer.

Commands:
Return after the end of the process' output sends the text from the 
    end of process to point.
Return before the end of the process' output copies the sexp ending at point
    to the end of the process' output, and sends it.
Delete converts tabs to spaces as it moves back.
Tab indents for Pcn; with argument, shifts rest
    of expression rigidly with the current line.
C-M-q does Tab on each line starting within following expression.
Paragraphs are separated only by blank lines.  Semicolons start comments.
If you accidentally suspend your process, use \\[comint-continue-subjob]
to continue it."
  (interactive)
  (comint-mode)
  ;; Customise in inferior-pcn-mode-hook
  (setq comint-prompt-regexp "^[^>]*>+ *") ; OK for cscheme, oaklisp, T,...
  (pcn-mode-variables)
  (setq major-mode 'inferior-pcn-mode)
  (setq mode-name "Inferior Pcn")
  (setq mode-line-process '(": %s"))
  (use-local-map inferior-pcn-mode-map)
  (setq comint-input-filter (function pcn-input-filter))
  (setq comint-input-sentinel (function ignore))
  (run-hooks 'inferior-pcn-mode-hook))

(defun pcn-input-filter (str)
  "Don't save anything matching inferior-pcn-filter-regexp"
  (not (string-match inferior-pcn-filter-regexp str)))

(defvar inferior-pcn-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'"
  "*Input matching this regexp are not saved on the history list.
Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters.")

(defun pcn-args-to-list (string)
  (let ((where (string-match "[ \t]+" string)))
    (cond ((null where) (if (string-equal string "") nil (list string)))
	  ((not (= where 0))
	   (cons (substring string 0 where)
		 (pcn-args-to-list (substring string (match-end 0)))))
	  (t (let ((pos (string-match "[^ \t]" string)))
	       (if (null pos)
		   nil
		 (pcn-args-to-list (substring string pos
						 (length string)))))))))

(defvar pcn-program-name "pcn"
  "*Program invoked by the run-pcn command")

(defun run-pcn (cmd &optional host path)
  "Run an inferior Pcn process, input and output via buffer *pcn*.
If there is a process already running in *pcn*, just switch to that buffer.
With argument, allows you to edit the command line (default is value
of pcn-program-name).  Runs the hooks from inferior-pcn-mode-hook
\(after the comint-mode-hook is run).
\(Type \\[describe-mode] in the process buffer for a list of commands.)"

  (interactive (list (if current-prefix-arg
			 (read-string "Run Pcn: " pcn-program-name)
		       pcn-program-name)))
  (setq pcn-program-name cmd)
  (if (not (comint-check-proc "*pcn*"))
      (let (pcn-cmd pcn-args)
	(if (or (not host)
		(string-equal host "")
		(string-equal host "local")
		(string-match (concat "^" (stringify host)) (system-name)))
	    (let ((cmdlist (pcn-args-to-list cmd)))
	      (setq pcn-cmd (car cmdlist)
		    pcn-args (cdr cmdlist)))
	  (setq pcn-cmd "rsh"
		pcn-args (list (stringify host)
			       (format "(cd %s ; %s)" path cmd))))
	(set-buffer (apply 'make-comint "pcn" pcn-cmd
			   nil pcn-args))
	(inferior-pcn-mode)))
  (setq pcn-buffer "*pcn*")
  (if (epoch-running)
      (progn (switch-to-buffer-other-screen pcn-buffer)
	     (raise-screen (current-screen)))
    (pop-to-buffer "*pcn*"))
  )

(defun pcn-send-region (start end)
  "Send the current region to the inferior Pcn process."
  (interactive "r")
  (comint-send-region (pcn-proc) start end)
  (comint-send-string (pcn-proc) "\n"))

(defun pcn-send-definition ()
  "Send the current definition to the inferior Pcn process."
  (interactive)
  (save-excursion
   (end-of-defun)
   (let ((end (point)))
     (beginning-of-defun)
     (pcn-send-region (point) end))))

(defun pcn-send-last-sexp ()
  "Send the previous sexp to the inferior Pcn process."
  (interactive)
  (pcn-send-region (save-excursion (backward-sexp) (point)) (point)))

(defvar pcn-compile-exp-command "(compile '%s)"
  "*Template for issuing commands to compile arbitrary Pcn expressions.")

(defun pcn-send (str)
  (save-excursion
    (set-buffer "*pcn-if*")
    (goto-char (point-max))
    (insert str)
    (insert "\n"))
  (comint-simple-send (pcn-proc) str)
)

(defun pcn-compile-region (start end)
  "Compile the current region in the inferior Pcn process
\(A BEGIN is wrapped around the region: (BEGIN <region>))"
  (interactive "r")
  (comint-send-string (pcn-proc) (format pcn-compile-exp-command
					    (format "(begin %s)"
						    (buffer-substring start end))))
  (comint-send-string (pcn-proc) "\n"))

(defun pcn-compile-definition ()
  "Compile the current definition in the inferior Pcn process."
  (interactive)
  (save-excursion
   (end-of-defun)
   (let ((end (point)))
     (beginning-of-defun)
     (pcn-compile-region (point) end))))

(defun switch-to-pcn (eob-p)
  "Switch to the pcn process buffer.
With argument, positions cursor at end of buffer."
  (interactive "P")
  (if (get-buffer pcn-buffer)
      (if (epoch-running)
	  (progn (switch-to-buffer-other-screen pcn-buffer) (raise-screen (current-screen)))
	(pop-to-buffer pcn-buffer))
      (error "No current process buffer. See variable pcn-buffer."))
  (cond (eob-p
	 (push-mark)
	 (goto-char (point-max)))))

(defun pcn-send-region-and-go (start end)
  "Send the current region to the inferior Pcn process,
and switch to the process buffer."
  (interactive "r")
  (pcn-send-region start end)
  (switch-to-pcn t))

(defun pcn-send-definition-and-go ()
  "Send the current definition to the inferior Pcn, 
and switch to the process buffer."
  (interactive)
  (pcn-send-definition)
  (switch-to-pcn t))

(defun pcn-compile-definition-and-go ()
  "Compile the current definition in the inferior Pcn, 
and switch to the process buffer."
  (interactive)
  (pcn-compile-definition)
  (switch-to-pcn t))

(defun pcn-compile-region-and-go (start end)
  "Compile the current region in the inferior Pcn, 
and switch to the process buffer."
  (interactive "r")
  (pcn-compile-region start end)
  (switch-to-pcn t))

(defvar pcn-source-modes '(pcn-mode)
  "*Used to determine if a buffer contains Pcn source code.
If it's loaded into a buffer that is in one of these major modes, it's
considered a pcn source file by pcn-load-file and pcn-compile-file.
Used by these commands to determine defaults.")

(defvar pcn-prev-l/c-dir/file nil
  "Caches the (directory . file) pair used in the last pcn-load-file or
pcn-compile-file command. Used for determining the default in the 
next one.")


(defun module-name (file)
  (substring file 0 (string-match "\\(.pcn$\\)\\|\\(.pam$\\)" file)))

(defun pcn-printf (fmt &rest args)
  (pcn-send (concat "stdio:printf(" (convert-pcn fmt) "," (convert-pcn args) ",_)")))

(defun convert-pcn (elm)
  (cond
   ((null elm) "[]")
   ((stringp elm) (concat "\""  (pcn-string elm) "\""))
   ((symbolp elm) (symbol-name elm))
   ((numberp elm) elm)
   ((listp elm) (convert-pcn-list elm))))

(defun convert-pcn-list (lst)
  (concat "[" (convert-list1 lst) "]")
  )

(defun convert-list1 (lst)
  (cond ((not lst) nil)
	((= (length lst) 1) (convert-pcn (car lst)))
	(t (concat (convert-pcn (car lst)) "," (convert-list1 (cdr lst))))))

(defun pcn-string (str)
  (let* ((index (string-match "\"\\|\n\\|\t" str)) 
	(match (and index (elt str (match-beginning 0))))
	(rest-str (and index (substring str (match-end 0)))))
    (if (null index) str
      (concat 
       (substring str 0 index) 
       (cond ((eq match ?\") "\\\"")
	     ((eq match ?\t) "\\t")
	     ((eq match ?\n) "\\n"))
       (if (string-equal rest-str "")  "" (pcn-string rest-str))))))

(defun pcn-load-file (file-name)
  "Load a Pcn file into the inferior Pcn process."
  (interactive (comint-get-source "Load Pcn file: " pcn-prev-l/c-dir/file
				  pcn-source-modes t)) ; T because LOAD 
                                                          ; needs an exact name
  (comint-check-source file-name) ; Check to see if buffer needs saved.
  (setq pcn-prev-l/c-dir/file (cons (file-name-directory    file-name)
				       (file-name-nondirectory file-name)))
  (comint-send-string (pcn-proc) (concat "load( \""
					    file-name
					    "\"\)\n"))
  (switch-to-pcn t))

(defun pcn-compile-file (file-name)
  "Compile a Pcn file in the inferior Pcn process."
  (interactive (comint-get-source "Compile Pcn file: "
				  pcn-prev-l/c-dir/file
				  pcn-source-modes
				  nil)) ; NIL because COMPILE doesn't
                                        ; need an exact name.
  ;; Check to see if buffer needs saved.
  (comint-check-source (concat (module-name file-name) ".pcn"))
  (setq pcn-prev-l/c-dir/file (cons (file-name-directory    file-name)
				       (file-name-nondirectory file-name)))
  (pcn-printf "Compiling PCN module: %s\\n" (module-name file-name))
  (pcn-send
   (concat "compile(\""
	   (module-name file-name)
	   "\"\)\n"))
  (switch-to-pcn t))

(defun pcn-run-goal (goal)
  "Start a PCN computation"
  (pcn-printf "Starting: %s\n" goal)
  (pcn-send (concat goal "\n"))
  (switch-to-pcn t))

(defun pcn-profile (goal done mods procs file)
  "Profile a PCN computation"
  (pcn-printf "Profiling: %s\\n" goal)
  (pcn-send "forget()")
  (pcn-send
   (concat 
    "profile(" goal "," done ","
    (convert-pcn (mapcar (function module-name) mods)) ","
    (convert-pcn procs) "," (convert-pcn file) ",_)"))
  (switch-to-pcn t)
  )



(defvar pcn-buffer nil "*The current pcn process buffer.

MULTIPLE PROCESS SUPPORT
===========================================================================
Cmupcn.el supports, in a fairly simple fashion, running multiple Pcn
processes. To run multiple Pcn processes, you start the first up with
\\[run-pcn]. It will be in a buffer named *pcn*. Rename this buffer
with \\[rename-buffer]. You may now start up a new process with another
\\[run-pcn]. It will be in a new buffer, named *pcn*. You can
switch between the different process buffers with \\[switch-to-buffer].

Commands that send text from source buffers to Pcn processes --
like pcn-send-definition or pcn-compile-region -- have to choose a
process to send to, when you have more than one Pcn process around. This
is determined by the global variable pcn-buffer. Suppose you
have three inferior Pcns running:
    Buffer	Process
    foo		pcn
    bar		pcn<2>
    *pcn*    pcn<3>
If you do a \\[pcn-send-definition-and-go] command on some Pcn source
code, what process do you send it to?

- If you're in a process buffer (foo, bar, or *pcn*), 
  you send it to that process.
- If you're in some other buffer (e.g., a source file), you
  send it to the process attached to buffer pcn-buffer.
This process selection is performed by function pcn-proc.

Whenever \\[run-pcn] fires up a new process, it resets pcn-buffer
to be the new process's buffer. If you only run one process, this will
do the right thing. If you run multiple processes, you can change
pcn-buffer to another process buffer with \\[set-variable].

More sophisticated approaches are, of course, possible. If you find youself
needing to switch back and forth between multiple processes frequently,
you may wish to consider ilisp.el, a larger, more sophisticated package
for running inferior Lisp and Pcn processes. The approach taken here is
for a minimal, simple implementation. Feel free to extend it.")

(defun pcn-proc ()
  "Returns the current pcn process. See variable pcn-buffer."
  (let ((proc (get-buffer-process (if (eq major-mode 'inferior-pcn-mode)
				      (current-buffer)
				      pcn-buffer))))
    (or proc
	(error "No current process. See variable pcn-buffer"))))


;;; Do the user's customisation...

(defvar cmupcn-load-hook nil
  "This hook is run when cmupcn is loaded in.
This is a good place to put keybindings.")
	
(run-hooks 'cmupcn-load-hook)


;;; CHANGE LOG
;;; ===========================================================================
;;; 8/88 Olin
;;; Created. 
;;;
;;; 2/15/89 Olin
;;; Removed -emacs flag from process invocation. It's only useful for
;;; cpcn, and makes cpcn assume it's running under xpcn.el,
;;; which messes things up royally. A bug.
;;;
;;; 5/22/90 Olin
;;; - Upgraded to use comint-send-string and comint-send-region.
;;; - run-pcn now offers to let you edit the command line if
;;;   you invoke it with a prefix-arg. M-x pcn is redundant, and
;;;   has been removed.
;;; - Explicit references to process "pcn" have been replaced with
;;;   (pcn-proc). This allows better handling of multiple process bufs.
;;; - Added pcn-send-last-sexp, bound to C-x C-e. A gnu convention.
;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist
;;;   and friends, but interested hackers might find a useful application
;;;   of this facility.