Archiving a historic piece of code. .emacs that allows emacs to interface with Mirai.

mirai-emacs-init.lisp

;; Original file can be found here: https://web.archive.org/web/20030317235658/http://www.snowcrest.net:80/dpriest/x.emacs

;; to start type alt-0 alt-x, then (hi-i:say-hi) at the prompt

;;(setq load-path (append load-path (list  "x:/mirai-1-1/eli")))
(setq load-path (append load-path (list  "d:/mirai-1-1/eli")))
(load "fi-site-init")


(setf fi::common-lisp-first-time nil)


(setf fi:common-lisp-directory
      (if (mswindows-system-p)
          temporary-file-directory
        "/tmp/"))


;;(setf fi:common-lisp-image-name "x:/mirai-1-1/mirai.exe")
(setf fi:common-lisp-image-name "d:/mirai-1-1/mirai.exe")
;;(setf fi:common-lisp-image-file "x:/mirai-1-1/mirai.dxl")
(setf fi:common-lisp-image-file "mirai.dxl")


(setf fi:common-lisp-image-arguments (list "-- NO_AUTOSTART t"))


;; start with alt-0 alt-x common-lisp
;; (fi:common-lisp)


(custom-set-variables
 '(disable-auto-save-when-buffer-shrinks nil)
 '(auto-save-default t)
 '(auto-save-interval 100)
 '(ps-italic-faces (quote (Courier-Oblique)))
 '(ps-font-size 10)
 '(ps-bold-faces (quote (Courier)))
 '(auto-save-visited-file-name nil))


(custom-set-faces)
(global-set-key '[C-tab] 'other-window)


(let ((tag 'fi:common-lisp-indent-hook))


  (put 'with-begin-end tag '(like progn))
  (put 'with-begin-end-quads tag '(like progn))
  (put 'with-begin-end-line-strip tag '(like progn))
  (put 'with-begin-end-lines tag '(like progn))
  (put 'using-ftriplet tag '(like when))
  (put 'using-fquad tag '(like when))
  (put 'using-transform-matrix tag '(like when))
  (put 'if tag '(like when))
  (put 'then tag '(like progn))
  (put 'else tag '(like progn))
  (put 'with-color tag '(like with-slots))
  (put 'ignore-errors tag '(like with-slots))
  (put 'double-checking-gl-line-width-bb tag '(like with-slots))
  (put 'with-bone-transform-matrix tag '(like with-slots))
  (put 'sp_noting-progress tag '(like when))
  (put 'doarray tag '(like using-ftriplet))
  (put 'with-sound tag '(like progn))
  (put 'with-sound-if-needed tag '(like progn))
  (put 'prog2 tag '(like progn))
  (put 'with-fast-hi tag '(like progn))
  (put 'prog1 tag '(like progn))
  (put 'updating-body-modification-code tag '(like defun))
  (put 'with-viewer-env tag '(like when))
  (put 'ftriplet-values-bind tag '(like with-slots))
  (put 'with-readonly-slots tag '(like with-slots))
  t
  )


(put 'if 'lisp-indent-function 4)


(defun insert-modified-tag ()
  (interactive)
  (insert ";; changed - " (user-login-name) " " (nst::date) ""))


(global-set-key "\C-c\C-m" 'insert-modified-tag)


(setq minibuffer-max-depth nil)


(setq font-lock-maximum-size (* 2000 1024))


(global-set-key "\C-x\C-b" 'switch-to-buffer)
(global-set-key "\C-x\C-u" 'list-buffers)
(global-set-key "\C-xu"    'list-buffers)


(unless (string-match "XEmacs" emacs-version)
  (defun previous-block (arg)
    (interactive "p")
    (forward-line -6))


  (defun next-block (arg)
    (interactive "p")
    (forward-line 6))


  (global-set-key [C-tab] 'other-window)
  (global-set-key [C-up] 'previous-block)
  (global-set-key [C-down] 'next-block)
  (global-set-key [end] 'end-of-line)
  (global-set-key [home] 'beginning-of-line)
  (global-set-key [C-home] 'beginning-of-buffer)
  (global-set-key [C-end] 'end-of-buffer)


  (setq-default highlight-paren-expression nil)
  (setq-default overwrite-mode nil)
  (setq-default teach-extended-commands-p t)
  (setq-default complex-buffers-menu-p nil)
  (setq-default buffers-menu-max-size nil)
  (setq-default case-fold-search t)


  (require 'delsel)


  (require 'mouse-copy)
  (global-set-key [C-down-mouse-1] 'mouse-drag-secondary-pasting)
  (global-set-key [C-S-down-mouse-1] 'mouse-drag-secondary-moving))


(global-set-key "\M-g" 'goto-line)
(delete-selection-mode t)


(defun insert-comment ()
  "Parse the current line expecting to find a function/method/... definition
   and makes a comment out of it.


   Note that this function uses the kill-ring !"
  (interactive)
  (cond
   ((nst::any-lisp-mode)
    (save-excursion
      (let (fn-type fn-name fn-params beg end
                    returns operation notes param-list)


        ;; workout the function type
        (beginning-of-line)
        (forward-char)
        (setf beg (point))
        (push-mark nil nil t)
        (forward-sexp)
        (let ((definition (buffer-substring beg (point))))
          (cond
           ((string-equal definition "defmacro")    (setf fn-type "Macro     "))
           ((string-equal definition "defun")       (setf fn-type "Function  "))
           ((string-equal definition "defmethod")   (setf fn-type "Method    "))
           ((string-equal definition "defedmethod") (setf fn-type "Edmethod  "))
           ((string-equal definition "defstub")     (setf fn-type "Stub      "))
           (t (setf fn-type current-kill))))


        ;; workout the function name
        (skip-chars-forward " \t")
        (setf beg (point))
        (push-mark nil nil t)
        (re-search-forward "(" (save-excursion
                                 (end-of-line)
                                 (point)))
        (backward-char)
        (if (= beg (point))
            (forward-sexp) ; must a setf method
            (skip-chars-backward " \t"))
        (setf fn-name (buffer-substring beg (point)))
            
        ;; workout the parameter set
        (re-search-forward "(")
        (skip-chars-forward " \t")
        (while (not (looking-at ")"))
          (if (looking-at "(")
              (progn ;; must be of the sort (param class)
                (save-excursion
                  (forward-char)
                  (setf beg (point))
                  (forward-sexp)
                  (setf param (buffer-substring beg (point))))
                (forward-sexp))
              (progn ;; must be a simple argument
                (setf beg (point))
                (forward-sexp)
                (setf param (buffer-substring beg (point)))))
          (unless (or (string-equal param "&key")
                      (string-equal param "&rest")
                      (string-equal param "&aux")
                      (string-equal param "&optional")
                      (string-equal param "&body")
                      (string-equal param "&allow-other-keys"))
            (push (list param (read-string (concat param ": ") nil)) param-list))
          (skip-chars-forward " \t"))


        (forward-char)


        (setf operation (read-string "Operation: " nil))
        (when (= (length operation) 0)
          (setf operation nil))


        (setf returns (read-string "Returns: " nil))
        (when (= (length returns) 0)
          (setf returns "The value returned is unspecified"))


        (setf notes (read-string "Notes: " nil))
        (when (= (length notes) 0)
          (setf notes nil))


        ;; output the comment
        (insert-and-inherit ?\n)
        (indent-according-to-mode) (insert "#@s\(\"" fn-type ": " fn-name "\"\n")
        (indent-according-to-mode) (insert "\"Created   : " (nst::date) " - " (user-login-name) "\"\n")
        (when operation
          (indent-according-to-mode) (insert "\"Operation : " operation "\"\n"))
        (dolist (param (nreverse param-list))
          (when (> (length (cadr param)) 0)
            (indent-according-to-mode) (insert "\"  " (car param) "\t : " (cadr param) "\"\n")))
        (indent-according-to-mode) (insert "\"Returns   : " returns "\"")
        (when notes
          (insert "\n") (indent-according-to-mode) (insert "\"Notes : " notes "\""))
        (insert "\)"))))


   (t (message "Sorry: insert-comment not implemented for this Mode."))))


(global-set-key "\M--" 'insert-comment)


(setf nst:*world-target*
      (cond
       ((unix-system-p)
        (cond
         ((eq system-type 'irix)  "acl5011-sgi63-debug")
         ((eq system-type 'linux) "acl5011-redhat5-debug")))
       ((mswindows-system-p) "acl5011-nt40-debug")))


(put 'downcase-region 'disabled nil)


;; makes emacs work more like a typical windows application
;;(global-set-key "\C-z" 'undo)
;;(global-set-key "\C-y" 'undo)
;;(global-set-key "\C-v" 'yank)


(require 'hilit19)