/[climacs]/climacs/core.lisp
ViewVC logotype

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sat Sep 2 21:43:56 2006 UTC (7 years, 7 months ago) by thenriksen
Branch: MAIN
Changes since 1.6: +1 -5 lines
Removed the Basic syntax and the `cache' slot in the `climacs-pane'
class. Fundamental syntax is now the default. This also required
moving some things around, but there has not been any functionality
changes.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
2
3 ;;; (c) copyright 2004-2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004-2005 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7 ;;; (c) copyright 2005 by
8 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 ;;; (c) copyright 2005 by
10 ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11 ;;; (c) copyright 2006 by
12 ;;; Troels Henriksen (athas@sigkill.dk)
13
14 (in-package :climacs-core)
15
16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
17 ;;;
18 ;;; Misc stuff
19
20 (defun display-string (string)
21 (with-output-to-string (result)
22 (loop for char across string
23 do (cond ((graphic-char-p char) (princ char result))
24 ((char= char #\Space) (princ char result))
25 (t (prin1 char result))))))
26
27 (defun object-equal (x y)
28 "Case insensitive equality that doesn't require characters"
29 (if (characterp x)
30 (and (characterp y) (char-equal x y))
31 (eql x y)))
32
33 (defun object= (x y)
34 "Case sensitive equality that doesn't require characters"
35 (if (characterp x)
36 (and (characterp y) (char= x y))
37 (eql x y)))
38
39 (defun no-upper-p (string)
40 "Does STRING contain no uppercase characters"
41 (notany #'upper-case-p string))
42
43 (defun case-relevant-test (string)
44 "Returns a test function based on the search-string STRING.
45 If STRING contains no uppercase characters the test is case-insensitive,
46 otherwise it is case-sensitive."
47 (if (no-upper-p string)
48 #'object-equal
49 #'object=))
50
51 (defun possibly-fill-line ()
52 (let* ((pane (current-window))
53 (buffer (buffer pane)))
54 (when (auto-fill-mode pane)
55 (let* ((fill-column (auto-fill-column pane))
56 (point (point pane))
57 (offset (offset point))
58 (tab-width (tab-space-count (stream-default-view pane)))
59 (syntax (syntax buffer)))
60 (when (>= (buffer-display-column buffer offset tab-width)
61 (1- fill-column))
62 (fill-line point
63 (lambda (mark)
64 (syntax-line-indentation mark tab-width syntax))
65 fill-column
66 tab-width
67 (syntax buffer)))))))
68
69 (defun insert-character (char)
70 (let* ((window (current-window))
71 (point (point window)))
72 (unless (constituentp char)
73 (possibly-expand-abbrev point))
74 (when (whitespacep (syntax (buffer window)) char)
75 (possibly-fill-line))
76 (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
77 (progn
78 (delete-range point)
79 (insert-object point char))
80 (insert-object point char))))
81
82 (defun back-to-indentation (mark syntax)
83 (beginning-of-line mark)
84 (loop until (end-of-line-p mark)
85 while (whitespacep syntax (object-after mark))
86 do (forward-object mark)))
87
88 (defun delete-horizontal-space (mark syntax &optional (backward-only-p nil))
89 (let ((mark2 (clone-mark mark)))
90 (loop until (beginning-of-line-p mark)
91 while (whitespacep syntax (object-before mark))
92 do (backward-object mark))
93 (unless backward-only-p
94 (loop until (end-of-line-p mark2)
95 while (whitespacep syntax (object-after mark2))
96 do (forward-object mark2)))
97 (delete-region mark mark2)))
98
99 (defun goto-position (mark pos)
100 (setf (offset mark) pos))
101
102 (defun goto-line (mark line-number)
103 (loop with m = (clone-mark (low-mark (buffer mark))
104 :right)
105 initially (beginning-of-buffer m)
106 do (end-of-line m)
107 until (end-of-buffer-p m)
108 repeat (1- line-number)
109 do (incf (offset m))
110 (end-of-line m)
111 finally (beginning-of-line m)
112 (setf (offset mark) (offset m))))
113
114 (defun indent-current-line (pane point)
115 (let* ((buffer (buffer pane))
116 (view (stream-default-view pane))
117 (tab-space-count (tab-space-count view))
118 (indentation (syntax-line-indentation point
119 tab-space-count
120 (syntax buffer))))
121 (indent-line point indentation (and (indent-tabs-mode buffer)
122 tab-space-count))))
123
124 (defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
125 (cond ((> count 0)
126 (loop while (and (not (end-of-buffer-p mark))
127 (whitespacep syntax (object-after mark)))
128 do (forward-object mark)))
129 ((< count 0)
130 (setf count (- count))
131 (loop repeat count do (backward-expression mark syntax))))
132 (unless (or (beginning-of-buffer-p mark)
133 (whitespacep syntax (object-before mark)))
134 (insert-object mark #\Space))
135 (insert-object mark open)
136 (let ((here (clone-mark mark)))
137 (loop repeat count
138 do (forward-expression here syntax))
139 (insert-object here close)
140 (unless (or (end-of-buffer-p here)
141 (whitespacep syntax (object-after here)))
142 (insert-object here #\Space))))
143
144 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
145 ;;;
146 ;;; Character case
147
148 (defun downcase-word (mark syntax &optional (n 1))
149 "Convert the next N words to lowercase, leaving mark after the last word."
150 (loop repeat n
151 do (forward-to-word-boundary mark syntax)
152 (let ((offset (offset mark)))
153 (forward-word mark syntax 1 nil)
154 (downcase-region offset mark))))
155
156 (defun upcase-word (mark syntax &optional (n 1))
157 "Convert the next N words to uppercase, leaving mark after the last word."
158 (loop repeat n
159 do (forward-to-word-boundary mark syntax)
160 (let ((offset (offset mark)))
161 (forward-word mark syntax 1 nil)
162 (upcase-region offset mark))))
163
164 (defun capitalize-word (mark syntax &optional (n 1))
165 "Capitalize the next N words, leaving mark after the last word."
166 (loop repeat n
167 do (forward-to-word-boundary mark syntax)
168 (let ((offset (offset mark)))
169 (forward-word mark syntax 1 nil)
170 (capitalize-region offset mark))))
171
172 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
173 ;;;
174 ;;; Indentation
175
176 (defun indent-region (pane mark1 mark2)
177 "Indent all lines in the region delimited by `mark1' and `mark2'
178 according to the rules of the active syntax in `pane'."
179 (let* ((buffer (buffer pane))
180 (view (clim:stream-default-view pane))
181 (tab-space-count (tab-space-count view))
182 (tab-width (and (indent-tabs-mode buffer)
183 tab-space-count))
184 (syntax (syntax buffer)))
185 (do-buffer-region-lines (line mark1 mark2)
186 (let ((indentation (syntax-line-indentation
187 line
188 tab-space-count
189 syntax)))
190 (indent-line line indentation tab-width))
191 ;; We need to update the syntax every time we perform an
192 ;; indentation, so that subsequent indentations will be
193 ;; correctly indented (this matters in list forms). FIXME: This
194 ;; should probably happen automatically.
195 (update-syntax buffer syntax))))
196
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
198 ;;;
199 ;;; Auto fill
200
201 (defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax
202 &optional (compress-whitespaces t))
203 "Breaks the contents of line pointed to by MARK up to MARK into
204 multiple lines such that none of them is longer than FILL-COLUMN. If
205 COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the
206 decision is made to break the line at a point. For now, the
207 compression means just the deletion of trailing whitespaces."
208 (let ((begin-mark (clone-mark mark)))
209 (beginning-of-line begin-mark)
210 (loop with column = 0
211 with line-beginning-offset = (offset begin-mark)
212 with walking-mark = (clone-mark begin-mark)
213 while (mark< walking-mark mark)
214 as object = (object-after walking-mark)
215 do (case object
216 (#\Space
217 (setf (offset begin-mark) (offset walking-mark))
218 (incf column))
219 (#\Tab
220 (setf (offset begin-mark) (offset walking-mark))
221 (incf column (- tab-width (mod column tab-width))))
222 (t
223 (incf column)))
224 (when (and (>= column fill-column)
225 (/= (offset begin-mark) line-beginning-offset))
226 (when compress-whitespaces
227 (let ((offset (buffer-search-backward
228 (buffer begin-mark)
229 (offset begin-mark)
230 #(nil)
231 :test #'(lambda (o1 o2)
232 (declare (ignore o2))
233 (not (whitespacep syntax o1))))))
234 (when offset
235 (delete-region begin-mark (1+ offset)))))
236 (insert-object begin-mark #\Newline)
237 (incf (offset begin-mark))
238 (let ((indentation
239 (funcall syntax-line-indentation-function begin-mark)))
240 (indent-line begin-mark indentation tab-width))
241 (beginning-of-line begin-mark)
242 (setf line-beginning-offset (offset begin-mark))
243 (setf (offset walking-mark) (offset begin-mark))
244 (setf column 0))
245 (incf (offset walking-mark)))))
246
247 (defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax
248 &optional (compress-whitespaces t))
249 "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be
250 mark<= `mark2.'"
251 (let* ((buffer (buffer mark1)))
252 (do-buffer-region (object offset buffer
253 (offset mark1) (offset mark2))
254 (when (eql object #\Newline)
255 (setf object #\Space)))
256 (when (>= (buffer-display-column buffer (offset mark2) tab-width)
257 (1- fill-column))
258 (fill-line mark2
259 syntax-line-indentation-function
260 fill-column
261 tab-width
262 compress-whitespaces
263 syntax))))
264
265 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
266 ;;;
267 ;;; Indentation
268
269 (defgeneric indent-line (mark indentation tab-width)
270 (:documentation "Indent the line containing mark with indentation
271 spaces. Use tabs and spaces if tab-width is not nil, otherwise use
272 spaces only."))
273
274 (defun indent-line* (mark indentation tab-width left)
275 (let ((mark2 (clone-mark mark)))
276 (beginning-of-line mark2)
277 (loop until (end-of-buffer-p mark2)
278 as object = (object-after mark2)
279 while (or (eql object #\Space) (eql object #\Tab))
280 do (delete-range mark2 1))
281 (loop until (zerop indentation)
282 do (cond ((and tab-width (>= indentation tab-width))
283 (insert-object mark2 #\Tab)
284 (when left ; spaces must follow tabs
285 (forward-object mark2))
286 (decf indentation tab-width))
287 (t
288 (insert-object mark2 #\Space)
289 (decf indentation))))))
290
291 (defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
292 (indent-line* mark indentation tab-width t))
293
294 (defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
295 (indent-line* mark indentation tab-width nil))
296
297 (defun delete-indentation (mark)
298 (beginning-of-line mark)
299 (unless (beginning-of-buffer-p mark)
300 (delete-range mark -1)
301 (loop until (end-of-buffer-p mark)
302 while (buffer-whitespacep (object-after mark))
303 do (delete-range mark 1))
304 (loop until (beginning-of-buffer-p mark)
305 while (buffer-whitespacep (object-before mark))
306 do (delete-range mark -1))
307 (when (and (not (beginning-of-buffer-p mark))
308 (constituentp (object-before mark)))
309 (insert-object mark #\Space))))
310
311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
312 ;;;
313 ;;; Syntax handling
314
315 (defgeneric set-syntax (buffer syntax))
316
317 (defmethod set-syntax ((buffer climacs-buffer) (syntax syntax))
318 (setf (syntax buffer) syntax))
319
320 ;;FIXME - what should this specialise on?
321 (defmethod set-syntax ((buffer climacs-buffer) syntax)
322 (set-syntax buffer (make-instance syntax :buffer buffer)))
323
324 (defmethod set-syntax ((buffer climacs-buffer) (syntax string))
325 (let ((syntax-class (syntax-from-name syntax)))
326 (cond (syntax-class
327 (set-syntax buffer (make-instance syntax-class
328 :buffer buffer)))
329 (t
330 (beep)
331 (display-message "No such syntax: ~A." syntax)))))
332
333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
334 ;;;
335 ;;; Buffer handling
336
337 (defmethod make-new-buffer ((application-frame climacs))
338 (let ((buffer (make-instance 'climacs-buffer)))
339 (push buffer (buffers application-frame))
340 buffer))
341
342 (defun make-new-named-buffer (&optional name)
343 (let ((buffer (make-new-buffer *application-frame*)))
344 (when name (setf (name buffer) name))
345 buffer))
346
347 (defgeneric erase-buffer (buffer))
348
349 (defmethod erase-buffer ((buffer string))
350 (let ((b (find buffer (buffers *application-frame*)
351 :key #'name :test #'string=)))
352 (when b (erase-buffer b))))
353
354 (defmethod erase-buffer ((buffer climacs-buffer))
355 (let* ((point (point buffer))
356 (mark (clone-mark point)))
357 (beginning-of-buffer mark)
358 (end-of-buffer point)
359 (delete-region mark point)))
360
361 (define-presentation-method present (object (type buffer)
362 stream
363 (view textual-view)
364 &key acceptably for-context-type)
365 (declare (ignore acceptably for-context-type))
366 (princ (name object) stream))
367
368 (define-presentation-method accept
369 ((type buffer) stream (view textual-view) &key (default nil defaultp)
370 (default-type type))
371 (multiple-value-bind (object success string)
372 (complete-input stream
373 (lambda (so-far action)
374 (complete-from-possibilities
375 so-far (buffers *application-frame*) '() :action action
376 :name-key #'name
377 :value-key #'identity))
378 :partial-completers '(#\Space)
379 :allow-any-input t)
380 (cond (success
381 (values object type))
382 ((and (zerop (length string)) defaultp)
383 (values default default-type))
384 (t (values string 'string)))))
385
386 (defgeneric switch-to-buffer (buffer))
387
388 (defmethod switch-to-buffer ((buffer climacs-buffer))
389 (let* ((buffers (buffers *application-frame*))
390 (position (position buffer buffers))
391 (pane (current-window)))
392 (when position
393 (setf buffers (delete buffer buffers)))
394 (push buffer (buffers *application-frame*))
395 (setf (offset (point (buffer pane))) (offset (point pane)))
396 (setf (buffer pane) buffer)
397 (full-redisplay pane)
398 buffer))
399
400 (defmethod switch-to-buffer ((name string))
401 (let ((buffer (find name (buffers *application-frame*)
402 :key #'name :test #'string=)))
403 (switch-to-buffer (or buffer
404 (make-new-named-buffer name)))))
405
406 ;;placeholder
407 (defmethod switch-to-buffer ((symbol (eql 'nil)))
408 (let ((default (second (buffers *application-frame*))))
409 (when default
410 (switch-to-buffer default))))
411
412 ;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
413 ;; ;;; 2005-10-31.
414 ;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
415 ;; (call-next-method)
416 ;; (note-pane-syntax-changed pane (syntax buffer)))
417
418 (defgeneric kill-buffer (buffer))
419
420 (defmethod kill-buffer ((buffer climacs-buffer))
421 (with-slots (buffers) *application-frame*
422 (when (and (needs-saving buffer)
423 (handler-case (accept 'boolean :prompt "Save buffer first?")
424 (error () (progn (beep)
425 (display-message "Invalid answer")
426 (return-from kill-buffer nil)))))
427 (save-buffer buffer *application-frame*))
428 (setf buffers (remove buffer buffers))
429 ;; Always need one buffer.
430 (when (null buffers)
431 (make-new-named-buffer "*scratch*"))
432 (setf (buffer (current-window)) (car buffers))
433 (full-redisplay (current-window))
434 (buffer (current-window))))
435
436 (defmethod kill-buffer ((name string))
437 (let ((buffer (find name (buffers *application-frame*)
438 :key #'name :test #'string=)))
439 (when buffer (kill-buffer buffer))))
440
441 (defmethod kill-buffer ((symbol (eql 'nil)))
442 (kill-buffer (buffer (current-window))))
443
444 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
445 ;;;
446 ;;; File handling
447
448 (defun filepath-filename (pathname)
449 (if (null (pathname-type pathname))
450 (pathname-name pathname)
451 (concatenate 'string (pathname-name pathname)
452 "." (pathname-type pathname))))
453
454 (defun syntax-class-name-for-filepath (filepath)
455 (or (climacs-syntax::syntax-description-class-name
456 (find (or (pathname-type filepath)
457 (pathname-name filepath))
458 climacs-syntax::*syntaxes*
459 :test (lambda (x y)
460 (member x y :test #'string-equal))
461 :key #'climacs-syntax::syntax-description-pathname-types))
462 *default-syntax*))
463
464 (defun evaluate-attributes (buffer options)
465 "Evaluate the attributes `options' and modify `buffer' as
466 appropriate. `Options' should be an alist mapping option names
467 to their values."
468 ;; First, check whether we need to change the syntax (via the SYNTAX
469 ;; option). MODE is an alias for SYNTAX for compatibility with
470 ;; Emacs. If there is more than one option with one of these names,
471 ;; only the first will be acted upon.
472 (let ((specified-syntax
473 (syntax-from-name
474 (second (find-if #'(lambda (name)
475 (or (string-equal name "SYNTAX")
476 (string-equal name "MODE")))
477 options
478 :key #'first)))))
479 (when (and specified-syntax
480 (not (eq (class-of (syntax buffer))
481 specified-syntax)))
482 (setf (syntax buffer)
483 (make-instance specified-syntax
484 :buffer buffer))))
485 ;; Now we iterate through the options (discarding SYNTAX and MODE
486 ;; options).
487 (loop for (name value) in options
488 unless (or (string-equal name "SYNTAX")
489 (string-equal name "MODE"))
490 do (eval-option (syntax buffer) name value)))
491
492 (defun split-attribute (string char)
493 (let (pairs)
494 (loop with start = 0
495 for ch across string
496 for i from 0
497 when (eql ch char)
498 do (push (string-trim '(#\Space #\Tab) (subseq string start i))
499 pairs)
500 (setf start (1+ i))
501 finally (unless (>= start i)
502 (push (string-trim '(#\Space #\Tab) (subseq string start))
503 pairs)))
504 (nreverse pairs)))
505
506 (defun split-attribute-line (line)
507 (when line
508 (mapcar (lambda (pair) (split-attribute pair #\:))
509 (split-attribute line #\;))))
510
511 (defun find-attribute-line-position (buffer)
512 (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
513 ;; skip the leading whitespace
514 (loop until (end-of-buffer-p scan)
515 until (not (whitespacep (syntax buffer) (object-after scan)))
516 do (forward-object scan))
517 ;; stop looking if we're already 1,000 objects into the buffer
518 (unless (> (offset scan) 1000)
519 (let ((start-found
520 (loop with newlines = 0
521 when (end-of-buffer-p scan)
522 do (return nil)
523 when (eql (object-after scan) #\Newline)
524 do (incf newlines)
525 when (> newlines 1)
526 do (return nil)
527 until (looking-at scan "-*-")
528 do (forward-object scan)
529 finally (return t))))
530 (when start-found
531 (let* ((end-scan (clone-mark scan))
532 (end-found
533 (loop when (end-of-buffer-p end-scan)
534 do (return nil)
535 when (eql (object-after end-scan) #\Newline)
536 do (return nil)
537 do (forward-object end-scan)
538 until (looking-at end-scan "-*-")
539 finally (return t))))
540 (when end-found
541 (values scan
542 (progn (forward-object end-scan 3)
543 end-scan)))))))))
544
545 (defun get-attribute-line (buffer)
546 (multiple-value-bind (start-mark end-mark)
547 (find-attribute-line-position buffer)
548 (when (and start-mark end-mark)
549 (let ((line (buffer-substring buffer
550 (offset start-mark)
551 (offset end-mark))))
552 (when (>= (length line) 6)
553 (let ((end (search "-*-" line :from-end t :start2 3)))
554 (when end
555 (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))
556
557 (defun replace-attribute-line (buffer new-attribute-line)
558 (let ((full-attribute-line (concatenate 'string
559 "-*- "
560 new-attribute-line
561 "-*-")))
562 (multiple-value-bind (start-mark end-mark)
563 (find-attribute-line-position buffer)
564 (cond ((not (null end-mark))
565 ;; We have an existing attribute line.
566 (delete-region start-mark end-mark)
567 (let ((new-line-start (clone-mark start-mark :left)))
568 (insert-sequence start-mark full-attribute-line)
569 (comment-region (syntax buffer)
570 new-line-start
571 start-mark)))
572 (t
573 ;; Create a new attribute line at beginning of buffer.
574 (let* ((mark1 (beginning-of-buffer (clone-mark (point buffer) :left)))
575 (mark2 (clone-mark mark1 :right)))
576 (insert-sequence mark2 full-attribute-line)
577 (insert-object mark2 #\Newline)
578 (comment-region (syntax buffer)
579 mark1
580 mark2)))))))
581
582 (defun update-attribute-line (buffer)
583 (replace-attribute-line buffer
584 (make-attribute-line (syntax buffer))))
585
586 (defun evaluate-attribute-line (buffer)
587 (evaluate-attributes
588 buffer
589 (split-attribute-line (get-attribute-line buffer))))
590
591 ;; Adapted from cl-fad/PCL
592 (defun directory-pathname-p (pathspec)
593 "Returns NIL if PATHSPEC does not designate a directory."
594 (let ((name (pathname-name pathspec))
595 (type (pathname-type pathspec)))
596 (and (or (null name) (eql name :unspecific))
597 (or (null type) (eql type :unspecific)))))
598
599 (defun find-file-impl (filepath &optional readonlyp)
600 (cond ((null filepath)
601 (display-message "No file name given.")
602 (beep))
603 ((directory-pathname-p filepath)
604 (display-message "~A is a directory name." filepath)
605 (beep))
606 (t
607 (flet ((usable-pathname (pathname)
608 (if (probe-file pathname)
609 (truename pathname)
610 pathname)))
611 (let ((existing-buffer (find filepath (buffers *application-frame*)
612 :key #'filepath
613 :test #'(lambda (fp1 fp2)
614 (and fp1 fp2
615 (equal (usable-pathname fp1)
616 (usable-pathname fp2)))))))
617 (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
618 (switch-to-buffer existing-buffer)
619 (progn
620 (when readonlyp
621 (unless (probe-file filepath)
622 (beep)
623 (display-message "No such file: ~A" filepath)
624 (return-from find-file-impl nil)))
625 (let ((buffer (if (probe-file filepath)
626 (with-open-file (stream filepath :direction :input)
627 (make-buffer-from-stream stream *application-frame*))
628 (make-new-buffer *application-frame*)))
629 (pane (current-window)))
630 (setf (offset (point (buffer pane))) (offset (point pane))
631 (buffer (current-window)) buffer
632 (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
633 :buffer buffer)
634 (file-write-time buffer) (file-write-date filepath))
635 (evaluate-attribute-line buffer)
636 (setf (filepath buffer) filepath
637 (name buffer) (filepath-filename filepath)
638 (read-only-p buffer) readonlyp)
639 (beginning-of-buffer (point pane))
640 (update-syntax buffer (syntax buffer))
641 (clear-modify buffer)
642 buffer))))))))
643
644 (defmethod find-file (filepath (application-frame climacs))
645 (find-file-impl filepath nil))
646
647 (defmethod find-file-read-only (filepath (application-frame climacs))
648 (find-file-impl filepath t))
649
650 (defun directory-of-buffer (buffer)
651 "Extract the directory part of the filepath to the file in BUFFER.
652 If BUFFER does not have a filepath, the path to the user's home
653 directory will be returned."
654 (make-pathname
655 :directory
656 (pathname-directory
657 (or (filepath buffer)
658 (user-homedir-pathname)))))
659
660 (defmethod set-visited-filename (filepath buffer (application-frame climacs))
661 (setf (filepath buffer) filepath
662 (file-saved-p buffer) nil
663 (file-write-time buffer) nil
664 (name buffer) (filepath-filename filepath)
665 (needs-saving buffer) t))
666
667 (defun check-file-times (buffer filepath question answer)
668 "Return NIL if filepath newer than buffer and user doesn't want
669 to overwrite."
670 (let ((f-w-d (file-write-date filepath))
671 (f-w-t (file-write-time buffer)))
672 (if (and f-w-d f-w-t (> f-w-d f-w-t))
673 (if (accept 'boolean
674 :prompt (format nil "File has changed on disk. ~a anyway?"
675 question))
676 t
677 (progn (display-message "~a not ~a" filepath answer)
678 nil))
679 t)))
680
681 (defmethod frame-exit :around ((frame climacs) #-mcclim &key)
682 (loop for buffer in (buffers frame)
683 when (and (needs-saving buffer)
684 (filepath buffer)
685 (handler-case (accept 'boolean
686 :prompt (format nil "Save buffer: ~a ?" (name buffer)))
687 (error () (progn (beep)
688 (display-message "Invalid answer")
689 (return-from frame-exit nil)))))
690 do (save-buffer buffer frame))
691 (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
692 (buffers frame))
693 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
694 (error () (progn (beep)
695 (display-message "Invalid answer")
696 (return-from frame-exit nil)))))
697 (call-next-method)))

  ViewVC Help
Powered by ViewVC 1.1.5