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