src/main.lisp

   1 (in-package "LICE")
   2
   3 ;;
   4 #+cmu (setf extensions:*gc-notify-after* (lambda (&rest r))
   5             extensions:*gc-notify-before* (lambda (&rest r)))
   6
   7 (defun init-mode-line-format ()
   8   (setf *default-mode-line-format*
   9         (list "--:" ;; fake it for hype
  10               (lambda (buffer)
  11                 (format nil "~C~C"
  12                         ;; FIXME: add read-only stuff
  13                         (if (buffer-modified-p buffer)
  14                             #\* #\-)
  15                         (if (buffer-modified-p buffer)
  16                             #\* #\-)))
  17               "  "
  18               (lambda (buffer)
  19                 (format nil "~12,,,a" (buffer-name buffer)))
  20               "   "
  21               (lambda (buffer)
  22                 (format nil "(~a)"
  23                         (major-mode-name (symbol-value (buffer-major-mode buffer))))))))
  24
  25 (defun lice ()
  26   "Run the lice environment."
  27   (unwind-protect
  28       (progn
  29         (dformat +debug-v+ "-- Start lice~%")
  30         #+(or cmu sbcl) (init-tty)
  31         #+clisp (init-clisp)
  32         (setf *buffer-list* nil)
  33         #+movitz (init-commands)
  34         (init-mode-line-format)
  35         (make-default-buffers)
  36         (set-buffer (get-buffer "*messages*"))
  37         ;; for the scratch buffer
  38         (set-buffer (get-buffer "*scratch*"))
  39         (insert *initial-scratch-message*)
  40         ;; FIXME: is this a hack?
  41         (setf (buffer-modified-p (current-buffer)) nil
  42               (buffer-undo-list (current-buffer)) nil)
  43         (goto-char (point-min))
  44         (set-major-mode '*lisp-interaction-mode*)
  45         (init-command-arg-types)
  46         (setf *frame-list* (list #+(or cmu sbcl) (make-default-tty-frame (get-buffer "*scratch*"))
  47                                  #+clisp (make-default-clisp-frame (get-buffer "*scratch*"))
  48                                  #+mcl (make-default-mcl-frame (get-buffer "*scratch*"))
  49                                  #+movitz (make-default-movitz-frame (get-buffer "*scratch*")))
  50               *selected-frame* (car *frame-list*)
  51               *process-list* nil)
  52         ;;(make-global-keymaps)
  53         (catch 'lice-quit
  54           #+clisp
  55           (ext:with-keyboard
  56               (loop
  57                  (with-simple-restart (recursive-edit-top-level "Return to LiCE top level")
  58                    (recursive-edit))))
  59           #-clisp
  60           (loop
  61              (with-simple-restart (recursive-edit-top-level "Return to LiCE top level")
  62                (recursive-edit)))))
  63     (progn
  64       #+(or cmu sbcl) (shutdown-tty)
  65       #+clisp (shutdown)
  66       (dformat +debug-v+ "-- End lice~%"))))
  67
  68 #+movitz
  69 (defun init-commands ()
  70   "Our special wikked hack."
  71   (macrolet ((create-cmd (name &rest args)
  72                          (let ((tmp (gensym)))
  73                            `(setf (gethash ',name *commands*)
  74                                   (make-instance
  75                                    'command
  76                                    :name ',name
  77                                    :args ',(delete nil (mapcar (lambda (a)
  78                                                                  (when (listp a) (second a)))
  79                                                                args))
  80                                    :doc nil
  81                                    :fn (lambda ()
  82                                          (let ((,tmp (list ,@(delete nil (mapcar (lambda (a)
  83                                                                                    (when (listp a)
  84                                                                                      `(funcall (gethash ,(second a) *command-arg-type-hash*) ,@(cddr a))))
  85                                                                                  args)))))
  86                                            ;; XXX: Is this a sick hack?  We need to reset the
  87                                            ;; prefix-arg at the right time. After the command
  88                                            ;; is executed we can't because the universal
  89                                            ;; argument code sets the prefix-arg for the next
  90                                            ;; command. The Right spot seems to be to reset it
  91                                            ;; once a command is about to be executed, and
  92                                            ;; after the prefix arg has been gathered to be
  93                                            ;; used in the command. Which is right here.
  94                                            (setf *prefix-arg* nil)
  95                                            ;; Note that we use the actual function. If the
  96                                            ;; function is redefined, the command will
  97                                            ;; continue to be defined and will call the
  98                                            ;; function declared above, not the redefined one.
  99                                            (apply #',name ,tmp))))))))
 100     (setf fundamental-mode
 101           (make-instance 'major-mode
 102                          :name "Fundamental"
 103                          :map (make-hash-table)
 104                          :init-fn (lambda ()))
 105           minibuffer-read-mode
 106           (make-instance 'major-mode
 107                          :name "minibuffer mode"
 108                          :map (let ((m (make-sparse-keymap)))
 109                                 (define-key m (make-instance 'key :char #\m :control t) 'exit-minibuffer)
 110                                 (define-key m (make-instance 'key :char #\Newline) 'exit-minibuffer)
 111                                 (define-key m (make-instance 'key :char #\j :control t) 'exit-minibuffer)
 112                                 (define-key m (make-instance 'key :char #\p :meta t) 'previous-history-element)
 113                                 (define-key m (make-instance 'key :char #\n :meta t) 'next-history-element)
 114                                 (define-key m (make-instance 'key :char #\g :control t) 'abort-recursive-edit)
 115                                 m)
 116                          :init-fn (lambda ()))
 117           minibuffer-complete-mode
 118           (make-instance 'major-mode
 119                          :name "minibuffer complete mode"
 120                          :map (let ((m (make-sparse-keymap)))
 121                                 (define-key m (make-instance 'key :char #\m :control t) 'minibuffer-complete-and-exit)
 122                                 (define-key m (make-instance 'key :char #\Newline) 'minibuffer-complete-and-exit)
 123                                 (define-key m (make-instance 'key :char #\j :control t) 'minibuffer-complete-and-exit)
 124                                 (define-key m (make-instance 'key :char #\p :meta t) 'previous-history-element)
 125                                 (define-key m (make-instance 'key :char #\n :meta t) 'next-history-element)
 126                                 (define-key m (make-instance 'key :char #\i :control t) 'minibuffer-complete)
 127                                 (define-key m (make-instance 'key :char #\Tab) 'minibuffer-complete)
 128                                 (define-key m (make-instance 'key :char #\g :control t) 'abort-recursive-edit)
 129                                 m)
 130                          :init-fn (lambda ()))
 131           lisp-interaction-mode
 132           (make-instance 'major-mode :name "Lisp Interaction"
 133                          :map (let ((m (make-sparse-keymap)))
 134                                 (define-key m (make-instance 'key :char #\j :control t) 'eval-print-last-sexp)
 135                                 m)
 136                          :init-fn (lambda ()))
 137           *universal-argument-map*
 138           (let ((map (make-sparse-keymap)))
 139             (define-key map t 'universal-argument-other-key)
 140             (define-key map (kbd "C-u") 'universal-argument-more)
 141             (define-key map (kbd "-") 'universal-argument-minus)
 142             (define-key map (kbd "0") 'digit-argument)
 143             (define-key map (kbd "1") 'digit-argument)
 144             (define-key map (kbd "2") 'digit-argument)
 145             (define-key map (kbd "3") 'digit-argument)
 146             (define-key map (kbd "4") 'digit-argument)
 147             (define-key map (kbd "5") 'digit-argument)
 148             (define-key map (kbd "6") 'digit-argument)
 149             (define-key map (kbd "7") 'digit-argument)
 150             (define-key map (kbd "8") 'digit-argument)
 151             (define-key map (kbd "9") 'digit-argument)
 152             map))
 153     (setf *mode-line-format* (list "--:" ;; fake it for hype
 154                                        (lambda (buffer)
 155                                          (format nil "~C~C"
 156                                               ;; FIXME: add read-only stuff
 157                                               (if (buffer-modified-p buffer)
 158                                                   #\* #\-)
 159                                               (if (buffer-modified-p buffer)
 160                                                   #\* #\-)))
 161                                        "  "
 162                                        (lambda (buffer)
 163                                          (format nil "~12,,,a" (buffer-name buffer)))
 164                                        "   "
 165                                        (lambda (buffer)
 166                                          (format nil "(~a)"
 167                                               (major-mode-name (buffer-major-mode buffer))))))
 168     (setf *commands* (make-hash-table :size 100))
 169     (create-cmd forward-sexp)
 170     (create-cmd backward-sexp)
 171     (create-cmd eval-last-sexp)
 172     (create-cmd eval-print-last-sexp)
 173     (create-cmd lisp-interaction-mode)
 174     (create-cmd ask-user)
 175     (create-cmd exit-minibuffer)
 176     (create-cmd abort-recursive-edit)
 177     (create-cmd minibuffer-complete-and-exit)
 178     (create-cmd next-history-element (n :prefix))
 179     (create-cmd previous-history-element)
 180     (create-cmd minibuffer-complete)
 181     (create-cmd forward-char (n :prefix))
 182     (create-cmd backward-char (n :prefix))
 183     (create-cmd self-insert-command (arg :prefix))
 184     (create-cmd newline)
 185     (create-cmd next-line (n :prefix))
 186     (create-cmd previous-line (n :prefix))
 187     (create-cmd delete-backward-char)
 188     (create-cmd delete-char)
 189     (create-cmd beginning-of-line)
 190     (create-cmd end-of-line)
 191     (create-cmd erase-buffer)
 192     (create-cmd execute-extended-command (n :prefix))
 193     (create-cmd switch-to-buffer (buffer :buffer "Switch To Buffer: " (buffer-name (other-buffer (current-buffer)))))
 194     (create-cmd save-buffers-kill-emacs ())
 195     (create-cmd kill-buffer (buffer :buffer "Kill buffer: " (buffer-name (current-buffer)) t))
 196     (create-cmd eval-expression (s :string "Eval: "))
 197     (create-cmd exchange-point-and-mark)
 198     (create-cmd set-mark-command)
 199     (create-cmd scroll-up)
 200     (create-cmd scroll-down)
 201     (create-cmd end-of-buffer)
 202     (create-cmd beginning-of-buffer)
 203     (create-cmd split-window-vertically)
 204     (create-cmd split-window-horizontally)
 205     (create-cmd other-window)
 206     (create-cmd switch-to-buffer-other-window (buffer :buffer "Switch to buffer in other window: " (buffer-name (other-buffer (current-buffer)))))
 207     (create-cmd delete-other-windows)
 208     (create-cmd keyboard-quit)
 209     (create-cmd kill-ring-save)
 210     (create-cmd kill-region (beg :region-beginning) (end :region-end))
 211     (create-cmd kill-line)
 212     (create-cmd yank)
 213     (create-cmd yank-pop)
 214     (create-cmd universal-argument)
 215     (create-cmd universal-argument-more (arg :raw-prefix))
 216     (create-cmd negative-argument (arg :raw-prefix))
 217     (create-cmd digit-argument (arg :raw-prefix))
 218     (create-cmd universal-argument-minus (arg :raw-prefix))
 219     (create-cmd universal-argument-other-key (arg :raw-prefix))))
 220
 221 #+(or cmu sbcl)
 222 (defun rl ()
 223   (asdf:oos 'asdf:load-op :lice))
 224
 225 ;;; The Deep Hack
 226
 227 ;;(muerte.init::lice-genesis)
 228
 229 ;; (defun foo ()
 230 ;;   (let (a)
 231 ;;     (labels ((do1 ()
 232 ;;                ;; do stuff and then
 233 ;;                (when <stuff>
 234 ;;                  (setf a <a struct>)))
 235 ;;           (do2 ()
 236 ;;                ;; do stuff and then call..
 237 ;;                (do1)))
 238 ;;       (do2)
 239 ;;       a)))
 240
 241 (provide :lice-0.1/main)