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

Contents of /climacs/climacs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Sat Jan 26 11:28:53 2008 UTC (6 years, 2 months ago) by thenriksen
Branch: MAIN
Changes since 1.5: +2 -1 lines
Only execute a command when we actually have a command.
1 thenriksen 1.3 ;;; -*- Mode: Lisp; Package: CLIMACS -*-
2 strandh 1.1
3 thenriksen 1.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     ;;; This library is free software; you can redistribute it and/or
15     ;;; modify it under the terms of the GNU Library General Public
16     ;;; License as published by the Free Software Foundation; either
17     ;;; version 2 of the License, or (at your option) any later version.
18     ;;;
19     ;;; This library is distributed in the hope that it will be useful,
20     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22     ;;; Library General Public License for more details.
23     ;;;
24     ;;; You should have received a copy of the GNU Library General Public
25     ;;; License along with this library; if not, write to the
26     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27     ;;; Boston, MA 02111-1307 USA.
28 strandh 1.1
29 thenriksen 1.3 ;;; Entry points for the Climacs editor.
30 strandh 1.1
31 thenriksen 1.3 (in-package :climacs)
32 strandh 1.1
33 thenriksen 1.5 (defun find-climacs-frame ()
34     (let ((frame-manager (find-frame-manager)))
35     (when frame-manager
36     (find-if (lambda (x) (and (typep x 'climacs)
37     (eq (clim:frame-state x) :enabled)))
38     (frame-manager-frames frame-manager)))))
39    
40     (defun climacs (&rest args &key new-process (process-name "Climacs")
41 thenriksen 1.3 (width 900) (height 400))
42     "Starts up a climacs session"
43 thenriksen 1.5 (declare (ignore new-process process-name width height))
44     (apply #'climacs-common nil args))
45 thenriksen 1.3
46 thenriksen 1.5 (defun climacs-rv (&rest args &key new-process (process-name "Climacs")
47     (width 900) (height 400))
48 thenriksen 1.3 "Starts up a climacs session with alternative colors."
49     ;; SBCL doesn't inherit dynamic bindings when starting new
50     ;; processes, so start a new processes and THEN setup the colors.
51 thenriksen 1.5 (declare (ignore width height))
52 thenriksen 1.3 (flet ((run ()
53 thenriksen 1.4 (let ((*background-color* +black+)
54     (*foreground-color* +gray+)
55 thenriksen 1.3 (*info-bg-color* +darkslategray+)
56     (*info-fg-color* +gray+)
57     (*mini-bg-color* +black+)
58     (*mini-fg-color* +white+))
59 thenriksen 1.5 (apply #'climacs-common nil :new-process nil args))))
60 thenriksen 1.3 (if new-process
61 thenriksen 1.5 (clim-sys:make-process #'run :name process-name)
62     (run))))
63    
64     (defun edit-file (thing &rest args
65     &key (process-name "Climacs") (width 900) (height 400))
66     "Edit THING in an existing climacs process or start a new one. THING
67     can be a filename (edit the file) or symbol (edit its function definition)."
68     (declare (ignore process-name width height))
69     (let ((climacs-frame (find-climacs-frame))
70     (command
71     (typecase thing
72     (null nil)
73     (symbol (list 'drei-lisp-syntax::com-edit-definition thing))
74     ((or string pathname)
75     (truename thing) ; raise file-error if file doesn't exist
76     (list 'esa-io::com-find-file thing))
77     (t (error 'type-error :datum thing
78     :expected-type '(or null string pathname symbol))))))
79     (if climacs-frame
80 thenriksen 1.6 (when command
81     (execute-frame-command climacs-frame command))
82 thenriksen 1.5 (apply #'climacs-common command :new-process t args)))
83     t)
84    
85     (defun climacs-common (command &key new-process (process-name "Climacs")
86     (width 900) (height 400))
87     (let* ((frame (make-application-frame 'climacs :width width :height height))
88     (*application-frame* frame)
89     (esa:*esa-instance* frame))
90     (adopt-frame (find-frame-manager) *application-frame*)
91     (when command (execute-frame-command *application-frame* command))
92     (flet ((run () (run-frame-top-level frame)))
93     (if new-process
94     (clim-sys:make-process #'run :name process-name)
95     (run)))))
96    
97     ;;; Append to end of *ed-functions* so we don't overwrite the user's
98     ;;; preferred editor
99     #+sbcl
100     (unless (member 'edit-file sb-ext:*ed-functions*)
101     (setf sb-ext:*ed-functions* (append sb-ext:*ed-functions* (list 'edit-file))))

  ViewVC Help
Powered by ViewVC 1.1.5