[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Tue Jul 11 14:20:20 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv7651
Modified Files:
packages.lisp gui.lisp climacs.asd
Added Files:
climacs.lisp
Log Message:
Added new CLIMACS package and moved entry points to it.
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/09 18:44:50 1.103
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/11 14:20:20 1.104
@@ -4,6 +4,8 @@
;;; Robert Strandh (strandh at labri.fr)
;;; (c) copyright 2005 by
;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr)
+;;; (c) copyright 2006 by
+;;; Troels Henriksen (athas at sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
@@ -22,6 +24,8 @@
;;; Package definitions for the Climacs editor.
+(in-package :cl-user)
+
(defpackage :climacs-buffer
(:use :clim-lisp :flexichain :binseq)
(:export #:buffer #:standard-buffer
@@ -318,33 +322,41 @@
:climacs-kill-ring :climacs-pane :clim-extensions
:undo :esa :climacs-editing :climacs-motion)
;;(:import-from :lisp-string)
- (:export :climacs ; Main entry point.
+ (:export #:climacs ; Frame.
+
;; GUI functions follow.
- :climacs-rv ; Entry point with alternate colors.
- :current-window
- :current-point
- :current-buffer
- :current-buffer
- :point
- :syntax
- :mark
- :insert-character
- :base-table
- :buffer-table
- :case-table
- :comment-table
- :deletion-table
- :development-table
- :editing-table
- :fill-table
- :indent-table
- :info-table
- :marking-table
- :movement-table
- :pane-table
- :search-table
- :self-insert-table
- :window-table))
+ #:current-window
+ #:current-point
+ #:current-buffer
+ #:current-buffer
+ #:point
+ #:syntax
+ #:mark
+ #:insert-character
+ #:base-table
+ #:buffer-table
+ #:case-table
+ #:comment-table
+ #:deletion-table
+ #:development-table
+ #:editing-table
+ #:fill-table
+ #:indent-table
+ #:info-table
+ #:marking-table
+ #:movement-table
+ #:pane-table
+ #:search-table
+ #:self-insert-table
+ #:window-table
+
+ ;; Some configuration variables
+ #:*bg-color*
+ #:*fg-color*
+ #:*info-bg-color*
+ #:*info-fg-color*
+ #:*mini-bg-color*
+ #:*mini-fg-color*))
(defpackage :climacs-commands
(:use :clim-lisp :clim :climacs-base :climacs-buffer
@@ -379,4 +391,12 @@
(defpackage :climacs-lisp-syntax
(:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing)
- (:export :lisp-string))
\ No newline at end of file
+ (:export #:lisp-string
+ #:edit-definition))
+
+(defpackage :climacs
+ (:use :clim-lisp :clim :clim-sys :clim-extensions :climacs-gui)
+ (:export #:climacs
+ #:climacs-rv
+ #:edit-definition)
+ (:documentation "Package containing entry points to Climacs."))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/06/13 11:34:52 1.219
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/11 14:20:20 1.220
@@ -201,33 +201,6 @@
"Return the current buffer."
(buffer (current-window)))
-(defun climacs (&key new-process (process-name "Climacs")
- (width 900) (height 400))
- "Starts up a climacs session"
- (let ((frame (make-application-frame 'climacs :width width :height height)))
- (flet ((run ()
- (run-frame-top-level frame)))
- (if new-process
- (clim-sys:make-process #'run :name process-name)
- (run)))))
-
-(defun climacs-rv (&key new-process (process-name "Climacs")
- (width 900) (height 400))
- "Starts up a climacs session"
- ;; SBCL doesn't inherit dynamic bindings when starting new
- ;; processes, so start a new processes and THEN setup the colors.
- (flet ((run ()
- (let ((*bg-color* +black+)
- (*fg-color* +gray+)
- (*info-bg-color* +darkslategray+)
- (*info-fg-color* +gray+)
- (*mini-bg-color* +black+)
- (*mini-fg-color* +white+))
- (climacs :new-process nil :width width :height height))))
- (if new-process
- (clim-sys:make-process #'run :name process-name)
- (run))))
-
(define-presentation-type read-only ())
(define-presentation-method highlight-presentation
((type read-only) record stream state)
@@ -540,25 +513,6 @@
'pane-table
'((#\x :control) (#\k)))
-#+sbcl
-(defun ed-in-climacs (thing)
- (let ((frame-manager (find-frame-manager)))
- (when frame-manager
- (let ((climacs-frame (find-if (lambda (x) (typep x 'climacs))
- (frame-manager-frames frame-manager))))
- (when climacs-frame
- (typecase thing
- ((or pathname string)
- (execute-frame-command
- climacs-frame `(com-find-file ,(pathname thing)))
- t)
- ((or symbol cons)
- ;; FIXME: do something
- nil)))))))
-
-#+sbcl
-(pushnew 'ed-in-climacs sb-ext:*ed-functions*)
-
;;; For the ESA help functions.
(defmethod help-stream ((frame climacs) title)
--- /project/climacs/cvsroot/climacs/climacs.lisp 2004/12/16 06:23:42 1.2
+++ /project/climacs/cvsroot/climacs/climacs.lisp 2006/07/11 14:20:20 1.3
@@ -1,145 +1,58 @@
-(defpackage :climacs
- (:use :clim-lisp :clim :climacs-buffer))
+;;; -*- Mode: Lisp; Package: CLIMACS -*-
-(in-package :climacs)
-
-(define-application-frame climacs ()
- ((buffer :initform (make-instance 'standard-buffer)
- :accessor buffer)
- (point :initform nil :reader point))
- (:panes
- (win :interactor :width 600 :height 200
- :display-function 'display-win))
- (:layouts
- (default (vertically () win)))
- (:top-level (climacs-top-level)))
-
-(defmethod initialize-instance :after ((frame climacs) &rest args)
- (declare (ignore args))
- (setf (slot-value frame 'point)
- (make-instance 'standard-right-sticky-mark
- :buffer (buffer frame))))
-
-(defun climacs ()
- (run-frame-top-level (make-application-frame 'climacs)))
-
-(defun display-win (frame pane)
- (let* ((medium (sheet-medium pane))
- (style (medium-text-style medium))
- (height (* 1.1 (text-style-height style medium)))
- (width (text-style-width style medium)))
- (loop with size = (size (buffer frame))
- with y = height
- for x from 0 by width
- for offset from 0 below size
- do (if (char= (buffer-char (buffer frame) offset) #\Newline)
- (setf y (+ y height)
- x (- width))
- (draw-text* pane (buffer-char (buffer frame) offset) x y)))
- (let* ((line (line-number (point frame)))
- (col (column-number (point frame)))
- (x (* width col))
- (y (* height (+ line 0.5))))
- (draw-line* pane x (- y (* 0.5 height)) x (+ y (* 0.5 height)) :ink +red+))))
-
-(defun find-gestures (gestures start-table)
- (loop with table = (find-command-table start-table)
- for (gesture . rest) on gestures
- for item = (find-keystroke-item gesture table :errorp nil)
- while item
- do (if (eq (command-menu-item-type item) :command)
- (return (if (null rest) item nil))
- (setf table (command-menu-item-value item)))
- finally (return item)))
-
-(defparameter *current-gesture* nil)
-
-(defun climacs-top-level (frame &key
- command-parser command-unparser
- partial-command-parser prompt)
- (declare (ignore command-parser command-unparser partial-command-parser prompt))
- (let ((*standard-output* (frame-standard-output frame))
- (*standard-input* (frame-standard-input frame))
- (*print-pretty* nil))
- (redisplay-frame-panes frame :force-p t)
- (loop with gestures = '()
- do (setf *current-gesture* (read-gesture :stream *standard-input*))
- (when (or (characterp *current-gesture*)
- (keyboard-event-character *current-gesture*))
- (setf gestures (nconc gestures (list *current-gesture*)))
- (let ((item (find-gestures gestures 'global-climacs-table)))
- (cond ((not item)
- (beep) (setf gestures '()))
- ((eq (command-menu-item-type item) :command)
- (funcall (command-menu-item-value item))
- (setf gestures '()))
- (t nil))))
- (redisplay-frame-panes frame :force-p t))))
-
-(define-command com-quit ()
- (frame-exit *application-frame*))
-
-(define-command com-self-insert ()
- (insert-text (point *application-frame*) *current-gesture*))
-
-(define-command com-backward-char ()
- (decf (offset (point *application-frame*))))
-
-(define-command com-forward-char ()
- (incf (offset (point *application-frame*))))
-
-(define-command com-beginning-of-line ()
- (beginning-of-line (point *application-frame*)))
-
-(define-command com-end-of-line ()
- (end-of-line (point *application-frame*)))
-
-(define-command com-delete-char ()
- (delete-text (point *application-frame*)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Global command table
-
-(make-command-table 'global-climacs-table :errorp nil)
-
-(loop for code from (char-code #\space) to (char-code #\~)
- do (add-command-to-command-table
- 'com-self-insert
- (find-command-table 'global-climacs-table)
- :keystroke (code-char code) :errorp nil))
-
-(add-command-to-command-table 'com-self-insert (find-command-table 'global-climacs-table)
- :keystroke #\newline :errorp nil)
-
-(add-command-to-command-table 'com-forward-char (find-command-table 'global-climacs-table)
- :keystroke '(#\f :control) :errorp nil)
-
-(add-command-to-command-table 'com-backward-char (find-command-table 'global-climacs-table)
- :keystroke '(#\b :control) :errorp nil)
-
-(add-command-to-command-table 'com-beginning-of-line (find-command-table 'global-climacs-table)
- :keystroke '(#\a :control) :errorp nil)
-
-(add-command-to-command-table 'com-end-of-line (find-command-table 'global-climacs-table)
- :keystroke '(#\e :control) :errorp nil)
-
-(add-command-to-command-table 'com-delete-char (find-command-table 'global-climacs-table)
- :keystroke '(#\d :control) :errorp nil)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; C-x command table
-
-(make-command-table 'c-x-climacs-table :errorp nil)
-
-(add-menu-item-to-command-table 'global-climacs-table "C-x"
- :menu (find-command-table 'c-x-climacs-table)
- :keystroke '(#\x :control))
+;;; (c) copyright 2004-2005 by
+;;; Robert Strandh (strandh at labri.fr)
+;;; (c) copyright 2004-2005 by
+;;; Elliott Johnson (ejohnson at fasl.info)
+;;; (c) copyright 2005 by
+;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr)
+;;; (c) copyright 2005 by
+;;; Aleksandar Bakic (a_bakic at yahoo.com)
+;;; (c) copyright 2006 by
+;;; Troels Henriksen (athas at sigkill.dk)
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307 USA.
-;;; for some reason, C-c does not seem to arrive as far as CLIM.
-
-(add-command-to-command-table 'com-quit (find-command-table 'c-x-climacs-table)
- :keystroke '(#\q :control))
+;;; Entry points for the Climacs editor.
+(in-package :climacs)
+(defun climacs (&key new-process (process-name "Climacs")
+ (width 900) (height 400))
+ "Starts up a climacs session"
+ (let ((frame (make-application-frame 'climacs :width width :height height)))
+ (flet ((run ()
+ (run-frame-top-level frame)))
+ (if new-process
+ (clim-sys:make-process #'run :name process-name)
+ (run)))))
+
+(defun climacs-rv (&key new-process (process-name "Climacs")
+ (width 900) (height 400))
+ "Starts up a climacs session with alternative colors."
+ ;; SBCL doesn't inherit dynamic bindings when starting new
+ ;; processes, so start a new processes and THEN setup the colors.
+ (flet ((run ()
+ (let ((*bg-color* +black+)
+ (*fg-color* +gray+)
+ (*info-bg-color* +darkslategray+)
+ (*info-fg-color* +gray+)
+ (*mini-bg-color* +black+)
+ (*mini-fg-color* +white+))
+ (climacs :new-process nil :width width :height height))))
+ (if new-process
+ (clim-sys:make-process #'run :name process-name)
+ (run))))
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/05 13:52:17 1.46
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/11 14:20:20 1.47
@@ -2,6 +2,8 @@
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh at labri.u-bordeaux.fr)
+;;; (c) copyright 2006 by
+;;; Troels Henriksen (athas at sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
@@ -91,6 +93,7 @@
(:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane"
"kill-ring" "io" "text-syntax"
"abbrev" "editing" "motion"))
+ (:file "climacs" :depends-on ("gui"))
;; (:file "buffer-commands" :depends-on ("gui"))
(:file "developer-commands" :depends-on ("gui" "lisp-syntax"))
(:file "motion-commands" :depends-on ("gui"))
More information about the Climacs-cvs
mailing list