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@labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.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 @@ -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@labri.fr) +;;; (c) copyright 2004-2005 by +;;; Elliott Johnson (ejohnson@fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) +;;; (c) copyright 2005 by +;;; Aleksandar Bakic (a_bakic@yahoo.com) +;;; (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 +;;; 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@labri.u-bordeaux.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 @@ -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"))