4 #+cmu
(setf extensions
:*gc-notify-after
* (lambda (&rest r
))
5 extensions
:*gc-notify-before
* (lambda (&rest r
)))
7 (defun init-mode-line-format ()
8 (setf *default-mode-line-format
*
9 (list "--:" ;; fake it for hype
12 ;; FIXME: add read-only stuff
13 (if (buffer-modified-p buffer
)
15 (if (buffer-modified-p buffer
)
19 (format nil
"~12,,,a" (buffer-name buffer
)))
23 (major-mode-name (symbol-value (buffer-major-mode buffer
))))))))
26 "Run the lice environment."
29 (dformat +debug-v
+ "-- Start lice~%")
30 #+(or cmu sbcl
) (init-tty)
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
*)
57 (with-simple-restart (recursive-edit-top-level "Return to LiCE top level")
61 (with-simple-restart (recursive-edit-top-level "Return to LiCE top level")
64 #+(or cmu sbcl
) (shutdown-tty)
66 (dformat +debug-v
+ "-- End lice~%"))))
69 (defun init-commands ()
70 "Our special wikked hack."
71 (macrolet ((create-cmd (name &rest args
)
73 `(setf (gethash ',name
*commands
*)
77 :args
',(delete nil
(mapcar (lambda (a)
78 (when (listp a
) (second a
)))
82 (let ((,tmp
(list ,@(delete nil
(mapcar (lambda (a)
84 `(funcall (gethash ,(second a
) *command-arg-type-hash
*) ,@(cddr a
))))
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
103 :map
(make-hash-table)
104 :init-fn
(lambda ()))
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
)
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
)
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
)
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
)
153 (setf *mode-line-format
* (list "--:" ;; fake it for hype
156 ;; FIXME: add read-only stuff
157 (if (buffer-modified-p buffer
)
159 (if (buffer-modified-p buffer
)
163 (format nil
"~12,,,a" (buffer-name buffer
)))
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
))
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
)
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
))))
223 (asdf:oos
'asdf
:load-op
:lice
))
227 ;;(muerte.init::lice-genesis)
232 ;; ;; do stuff and then
234 ;; (setf a <a struct>)))
236 ;; ;; do stuff and then call..
241 (provide :lice-0.1
/main
)