Commit ed18b495 authored by Troels Henriksen's avatar Troels Henriksen

Changed Climacs to use the ESA-IO and ESA-BUFFER functionality instead

of duplicating essentially the same code across multiple
projects. This is rather invasive as some of the ESA functions have a
subtly different signature.
parent 32a7f325
......@@ -297,8 +297,6 @@ spaces. `Mark' will be moved to after any spaces inserted."
;;;
;;; Named objects
(defgeneric name (obj))
(defclass name-mixin ()
((name :initarg :name :accessor name)))
......
......@@ -63,7 +63,6 @@
:depends-on ("packages" "buffer" "Persistent"))
(:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring"))
(:file "io" :depends-on ("packages" "buffer"))
(:file "abbrev" :depends-on ("packages" "buffer" "base"))
(:file "syntax" :depends-on ("packages" "buffer" "base"))
(:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion"))
......@@ -86,14 +85,16 @@
"pane"))
(:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane"
"window-commands" "gui"))
(:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands"
"misc-commands" "window-commands" "file-commands" "core"))
(:file "lisp-syntax-swine" :depends-on ("lisp-syntax"))
(:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands"
"editing-commands" "misc-commands"))
#.(if (find-swank)
'(:file "lisp-syntax-swank" :depends-on ("lisp-syntax"))
(values))
(:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane"
"kill-ring" "io" "text-syntax"
"kill-ring" "text-syntax"
"abbrev" "editing" "motion"))
(:file "io" :depends-on ("packages" "gui"))
(:file "core" :depends-on ("gui"))
(:file "climacs" :depends-on ("gui" "core"))
;; (:file "buffer-commands" :depends-on ("gui"))
......
......@@ -336,10 +336,14 @@ spaces only."))
;;;
;;; Buffer handling
(defun make-buffer (&optional name)
(defmethod make-new-buffer ((application-frame climacs))
(let ((buffer (make-instance 'climacs-buffer)))
(push buffer (buffers application-frame))
buffer))
(defun make-new-named-buffer (&optional name)
(let ((buffer (make-new-buffer *application-frame*)))
(when name (setf (name buffer) name))
(push buffer (buffers *application-frame*))
buffer))
(defgeneric erase-buffer (buffer))
......@@ -399,7 +403,7 @@ spaces only."))
(let ((buffer (find name (buffers *application-frame*)
:key #'name :test #'string=)))
(switch-to-buffer (or buffer
(make-buffer name)))))
(make-new-named-buffer name)))))
;;placeholder
(defmethod switch-to-buffer ((symbol (eql 'nil)))
......@@ -422,11 +426,11 @@ spaces only."))
(error () (progn (beep)
(display-message "Invalid answer")
(return-from kill-buffer nil)))))
(save-buffer buffer))
(save-buffer buffer *application-frame*))
(setf buffers (remove buffer buffers))
;; Always need one buffer.
(when (null buffers)
(make-buffer "*scratch*"))
(make-new-named-buffer "*scratch*"))
(setf (buffer (current-window)) (car buffers))
(full-redisplay (current-window))
(buffer (current-window))))
......@@ -594,7 +598,7 @@ spaces only."))
(and (or (null name) (eql name :unspecific))
(or (null type) (eql type :unspecific)))))
(defun find-file (filepath &optional readonlyp)
(defun find-file-impl (filepath &optional readonlyp)
(cond ((null filepath)
(display-message "No file name given.")
(beep))
......@@ -603,9 +607,9 @@ spaces only."))
(beep))
(t
(flet ((usable-pathname (pathname)
(if (probe-file pathname)
(truename pathname)
pathname)))
(if (probe-file pathname)
(truename pathname)
pathname)))
(let ((existing-buffer (find filepath (buffers *application-frame*)
:key #'filepath
:test #'(lambda (fp1 fp2)
......@@ -619,36 +623,36 @@ spaces only."))
(unless (probe-file filepath)
(beep)
(display-message "No such file: ~A" filepath)
(return-from find-file nil)))
(let ((buffer (make-buffer))
(return-from find-file-impl nil)))
(let ((buffer (if (probe-file filepath)
(with-open-file (stream filepath :direction :input)
(make-buffer-from-stream stream *application-frame*))
(make-new-buffer *application-frame*)))
(pane (current-window)))
;; Clear the pane's cache; otherwise residue from the
;; previously displayed buffer may under certain
;; circumstances be displayed.
(clear-cache pane)
(setf (syntax buffer) nil)
(setf (offset (point (buffer pane))) (offset (point pane)))
(setf (buffer (current-window)) buffer)
(setf (syntax buffer)
(make-instance (syntax-class-name-for-filepath filepath)
:buffer buffer))
;; Don't want to create the file if it doesn't exist.
(when (probe-file filepath)
(with-open-file (stream filepath :direction :input)
(input-from-stream stream buffer 0))
(setf (file-write-time buffer) (file-write-date filepath))
;; A file! That means we may have a local options
;; line to parse.
(evaluate-attribute-line buffer))
(setf (offset (point (buffer pane))) (offset (point pane))
(buffer (current-window)) buffer
(syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
:buffer buffer)
(file-write-time buffer) (file-write-date filepath))
(evaluate-attribute-line buffer)
(setf (filepath buffer) filepath
(name buffer) (filepath-filename filepath)
(needs-saving buffer) nil
(read-only-p buffer) readonlyp)
(beginning-of-buffer (point pane))
(update-syntax buffer (syntax buffer))
(clear-modify buffer)
buffer))))))))
(defmethod find-file (filepath (application-frame climacs))
(find-file-impl filepath nil))
(defmethod find-file-read-only (filepath (application-frame climacs))
(find-file-impl filepath t))
(defun directory-of-buffer (buffer)
"Extract the directory part of the filepath to the file in BUFFER.
If BUFFER does not have a filepath, the path to the user's home
......@@ -659,34 +663,13 @@ spaces only."))
(or (filepath buffer)
(user-homedir-pathname)))))
(defun set-visited-file-name (filename buffer)
(setf (filepath buffer) filename
(defmethod set-visited-filename (filepath buffer (application-frame climacs))
(setf (filepath buffer) filepath
(file-saved-p buffer) nil
(file-write-time buffer) nil
(name buffer) (filepath-filename filename)
(name buffer) (filepath-filename filepath)
(needs-saving buffer) t))
(defun extract-version-number (pathname)
"Extracts the emacs-style version-number from a pathname."
(let* ((type (pathname-type pathname))
(length (length type)))
(when (and (> length 2) (char= (char type (1- length)) #\~))
(let ((tilde (position #\~ type :from-end t :end (- length 2))))
(when tilde
(parse-integer type :start (1+ tilde) :junk-allowed t))))))
(defun version-number (pathname)
"Return the number of the highest versioned backup of PATHNAME
or 0 if there is no versioned backup. Looks for name.type~X~,
returns highest X."
(let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname))
(possibilities (directory wildpath)))
(loop for possibility in possibilities
for version = (extract-version-number possibility)
if (numberp version)
maximize version into max
finally (return max))))
(defun check-file-times (buffer filepath question answer)
"Return NIL if filepath newer than buffer and user doesn't want
to overwrite."
......@@ -701,32 +684,6 @@ to overwrite."
nil))
t)))
(defun save-buffer (buffer)
(let ((filepath (or (filepath buffer)
(accept 'pathname :prompt "Save Buffer to File"))))
(cond
((directory-pathname-p filepath)
(display-message "~A is a directory." filepath)
(beep))
(t
(unless (check-file-times buffer filepath "Overwrite" "written")
(return-from save-buffer))
(when (and (probe-file filepath) (not (file-saved-p buffer)))
(let ((backup-name (pathname-name filepath))
(backup-type (format nil "~A~~~D~~"
(pathname-type filepath)
(1+ (version-number filepath)))))
(rename-file filepath (make-pathname :name backup-name
:type backup-type)))
(setf (file-saved-p buffer) t))
(with-open-file (stream filepath :direction :output :if-exists :supersede)
(output-to-stream stream buffer 0 (size buffer)))
(setf (filepath buffer) filepath
(file-write-time buffer) (file-write-date filepath)
(name buffer) (filepath-filename filepath))
(display-message "Wrote: ~a" filepath)
(setf (needs-saving buffer) nil)))))
(defmethod frame-exit :around ((frame climacs) #-mcclim &key)
(loop for buffer in (buffers frame)
when (and (needs-saving buffer)
......
......@@ -24,7 +24,9 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; File (and buffer) commands for the Climacs editor.
;;; File (and buffer) commands for the Climacs editor. Note that many
;;; basic commands (such as Find File) are defined in ESA and made
;;; available to Climacs via the ESA-IO-TABLE command table.
(in-package :climacs-commands)
......@@ -151,52 +153,6 @@ appropriate for the syntax of the buffer."
(update-attribute-line (buffer (current-window)))
(evaluate-attribute-line (buffer (current-window))))
(define-command (com-find-file :name t :command-table buffer-table)
((filepath 'pathname
:prompt "Find File"
:default (directory-of-buffer (buffer (current-window)))
:default-type 'pathname
:insert-default t))
"Prompt for a filename then edit that file.
If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file."
(find-file filepath))
(set-key `(com-find-file ,*unsupplied-argument-marker*)
'buffer-table
'((#\x :control) (#\f :control)))
(define-command (com-find-file-read-only :name t :command-table buffer-table)
((filepath 'pathname :Prompt "Find file read only"
:default (directory-of-buffer (buffer (current-window)))
:default-type 'pathname
:insert-default t))
"Prompt for a filename then open that file readonly.
If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error."
(find-file filepath t))
(set-key `(com-find-file-read-only ,*unsupplied-argument-marker*)
'buffer-table
'((#\x :control) (#\r :control)))
(define-command (com-read-only :name t :command-table buffer-table) ()
"Toggle the readonly status of the current buffer.
When a buffer is readonly, attempts to change the contents of the buffer signal an error."
(let ((buffer (buffer (current-window))))
(setf (read-only-p buffer) (not (read-only-p buffer)))))
(set-key 'com-read-only
'buffer-table
'((#\x :control) (#\q :control)))
(define-command (com-set-visited-file-name :name t :command-table buffer-table)
((filename 'pathname :prompt "New file name"
:default (directory-of-buffer (buffer (current-window)))
:default-type 'pathname
:insert-default t))
"Prompt for a new filename for the current buffer.
The next time the buffer is saved it will be saved to a file with that filename."
(set-visited-file-name filename (buffer (current-window))))
(define-command (com-insert-file :name t :command-table buffer-table)
((filename 'pathname :prompt "Insert File"
:default (directory-of-buffer (buffer (current-window)))
......@@ -243,42 +199,6 @@ Signals an error if the file does not exist."
(display-message "No file ~A" filepath)
(beep))))))
(define-command (com-save-buffer :name t :command-table buffer-table) ()
"Write the contents of the buffer to a file.
If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename."
(let ((buffer (buffer (current-window))))
(if (or (null (filepath buffer))
(needs-saving buffer))
(save-buffer buffer)
(display-message "No changes need to be saved from ~a" (name buffer)))))
(set-key 'com-save-buffer
'buffer-table
'((#\x :control) (#\s :control)))
(define-command (com-write-buffer :name t :command-table buffer-table)
((filepath 'pathname :prompt "Write Buffer to File"
:default (directory-of-buffer (buffer (current-window)))
:default-type 'pathname
:insert-default t))
"Prompt for a filename and write the current buffer to it.
Changes the file visted by the buffer to the given file."
(let ((buffer (buffer (current-window))))
(cond
((directory-pathname-p filepath)
(display-message "~A is a directory name." filepath))
(t
(with-open-file (stream filepath :direction :output :if-exists :supersede)
(output-to-stream stream buffer 0 (size buffer)))
(setf (filepath buffer) filepath
(name buffer) (filepath-filename filepath)
(needs-saving buffer) nil)
(display-message "Wrote: ~a" (filepath buffer))))))
(set-key `(com-write-buffer ,*unsupplied-argument-marker*)
'buffer-table
'((#\x :control) (#\w :control)))
(defun load-file (file-name)
(cond ((directory-pathname-p file-name)
(display-message "~A is a directory name." file-name)
......@@ -334,7 +254,7 @@ If the buffer needs saving, will prompt you to do so before killing it. Uses the
'((#\x :control) (#\k)))
(define-command (com-toggle-read-only :name t :command-table base-table)
((buffer 'buffer :default (current-buffer)))
((buffer 'buffer :default (current-buffer *application-frame*)))
(setf (read-only-p buffer) (not (read-only-p buffer))))
(define-presentation-to-command-translator toggle-read-only
......@@ -344,7 +264,7 @@ If the buffer needs saving, will prompt you to do so before killing it. Uses the
(list object))
(define-command (com-toggle-modified :name t :command-table base-table)
((buffer 'buffer :default (current-buffer)))
((buffer 'buffer :default (current-buffer *application-frame*)))
(setf (needs-saving buffer) (not (needs-saving buffer))))
(define-presentation-to-command-translator toggle-modified
......
......@@ -133,6 +133,7 @@
(kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring))
(:command-table (global-climacs-table
:inherit-from (global-esa-table
esa-io-table
keyboard-macro-table
climacs-help-table
base-table
......@@ -201,9 +202,9 @@
"Return the current panes point."
(point (current-window)))
(defun current-buffer ()
(defmethod current-buffer ((application-frame climacs))
"Return the current buffer."
(buffer (current-window)))
(buffer (car (windows application-frame))))
(define-presentation-type read-only ())
(define-presentation-method highlight-presentation
......
;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*-
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh@labri.fr)
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......@@ -20,20 +22,23 @@
;;; Input/Output of buffers to and from streams.
(in-package :climacs-base)
(in-package :climacs-core)
(defmethod save-buffer-to-stream ((buffer climacs-buffer) stream)
(let ((seq (buffer-sequence buffer 0 (size buffer))))
(write-sequence seq stream)))
(defun input-from-stream (stream buffer offset)
(loop with vec = (make-array 10000 :element-type 'character)
for count = (#+mcclim read-sequence #-mcclim cl:read-sequence
vec stream)
while (plusp count)
do (if (= count (length vec))
(insert-buffer-sequence buffer offset vec)
(insert-buffer-sequence buffer offset
(subseq vec 0 count)))
(incf offset count)))
(let* ((seq (make-string (file-length stream)))
(count (#+mcclim read-sequence #-mcclim cl:read-sequence
seq stream)))
(if (= count (length seq))
(insert-buffer-sequence buffer offset
(if (= count (length seq))
seq
(subseq seq 0 count))))))
(defun output-to-stream (stream buffer offset1 offset2)
(loop for offset from offset1 below offset2
when (characterp (buffer-object buffer offset))
do (write-char (buffer-object buffer offset) stream)))
(defmethod make-buffer-from-stream (stream (application-frame climacs))
(let* ((buffer (make-new-buffer application-frame)))
(input-from-stream stream buffer 0)
buffer))
......@@ -255,8 +255,8 @@ Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane."
(let* ((pane (current-window))
(point (point pane)))
(insert-object point #\Newline)
(update-syntax (current-buffer)
(syntax (current-buffer)))
(update-syntax (current-buffer *application-frame*)
(syntax (current-buffer *application-frame*)))
(indent-current-line pane point)))
(set-key 'com-newline-and-indent
......@@ -453,7 +453,7 @@ point at the beginning of the last line of the buffer."
:prompt "Name of syntax"))
"Prompts for a syntax to set for the current buffer.
Setting a syntax will cause the buffer to be reparsed using the new syntax."
(set-syntax (current-buffer) syntax))
(set-syntax (current-buffer *application-frame*) syntax))
;;;;;;;;;;;;;;;;;;;;
;; Kill ring commands
......
......@@ -76,7 +76,7 @@
(:documentation "An implementation of a kill ring."))
(defpackage :climacs-base
(:use :clim-lisp :climacs-buffer :climacs-kill-ring)
(:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer)
(:export #:as-offsets
#:do-buffer-region
#:do-buffer-region-lines
......@@ -91,7 +91,6 @@
#:just-n-spaces
#:buffer-whitespacep
#:buffer-region-case
#:input-from-stream #:output-to-stream
#:name-mixin #:name
#:buffer-looking-at #:looking-at
#:buffer-search-forward #:buffer-search-backward
......@@ -171,7 +170,7 @@
(defpackage :climacs-pane
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev
:climacs-syntax :flexichain :undo)
:climacs-syntax :flexichain :undo :esa-buffer :esa-io)
(:export #:climacs-buffer #:needs-saving
#:filepath #:file-saved-p #:file-write-time
#:read-only-p #:buffer-read-only
......@@ -316,7 +315,7 @@
(:use :clim-lisp :clim :climacs-buffer :climacs-base
:climacs-abbrev :climacs-syntax :climacs-motion
:climacs-kill-ring :climacs-pane :clim-extensions
:undo :esa :climacs-editing :climacs-motion)
:undo :esa :climacs-editing :climacs-motion :esa-buffer :esa-io)
;;(:import-from :lisp-string)
(:export #:climacs ; Frame.
......@@ -370,7 +369,7 @@
(defpackage :climacs-core
(:use :clim-lisp :climacs-base :climacs-buffer
:climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring
:climacs-editing :climacs-gui :clim :climacs-abbrev :esa)
:climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io)
(:export #:display-string
#:object-equal
#:object=
......@@ -397,7 +396,8 @@
#:set-syntax
#:switch-to-buffer
#:make-buffer
#:make-new-buffer
#:make-new-named-buffer
#:erase-buffer
#:kill-buffer
......@@ -405,11 +405,15 @@
#:update-attribute-line
#:evaluate-attribute-line
#:directory-pathname-p
#:find-file
#:find-file #:find-file-read-only
#:directory-of-buffer
#:set-visited-file-name
#:set-visited-filename
#:check-file-times
#:save-buffer)
#:save-buffer
#:input-from-stream
#:save-buffer-to-stream
#:make-buffer-from-stream)
(:documentation "Package for editor functionality that is
syntax-aware, but yet not specific to certain
syntaxes. Contains stuff like indentation, filling and other
......@@ -439,7 +443,7 @@
(defpackage :climacs-prolog-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane)
:climacs-syntax :flexichain :climacs-pane :climacs-core)
(:shadow #:atom #:close #:exp #:integer #:open #:variable))
(defpackage :climacs-cl-syntax
......
......@@ -237,11 +237,6 @@ is made to alter a buffer which has been set read only."))
(defparameter +climacs-textual-view+ (make-instance 'climacs-textual-view))
(defclass file-mixin ()
((filepath :initform nil :accessor filepath)
(file-saved-p :initform nil :accessor file-saved-p)
(file-write-time :initform nil :accessor file-write-time)))
;(defgeneric indent-tabs-mode (climacs-buffer))
(defclass extended-standard-buffer (read-only-mixin standard-buffer undo-mixin abbrev-mixin) ()
......@@ -250,7 +245,7 @@ is made to alter a buffer which has been set read only."))
(defclass extended-binseq2-buffer (read-only-mixin binseq2-buffer p-undo-mixin abbrev-mixin) ()
(:documentation "Extensions accessible via marks."))
(defclass climacs-buffer (delegating-buffer file-mixin name-mixin)
(defclass climacs-buffer (delegating-buffer esa-buffer-mixin)
((needs-saving :initform nil :accessor needs-saving)
(syntax :accessor syntax)
(point :initform nil :initarg :point :accessor point)
......
......@@ -44,7 +44,7 @@
(let ((buffer (make-instance 'prolog-buffer)))
(when (probe-file filepath)
(with-open-file (stream filepath :direction :input)
(input-from-stream stream buffer 0)))
(save-buffer-to-stream stream buffer)))
(setf (filepath buffer) filepath
(offset (low-mark buffer)) 0
(offset (high-mark buffer)) (size buffer))
......
......@@ -168,7 +168,7 @@ If found, leaves point before the word. If not, leaves point where it is."
(isearch-from-mark pane mark string forwardp))))
(define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) ()
(let ((syntax (syntax (current-buffer))))
(let ((syntax (syntax (current-buffer *application-frame*))))
(isearch-append-text #'(lambda (mark)
(forward-word mark syntax)))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment