;
; ELisp mode for Stk Scheme Interpreter v2.0b
; Aime Frederic :
;  fred@castor.unice.fr, aime@samoa.unice.fr www : http://dico.unice.fr/~aime
;
; University of Nice Sophia Antipolis France
;
; This is free software, you can redistribute, modify WITHOUT ANY CHARGE ( under the terms of the
; FSF public general licence )
;
; This is the second release of my own stk mode
; please send bugs to fred@castor.unice.fr
;
; or use stk-submit-bug-report from a menu or aother
;
; NEW: FSF Emacs 19 support for menus
;      Integrated bug reporter
;      automatic insertion of some special forms					
;      
;
; BugFixes : now eval-buffer works with FSF Emacs 19
;      From 2.0a : XEmacs menus fixed
;
; Known bugs : Stk suprocess is not interactive....
;              menu stays sometimes in other modes under XEmacs 19.11				  
;              no color highlighting under FSF Emacs 19
;
;


; adds stk mode as an Emacs feature
(require 'scheme)
(provide 'stk-mode)

;
; Definition of the menu, even on menubar or popup menu
; feel free to add things here
;
(defvar stk-mode-menu
  '(["Run stk subprocess"       (run-stk) t]
    ["Kill stk subprocess"      (kill-stk) t]
    ["-------------------"      () t]
    ["Ident S-Expression"       (indent-sexp) t]
    ["Add define"             stk-add-define t]
    ["Add if"                stk-add-if t]
    ["Add cond"              stk-add-cond t]
    ["Add let"               stk-add-let t]
    ["Add case"              stk-add-case t]
    ["-------------------"      () t]
    ["Eval buffer"            (stk-eval-buffer) t]
    ["Eval function"          (stk-eval-function) t]
    ["Eval region"            (stk-eval-region) t]
    ["-------------------"    () t]
    ["Show Stk Window"        (stk-show-output) t]
    ["Hide Stk Window"        (stk-hide-output) t]
    ["-------------------"    () t]
    ["Submit bug report"      (stk-submit-bug-report) t]
    )
  "Lucid Emacs menu for stk modes.")



(defconst stk-mode-help-address "fred@castor.unice.fr"
  "Address accepting submission of bug reports.")


(defconst stk-mode-version "v2.0a")

(defconst stk-emacs-features
  (let ((mse-spec 'no-dual-comments)
	(scanner 'v18)
	flavor)
    ;; vanilla GNU18/Epoch 4 uses default values
    (if (= 8 (length (parse-partial-sexp (point) (point))))
	;; we know we're using v19 style dual-comment specifications.
	;; All Lemacsen use 8-bit modify-syntax-entry flags, as do all
	;; patched FSF19 (obsolete), GNU18, Epoch4's.  Only vanilla
	;; FSF19 uses 1-bit flag.  Lets be as smart as we can about
	;; figuring this out.
	(let ((table (copy-syntax-table)))
	  (modify-syntax-entry ?a ". 12345678" table)
	  (if (= (logand (lsh (aref table ?a) -16) 255) 255)
	      (setq mse-spec '8-bit)
	    (setq mse-spec '1-bit))
	  ;; we also know we're using a quicker, built-in comment
	  ;; scanner, but we don't know if its old-style or new.
	  ;; Fortunately we can ask emacs directly
	  (if (fboundp 'forward-comment)
	      (setq scanner 'v19)
	    ;; we no longer support older Lemacsen
	    (error "cc-mode no longer supports pre 19.8 Lemacsen. Upgrade!"))
	  ;; find out what flavor of Emacs 19 we're using
	  (if (string-match "Lucid" emacs-version)
	      (setq flavor 'Lucid)
	    (setq flavor 'FSF))
	  ))
    ;; now cobble up the necessary list
    (list mse-spec scanner flavor))
  "A list of features extant in the Emacs you are using.
There are many flavors of Emacs out there, each with different
features supporting those needed by cc-mode.  Here's the current
supported list, along with the values for this variable:

 Vanilla GNU 18/Epoch 4:   (no-dual-comments v18)
 GNU 18/Epoch 4 (patch2):  (8-bit v19 FSF)
 Lucid Emacs 19:           (8-bit v19 Lucid)
 FSF Emacs 19:             (1-bit v19 FSF).")


(defvar stk-name "stk")

(defvar stk-running ())

(defvar stk-process ())

;
; runs the inferior process stk...may be bugs here !!!
;
(defun run-stk ()
  (interactive)
  (if stk-running
      (message "Stk is already running")
    (progn
      (message "Launching stk process...")
      (delete-other-windows)
      (setq stk-process 
	    (start-process "Stk" "Stk" stk-name))
      (split-window)
      (switch-to-buffer "Stk")
      (message "Done")
      (setq stk-running t)))
  t)

;
; Switch to stk output window
;
(defun stk-show-output ()
  (if stk-running
      (progn
	(delete-other-windows)
	(split-window)
	(switch-to-buffer "Stk"))
    (message "Stk process is not running, there is no output")))

;
; hides the stk window
;
(defun stk-hide-output ()
  (if stk-running
      (delete-other-windows)
    (message "What do you want me to hide ??")))



;
; Kills the inferior process stk
;
(defun kill-stk ()
  (interactive)
  (if stk-running
      (progn
	(delete-process stk-process)
	(kill-buffer "Stk")
	(delete-other-windows)
	(setq stk-running ()))
    (message "There is no stk process active"))
  t)


;
; this ask stk inferior process ( if exists ) to eval pointed function 
;
(defun stk-eval-function ()
  (interactive)
  (if stk-running
      (progn
	(message "Sending current function to stk process...")
	(mark-defun)
	(copy-to-register '2 (region-beginning) (region-end))
	(process-send-string "Stk" (get-register '2))
	(process-send-string "Stk" "\n")
	(message "Done")
	t)
    (message "You must start the stk process first with C-c C-c .")))
  
;
; this ask stk inferior process ( if exists ) to eval the current region
;

(defun stk-eval-region ()
  (interactive)
  (if stk-running
      (progn
	(message "Sending current region to stk prodess...")
	(copy-to-register '2 (region-beginning) (region-end))
	(process-send-string "Stk" (get-register '2))
	(process-send-string "Stk" "\n")
	(message "Done")
	t)
    (message "You must start the stk process first with C-c C-c ."))
  t)

;
; this ask stk inferior process ( if exists ) to eval the buffer
;
(defun stk-eval-buffer ()
  (interactive)
  (if stk-running
      (progn
	(message "Sending entire buffer to stk process...be patient...")
	(mark-whole-buffer)
	(copy-to-register '2 (region-beginning) (region-end))
	(process-send-string "Stk" (get-register '2))
	(process-send-string "Stk" "\n")
	(message "Done")
	t)
    (message "You must start the stk process first with C-c C-c ."))
  t)

  
;
; Defines an empty stk-mode-map
;
(defvar stk-mode-map () "Keymap used in stk-mode buffers")

;
; Defines an empty stk-mode syntax table
;
(defvar stk-mode-syntax-table nil "")

;
; Creates new syntax table
;
(if stk-mode-syntax-table
    ()
  (setq stk-mode-syntax-table (make-syntax-table scheme-mode-syntax-table)))

;
; Creates and fill new mode map
;
;(if stk-mode-map
;    ()
;  (setq stk-mode-map (make-sparse-keymap))
;  (define-key stk-mode-map "\C-cf" 'stk-eval-function)
;  (define-key stk-mode-map "\C-cb"  'stk-eval-buffer)
;  (define-key stk-mode-map "\C-cr" 'stk-eval-region)
;  (define-key stk-mode-map "\C-c\C-c" 'run-stk)
;  (define-key stk-mode-map "\C-ck" 'kill-stk)
;  )


(defconst stk-font-lock-keywords
  (purecopy
   (list
    '("^;.*" . font-lock-comment-face)       ; comments

    '("define " . font-lock-type-face)       ; special forms
    '("if "    . font-lock-type-face )
    '("cond "  . font-lock-type-face )
    '("case[ \n\t]" . font-lock-type-face )
    '("let "   . font-lock-type-face )
    '("begin[ \n\t]" . font-lock-type-face )
    '("lambda"  . font-lock-type-face)
    '("else"   . font-lock-type-face)
    '("call/cc" . font-lock-type-face)

    '("c[ad]+r " . font-lock-doc-string-face) ; most used functions
    '("null?"   . font-lock-doc-string-face)
    '("cons "    . font-lock-doc-string-face)
    '("set!"    . font-lock-doc-string-face)
    '("not "     . font-lock-doc-string-face)
    '("equal?"  . font-lock-doc-string-face)
   
    '("#\."   . font-lock-comment-face)     ; strings and char
    '("\".*\""  . font-lock-string-face)
    '("define[ \t\n(]+\\([a-zA-Z0-9\-\_]+\\)" 1 font-lock-function-name-face t)


    ))
  "Colors provided only by the basic stk mode"
  )

;
; Lucid emacs specific stuff
;
(defun stk-lucid-specific ()
  (message "You are lucky, you've got a lucid emacs version...")
  (turn-on-font-lock)
  (define-key stk-mode-map 'button3 'stk-popup-menu)
  (add-menu nil "Stk" stk-mode-menu))

;
; FSF Emacs specific stuff
;
(defun fsf-emacs-specific ()
  )


;
; Pops up the menu 
;
(defun stk-popup-menu (e)
  "Pops up the stk menu."
  (interactive "@e")
  (popup-menu (cons (concat mode-name " Mode Commands") stk-mode-menu))
  (stk-keep-region-active))

;
; inspired from cc-mode ... strange...
;
(defun stk-keep-region-active ()
  (and (boundp 'zmacs-region-stays)
       (setq zmacs-region-stays t)))


;
; submit bug report
;

(defun stk-submit-bug-report ()
  "Submit via mail a bug report on stk-mode."
  (interactive)
  (require 'reporter)
  (and
   (y-or-n-p "Do you want to submit a report on stk-mode? ")
   (reporter-submit-bug-report
    stk-mode-help-address
    (concat "stk-mode version " stk-mode-version)
    (list
     'stk-emacs-features
     'stk-running
     ))))

; C-cd
(defun stk-add-define ( function-name vars )
  "Add a define"
  (interactive "sFuncion Name: \nsParameters: ")
  (insert "(define " function-name "\n\t(lambda (" vars ")\n\n)\n)")
  (forward-line -4)
  (cmpl-beginning-of-line)
  (indent-sexp)
  (forward-line 2))

; C-ci
(defun stk-add-if ( condition )
  "Add a if statment"
  (interactive "sCondition : ")
  (insert "(if " condition "\n\n)")
  (forward-line -3)
  (cmpl-beginning-of-line)
  (indent-sexp)
  (forward-line)
  (indent-sexp)
  (forward-line)
)

;
; C-cc
;

(defun stk-add-cond ()
  "Add a cond statment"
  (interactive)
  (insert "(cond ()\n\n)")
  (forward-line -2)
  (cmpl-beginning-of-line)
  (indent-sexp)
;  (forward-line)
  (cmpl-end-of-line)
  (set-window-point (screen-selected-window) (- (point) 1))
)

;
; C-cl
;

(defun stk-add-let ( vname expr )
  (interactive "sVariable name : \nsExpression : ")
  (insert "(let ((" vname " " expr ")\n)\n\n)")
  (forward-line -3)
  (cmpl-beginning-of-line)
  (indent-sexp)
  (forward-line 2))

;
; C-cs
;

(defun stk-add-case ( expr )
  (interactive "sExpression : ")
  (insert "(case " expr "\n(()   )\n\n)")
  (forward-line -3)
  (cmpl-beginning-of-line)
  (indent-sexp)
  (forward-line)
  (cmpl-end-of-line)
  (set-window-point (screen-selected-window) (- (point) 5))
)



;
; Main function for this mode
;
(defun stk-mode ()
"This mode was designed to makes interaction between emacs and stk
       Commands are :
      C-c f     :     Eval function
      C-c r     :     Eval region
      C-c b     :     Eval buffer
      C-c C-c   :     Run stk subprocess
      C-c k     :     Kill stk subprocess
      C-c d     :     Add define
      C-c i     :     Add if
      C-c c     :     Add cond
      C-c l     :     Add let
      C-c s     :     Add case"
  (interactive)
  (message "Building stk-mode...")
  (if stk-mode-map
      ()
    (setq stk-mode-map (make-sparse-keymap))
    (define-key stk-mode-map "\C-cf" 'stk-eval-function)
    (define-key stk-mode-map "\C-cb"  'stk-eval-buffer)
    (define-key stk-mode-map "\C-cr" 'stk-eval-region)
    (define-key stk-mode-map "\C-c\C-c" 'run-stk)
    (define-key stk-mode-map "\C-ck" 'kill-stk)
    (define-key stk-mode-map "\C-cd" 'stk-add-define)
    (define-key stk-mode-map "\C-ci" 'stk-add-if)
    (define-key stk-mode-map "\C-cc" 'stk-add-cond)
    (define-key stk-mode-map "\C-cl" 'stk-add-let)
    (define-key stk-mode-map "\C-cs" 'stk-add-case)
    (if (memq 'FSF stk-emacs-features)
	(progn
	  (message "Not lucky, you're only running FSF Emacs :(")
	  (font-lock-mode)
	  (load "hilit19")
	  (define-key stk-mode-map [menu-bar] (make-sparse-keymap))
	  (define-key stk-mode-map [menu-bar stk]
	    (cons "Stk" (make-sparse-keymap "Stk")))
	  (define-key stk-mode-map [menu-bar stk run-stk]
	    '("Run stk subprocess" . run-stk))
	  (define-key stk-mode-map [menu-bar stk kill-stk]
	    '("Kill stk subprocess" . kill-stk))
	  (define-key stk-mode-map [menu-bar stk stk-show-output]
	    '("Show stk window" . stk-show-output))
	  (define-key stk-mode-map [menu-bar stk stk-hide-output]
	    '("Hide stk window" . stk-hide-output))
	  (define-key stk-mode-map [menu-bar stk stk-eval-buffer]
	    '("Eval buffer" . stk-eval-buffer))
	  (define-key stk-mode-map [menu-bar stk stk-eval-function]
	    '("Eval Function" . stk-eval-function))
	  (define-key stk-mode-map [menu-bar stk stk-eval-region]
	    '("Eval region" . stk-eval-region))
	  (define-key stk-mode-map [menu-bar stk stk-submit-bug-report]
	    '("Submit bug report" . stk-submit-bug-report))
	  (define-key stk-mode-map [menu-bar stk indent-sexp]
	    '("Ident S-Expression" . indent-sexp))
	  (define-key stk-mode-map [menu-bar stk stk-add-define]
	    '("Add define" . stk-add-define))
	  (define-key stk-mode-map [menu-bar stk stk-add-if]
	    '("Add if" . stk-add-if))
	  (define-key stk-mode-map [menu-bar stk stk-add-cond]
	    '("Add cond" . stk-add-cond))
	  (define-key stk-mode-map [menu-bar stk stk-add-let]
	    '("Add let" . stk-add-let))
	  (define-key stk-mode-map [menu-bar stk stk-add-case]
	    '("Add case" . stk-add-case))
	  )))
  (if (string-match "Lucid" emacs-version)
      (stk-lucid-specific)
    (message "Not running with Lucid emacs, providing only a few features"))
    
  (kill-all-local-variables)
  (use-local-map stk-mode-map)
  (set-syntax-table stk-mode-syntax-table)
  (setq major-mode 'stk-mode)
  (setq mode-name "Scheme-tk")
  (lisp-mode-variables nil)
  (run-hooks 'stk-mode-hook)
  (message "Done")
  t)









