;;;; -*-Mode:LISP; Package:LISP; Base:10; Syntax:EmacsLisp -*-
;;;; Date:   2009/03/09
;;;; Title:  openlisp.el
;;;; Author: C. Jullien
;;;; RCS:    $Id: openlisp.el,v 1.16 2012-12-22 09:01:35 jullien Exp $

;;;
;;; OpenLisp mode.
;;;                      
;;; NOTE: This lisp file is for GNU-Emacs not for OpenLisp.
;;;

;;; Adapat and add the following lines to your .emacs:
;;;
;;; (let ((openlisp (concat (getenv "OPENLISP") "/emacs/openlisp.el")))
;;;      (cond
;;;            ((file-exists-p openlisp)
;;;             (load openlisp))
;;;            ((file-exists-p "c:/usr/jullien/openlisp/emacs/openlisp.el")
;;;             (load "c:/usr/jullien/openlisp/emacs/openlisp.el"))
;;;            ((file-exists-p "/home/jullien/.emacs.d/openlisp.el")
;;;             (load "/home/jullien/.emacs.d/openlisp.el"))))
;;;

;; Load the font-lock package.
(require 'font-lock)

;; Load the Lisp mode package
(require 'lisp-mode)

;; Inferior Lisp process
(load-library "inf-lisp")

;; Load the Lisp indent package
(load-library "cl-indent")

;; To highlight the region between the point and the mark:
(transient-mark-mode t)

;; To  highlight  matching  parenthesis:
(show-paren-mode 1)

;; Add new keybindings: C-x C-e evaluates the *next* form,
;; C-x C-m macroexpands the next form.

(defun openlisp-eval-sexp (&optional and-go)
   "Send the next sexp to the inferior Lisp process.
   Prefix argument means switch to the Lisp buffer afterwards."
   (interactive "P")
   (lisp-eval-region (point) (scan-sexps (point) 1) and-go))

(defun openlisp-eval-buffer (&optional and-go)
   "Evaluate entire buffer."
   (interactive "P")
   (mark-whole-buffer)
   (lisp-eval-region (point) (mark) and-go))

(defun openlisp-macroexpand-region (start end &optional and-go)
   "Macroexpand the current region in the inferior Lisp process.
   Prefix argument means switch to the Lisp buffer afterwards."
   (interactive "r\nP")
   (comint-send-string
          (inferior-lisp-proc)
          (format "(macroexpand-1 (quote %s))\n"
                  (buffer-substring-no-properties start end)))
   (if and-go
       (switch-to-lisp t)))

(defun openlisp-macroexpand-sexp (&optional and-go)
   "Macroexpand the next sexp in the inferior Lisp process.
   Prefix argument means switch to the Lisp buffer afterwards."
   (interactive "P")
   (openlisp-macroexpand-region (point) (scan-sexps (point) 1) and-go))

(defun openlisp-debug-off (&optional and-go)
   "Set debug mode off"
   (interactive)
   (comint-send-string
          (inferior-lisp-proc)
          (format "(debug nil)"))
   (if and-go
       (switch-to-lisp t)))

(defun openlisp-debug-on (&optional and-go)
   "Set debug mode on"
   (interactive)
   (comint-send-string
          (inferior-lisp-proc)
          (format "(debug t)"))
   (if and-go
       (switch-to-lisp t)))

(defun openlisp-trace ()
   "Trace function"
   (interactive)
   (let ((fn (read-from-minibuffer "Trace function: ")))
        (if (not (zerop (length fn)))
            (comint-send-string
                    (inferior-lisp-proc)
                    (format "(trace (quote %s))" fn)))))

(defun openlisp-untrace ()
   "Untrace function"
   (interactive)
   (let ((fn (read-from-minibuffer "Untrace function: ")))
        (if (not (zerop (length fn)))
            (comint-send-string
                    (inferior-lisp-proc)
                    (format "(untrace (quote %s))" fn)))))

(defun openlisp-fib (&optional and-go)
   "Call (fib 20) using OpenLisp"
   (comint-send-string
	   (inferior-lisp-proc)
	   (format "(fib 20)\n"))
   (if and-go
       (switch-to-lisp t)))

(defun openlisp-reindent ()
   "Reindent current line and mote to the next one"
   (interactive)
   (lisp-indent-line)
   (next-line)
   (beginning-of-line))

(defun openlisp ()
   "Run OpenLisp as inferior-lisp-process"
   (interactive)
   (setq inferior-lisp-program "c:/usr/bin/lisp -emacs")
   (let ((process-connection-type t))
        ;; This   variable  controls  the  type  of  device  used  to
        ;; communicate  with  asynchronous  subprocesses.  If  it  is
        ;; non-nil,  then PTYs are used,  when available.  Otherwise,
        ;; pipes are used.
	(run-lisp inferior-lisp-program)))

(defun openlisp-unicode ()
   "Run OpenLisp as inferior-lisp-process"
   (interactive)
   (setq inferior-lisp-program "c:/usr/bin/lisp -unicode -utf8 -emacs")
   (let ((coding-system-for-read  'utf-8)
         (coding-system-for-write 'utf-8)
         (coding-system-require-warning t)
         (process-connection-type t))

;        (prefer-coding-system       'utf-8)
;        (set-default-coding-systems 'utf-8)
;        (set-terminal-coding-system 'utf-8)
;        (set-keyboard-coding-system 'utf-8)
;        ;; This from a japanese individual.  I hope it works.
;        (setq default-buffer-file-coding-system 'utf-8)
;        ;; From Emacs wiki
;        (setq x-select-request-type '(UTF8_STRING COMPOUND_TEXT TEXT STRING))
;        ;; MS Windows clipboard is UTF-16LE 
;        (set-clipboard-coding-system 'utf-16le-dos)

        (run-lisp inferior-lisp-program)))

(defun clisp ()
   (interactive)
   (setq inferior-lisp-program "c:/usr/jullien/clisp-2.47/clisp -I")
   (run-lisp inferior-lisp-program))

(defun lisp-compile-file (file-name)
   "Compile a Lisp file in the inferior Lisp process."
   (interactive (comint-get-source
                        "Compile Lisp file: "
                        lisp-prev-l/c-dir/file
                        lisp-source-modes nil)) ; nil = don't need suffix .lisp
   (comint-check-source file-name) ; Check to see if buffer needs saved.
   (setq lisp-prev-l/c-dir/file (cons (file-name-directory    file-name)
                                      (file-name-nondirectory file-name)))
   (comint-send-string (inferior-lisp-proc)
           (concat "(compile-file \"" file-name "\" :cc\)\n"))
   (switch-to-lisp t))

;; The  above  code  uses  the  default faces for decoration.  If you
;; would  like to customize the attributes of the faces,  you can use
;; the following startup code to get started

(when (fboundp 'global-font-lock-mode)
      ;; Customize face attributes
      (setq font-lock-face-attributes
            ;; Symbol-for-Face Foreground Background Bold Italic Underline
            '(
               (font-lock-builtin-face       "MediumPurple")
               (font-lock-comment-face       "Green")
               (font-lock-constant-face      "Orchid")
               (font-lock-function-name-face "Orange")
               (font-lock-keyword-face       "Cyan")
               (font-lock-string-face        "Yellow")
               (font-lock-type-face          "DodgerBlue")
               (font-lock-variable-name-face "Orange")
               (font-lock-warning-face       "Red")
               (font-lock-preprocessor-face  "White")
               ))
       ;; Maximum colors
       (setq font-lock-maximum-decoration t)
       ;; Turn on font-lock in all modes that support it
       (global-font-lock-mode t))

;; To  highlight  the region between the point and the mark,  use the
;; function transient-mark-mode: 

(transient-mark-mode t)

;; To  highlight  matching  parenthesis,  add  the  following to your
;; startup file: 

(show-paren-mode 1)

(custom-set-variables
  ;; custom-set-variables was added by Custom.
  ;; If you edit it by hand, you could mess it up, so be careful.
  ;; Your init file should contain only one such instance.
  ;; If there is more than one, they won't work right.
 '(safe-local-variable-values
        (quote ((Syntax   . ANSI-Common-Lisp)
                (Syntax   . EmacsLisp)
                (Mode     . LISP)
                (Package  . LISP)
                (Base     . 10)
                (Syntax   . ISLISP)
                (Encoding . utf-8)
                (Encoding . utf-16)))))

;; Lisp system on this machine

(setq inferior-lisp-prompt  "^[^>? \n]*>+:? *")

;;
;; set path to join OpenLisp
;;

(if (eq system-type 'windows-nt)
    (setq inferior-lisp-program "c:/usr/bin/lisp -emacs")
    (setq inferior-lisp-program "/usr/bin/env openlisp -emacs"))

(defun openlisp-mode-hook ()
   "Hook for running OpenLisp file..."
   (setq tab-width 8)
   ;; make sure spaces are used instead of tabs
   (setq indent-tabs-mode      nil)
   (setq lisp-body-indent      3)
   (setq case-fold-search      t)
   (setq lisp-indent-function  'common-lisp-indent-function)
   (set (make-local-variable 'lisp-indent-function)
        'common-lisp-indent-function)
   (setq lisp-indent-maximum-backtracking 10)
   t)

(add-hook 'lisp-mode-hook             'openlisp-mode-hook)
(add-hook 'lisp-interaction-mode-hook 'openlisp-mode-hook)

(defconst lisp-font-lock-keywords-1
   (eval-when-compile
        (list
         ;;
         ;; Definitions.
         (list (concat
                  "(\\(def\\("
                  ;; Function declarations.
                  "\\(inline\\|alias\\|generic\\|macro\\*?\\|method\\|"
                  "setf\\|subst\\*?\\|un\\*?\\|"
                  "ine-\\(condition\\|derived-mode\\|function\\|"
                  "method-combination\\|setf-expander\\|skeleton\\|widget\\|"
                  "\\(compiler\\|modify\\|symbol\\)-macro\\)\\)\\|"
                  ;; Variable declarations.
                  "\\(const\\(ant\\)?\\|"
                  "custom\\|dynamic\\|face\\|global\\|parameter\\|var\\)\\|"
                  ;; Structure declarations.
                  "\\(class\\|group\\|package\\|struct\\|type\\)"
                  "\\)\\)\\>"
                  ;; Any whitespace and defined object.
                  "[ \t'\(]*"
                  "\\(\\sw+\\)?")
               '(1 font-lock-keyword-face)
               '(9 (cond
                         ((match-beginning 3) font-lock-function-name-face)
                         ((match-beginning 6) font-lock-variable-name-face)
                         (t                   font-lock-type-face))
                    nil
                    t))
         ;;
         ;; Emacs Lisp autoload cookies.
         '("^;;;###\\(autoload\\)\\>" 1 font-lock-warning-face prepend)
         ))
  "Subdued level highlighting for Lisp modes.")

(defconst lisp-font-lock-keywords-2
  (append lisp-font-lock-keywords-1
   (eval-when-compile
     (list
      ;;
      ;; Control structures. ISLISP Special Forms.
      ;;
      (cons (concat
	      "("
	         (regexp-opt
		  '(
		    ;;
		    ;; ISLISP Reserved symbols
		    ;;
		    "and"
		    "assure"
		    "block"
		    "case"
		    "case-using"
		    "catch"
		    "class"
		    "cond"
		    "convert"
		    "defclass"
		    "defconstant"
		    "defdynamic"
		    "defgeneric"
		    "defglobal"
		    "defmacro"
		    "defmethod"
		    "defun"
		    "dynamic"
		    "dynamic-let"
		    "flet"
		    "for"
		    "function"
		    "go"
		    "if"
		    "ignore-errors"
		    "labels"
		    "lambda"
		    "let"
		    "let*"
		    "or"
		    "progn"
		    "quote"
		    "return-from"
		    "setf"
		    "setq"
		    "set-dynamic"
		    "tagbody"
		    "the"
		    "throw"
		    "unwind-protect"
		    "while"
		    "with-error-output"
		    "with-handler"
		    "with-open-input-file"
		    "with-open-io-file"
		    "with-open-output-file"
		    "with-standard-input"
		    "with-standard-output"
		    ;;
		    ;; ISLISP Extra
		    ;;
		    "prog1"
		    "psetq"
		    "unless"
		    "when"
		    )
                   t)
	     "\\>")
	    1)
      ;;
      ;; Other reserved keywords
      ;;
      '("\\<\\(t\\|nil\\|&rest\\)\\>" 0 font-lock-keyword-face)
      ;;
      ;; Module management
      ;;
      '("(\\(featurep\\|provide\\|require\\)\\>[ \t']*\\(\\sw+\\)?"
	(1 font-lock-keyword-face)
	(2 font-lock-constant-face nil t))
      ;;
      ;; Package management
      ;;
      '("(\\(export\\|import\\|in-package\\|use-package\\)\\>[ \t']*\\(\\sw+\\)?"
	(1 font-lock-keyword-face)
	(2 font-lock-constant-face nil t))
      ;;
      ;; Feature symbols as references.
      ;;
      '("(\\(defstruct\\|defclass\\)\\>[ \t']*\\(\\sw+\\)?"
	(1 font-lock-keyword-face)
	(2 font-lock-type-face nil t))
      ;;
      ;; OpenLisp `&' keywords as keywords. 
      ;;
      '("\\&\\sw+\\>" 0 font-lock-keyword-face) 
      ;;
      ;; types (classes of structures)
      ;;
      '("\\<[<]\\sw+[>]\\>" 0 font-lock-type-face) 
      ;;
      ;; Words inside `' tend to be symbol names.
      ;;
      '("`\\(\\sw\\sw+\\)'" 1 font-lock-reference-face prepend)
      ;;
      ;; ISLisp `:' keywords as builtins.
      ;;
      '("\\<:\\sw\\sw+\\>" 0 font-lock-builtin-face)
      ;;
      ;; ISLisp numbers.
      ;;
      '("\\<[-+]?[0-9]+\\>"         0 font-lock-constant-face)
      '("\\<[-+]?[0-9]+\.[0-9]+\\>" 0 font-lock-constant-face)
      )))
  "Lisp modes.")

;;;
;;; Add more extensions to auto-lisp mode.
;;;

(setq auto-mode-alist
      (append '(("\\inferior-lisp" . lisp-mode)
		("\\.ll\\'"        . lisp-mode)
		("\\.lm\\'"        . lisp-mode)
		("\\.lap\\'"       . lisp-mode))
	      auto-mode-alist))

(defvar lisp-font-lock-keywords lisp-font-lock-keywords-1
  "Default expressions to highlight in Lisp modes.")

(eval-after-load "font-lock"
  '(setq
	lisp-font-lock-keywords	lisp-font-lock-keywords-2))

;;;
;;; Lisp indentation
;;;

(defmacro defindent (operator indentation)
  `(put ',operator 'common-lisp-indent-function ',indentation))

(setq lisp-indent-function   'common-lisp-indent-function)
(setq lisp-body-indent       3)  ;; default

(defindent and                    (&rest 6))
(defindent block                  (7 7))
(defindent case                   (6 6))
(defindent case-using             (6 6))
(defindent catch                  (7 7))
(defindent cond                   (6 6))
(defindent do                     ((&whole nil &rest) (&whole nil &rest 4)))
(defindent do*                    ((&whole nil &rest) (&whole nil &rest 5)))
(defindent dolist                 ((&whole 4 1 1) &body))
(defindent dotimes                ((&whole 4 1 1) &body))
(defindent dynamic-let            ((&whole 9 &rest (&whole 1 2 2)) 9))
(defindent for                    ((&whole nil &rest) (&whole nil &rest 5)))
(defindent if                     4)
(defindent lambda                 ((&whole 4 1 &rest 1) 3))
(defindent let                    ((&whole 5 &rest (&whole 1 2 2)) 5))
(defindent let*                   ((&whole 6 &rest (&whole 1 2 2)) 6))
(defindent or                     (&rest 4))
(defindent prog1                  (7 7))
(defindent progn                  (7 7))
(defindent tagbody                lisp-indent-tagbody)
(defindent unless                 (8 8))
(defindent until                  (7 7))
(defindent unwind-protect         (8 8))
(defindent when                   (6 6))
(defindent while                  (7 7))
(defindent with-client-socket     ((&whole 5 1 &rest 1) 5))
(defindent with-error-output      ((&whole 5 1 &rest 1) 5))
(defindent with-input-from-string ((&whole 5 1 &rest 1) 5))
(defindent with-open-input-file   ((&whole 5 1 &rest 1) 5))
(defindent with-open-input-pipe   ((&whole 5 1 &rest 1) 5))
(defindent with-open-io-file      ((&whole 5 1 &rest 1) 5))
(defindent with-open-output-file  ((&whole 5 1 &rest 1) 5))
(defindent with-output-to-string  ((&whole 5 1 &rest 1) 5))
(defindent with-server-socket     ((&whole 5 1 &rest 1) 5))
(defindent with-standard-intput   ((&whole 5 1 &rest 1) 5))
(defindent with-standard-output   ((&whole 5 1 &rest 1) 5))

;;;
;;; Define new keys
;;;

(define-key lisp-mode-map           "\C-x\C-e" 'openlisp-eval-sexp)
(define-key lisp-mode-map           "\C-x\C-h" 'openlisp-eval-buffer)
(define-key lisp-mode-map           "\C-x\C-m" 'openlisp-macroexpand-sexp)
(define-key lisp-mode-map           "\C-x\C-z" 'openlisp)
(define-key lisp-mode-map           [return]   'newline-and-indent)
(define-key lisp-mode-map           [f4]       'openlisp-reindent)


(define-key lisp-mode-map           "\C-c\C-e" 'lisp-eval-defun)
(define-key lisp-mode-map           "\C-c\C-r" 'lisp-eval-region)
(define-key lisp-mode-map           "\C-c\C-c" 'lisp-compile-defun)
(define-key lisp-mode-map           "\C-c\C-z" 'switch-to-lisp)
(define-key lisp-mode-map           "\C-c\C-l" 'lisp-load-file)
(define-key lisp-mode-map           "\C-c\C-k" 'lisp-compile-file)

(global-set-key                     [f12]      'openlisp)

;; Rebind ESG-g to goto-line

(global-set-key                     "\M-g"     'goto-line)

(define-key inferior-lisp-mode-map "\C-x\C-e" 'openlisp-eval-sexp)
(define-key inferior-lisp-mode-map "\C-x\C-m" 'openlisp-macroexpand-sexp)
;; from inf-lisp.el
(define-key inferior-lisp-mode-map "\C-c\C-l" 'lisp-load-file)
(define-key inferior-lisp-mode-map "\C-c\C-k" 'lisp-compile-file)

(defvar lisp-general-menu-map (make-sparse-keymap "OpenLisp")
  "Keymap for main OpenLisp menu")

(define-key inferior-lisp-mode-map [menu-bar openlisp]
  (cons "OpenLisp" lisp-general-menu-map))

(define-key inferior-lisp-mode-map [menu-bar openlisp debug-off]
  '("Debug Off" . openlisp-debug-off))

(define-key inferior-lisp-mode-map [menu-bar openlisp debug-on]
  '("Debug On" . openlisp-debug-on))

(define-key inferior-lisp-mode-map [menu-bar openlisp untrace]
  '("Untrace ..." . openlisp-untrace))

(define-key inferior-lisp-mode-map [menu-bar openlisp trace]
  '("Trace ..." . openlisp-trace))

;;; - End of OpenLisp customization