[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp

[Robert Strandh]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv17852

Modified Files:
	base.lisp gui.lisp packages.lisp syntax.lisp 
Log Message:
Factored aspects of named objects (currently buffers and syntaxes) into
a syntax-mixin class in base.lisp.  Updated packages.lisp accordingly.

Implemented syntax completion (i.e., the possibility to use CLIM
completion to determine the name of a syntax).  I

Implemented an extended command "Set Syntax" using the completion.
Currently, it does not invalidate the CLIM output history, because I
need to think a bit more about how to do that properly. 


Date: Sat Jan  1 10:34:26 2005
Author: rstrandh

Index: climacs/base.lisp
diff -u climacs/base.lisp:1.8 climacs/base.lisp:1.9
--- climacs/base.lisp:1.8	Thu Dec 30 06:28:21 2004
+++ climacs/base.lisp	Sat Jan  1 10:34:25 2005
@@ -135,3 +135,12 @@
 	while (constituentp (object-before mark))
 	do (delete-range mark -1)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; Named objects
+
+(defgeneric name (obj))
+
+(defclass name-mixin ()
+  ((name :initarg :name :accessor name)))
+


Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.37 climacs/gui.lisp:1.38
--- climacs/gui.lisp:1.37	Fri Dec 31 14:33:06 2004
+++ climacs/gui.lisp	Sat Jan  1 10:34:25 2005
@@ -27,9 +27,10 @@
 (defclass filename-mixin ()
   ((filename :initform nil :accessor filename)))
 
-(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin)
-  ((name :initform "*scratch*" :accessor name)
-   (needs-saving :initform nil :accessor needs-saving)))
+(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin)
+  ((needs-saving :initform nil :accessor needs-saving))
+  (:default-initargs :name "*scratch*"))
+
 
 (defclass climacs-pane (application-pane)
   ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
@@ -94,9 +95,10 @@
 (defun display-info (frame pane)
   (let* ((win (win frame))
 	 (buf (buffer win))
-	 (name-info (format nil "   ~a   ~a"
+	 (name-info (format nil "   ~a   ~a   Syntax: ~a"
 			    (if (needs-saving buf) "**" "--")
-			    (name buf))))
+			    (name buf)
+			    (name (syntax win)))))
     (princ name-info pane)))
 
 (defun display-win (frame pane)
@@ -420,6 +422,11 @@
 (define-named-command com-set-mark ()
   (with-slots (point mark) (win *application-frame*)
 	      (setf mark (clone-mark point))))
+
+(define-named-command com-set-syntax ()
+  (setf (syntax (win *application-frame*))
+	(make-instance (accept 'syntax :prompt "Set Syntax")
+	   :pane (win *application-frame*))))
 
 ;;;;;;;;;;;;;;;;;;;;
 ;; Kill ring commands


Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.16 climacs/packages.lisp:1.17
--- climacs/packages.lisp:1.16	Fri Dec 31 14:33:06 2004
+++ climacs/packages.lisp	Sat Jan  1 10:34:25 2005
@@ -48,7 +48,8 @@
 	   #:constituentp #:whitespacep
 	   #:forward-word #:backward-word
 	   #:delete-word #:backward-delete-word
-	   #:input-from-stream #:output-to-stream))
+	   #:input-from-stream #:output-to-stream
+	   #:name-mixin #:name))
 
 (defpackage :climacs-abbrev
   (:use :clim-lisp :clim :climacs-buffer :climacs-base)


Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.13 climacs/syntax.lisp:1.14
--- climacs/syntax.lisp:1.13	Fri Dec 31 14:33:06 2004
+++ climacs/syntax.lisp	Sat Jan  1 10:34:25 2005
@@ -24,7 +24,7 @@
 
 (in-package :climacs-syntax)
 
-(defclass syntax () ())
+(defclass syntax (name-mixin) ())
 
 (defgeneric redisplay-with-syntax (pane syntax))
 
@@ -34,7 +34,37 @@
 
 (defgeneric full-redisplay (pane syntax))
 
-(defclass basic-syntax (syntax)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Syntax completion
+
+(defparameter *syntaxes* '())
+
+(defmacro define-syntax (class-name (name superclasses) &body body)
+  `(progn (push '(,name . ,class-name) *syntaxes*)
+	  (defclass ,class-name ,superclasses
+	       , at body
+	    (:default-initargs :name ,name))))
+
+(define-presentation-method accept
+    ((type syntax) stream (view textual-view) &key)
+  (multiple-value-bind (pathname success string)
+      (complete-input stream
+		      (lambda (so-far action)
+			(complete-from-possibilities
+			 so-far *syntaxes* '() :action action
+			 :name-key #'car
+			 :value-key #'cdr))
+		      :partial-completers '(#\Space)
+		      :allow-any-input t)
+    (declare (ignore success))
+    (or pathname string)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Basic syntax
+
+(define-syntax basic-syntax ("Basic" (syntax))
   ((top :reader top)
    (bot :reader bot)
    (scan :reader scan)
@@ -58,6 +88,8 @@
 (define-presentation-type url ()
   :inherit-from 'string)
 
+(defgeneric present-contents (contenst pane syntax))
+
 (defmethod present-contents (contents pane (syntax basic-syntax))
   (unless (null contents)
     (present contents
@@ -66,6 +98,8 @@
 		 'string)
 	     :stream pane)))
 
+(defgeneric display-line (pane syntax line))
+
 (defmethod display-line (pane (syntax basic-syntax) line)
   (let ((saved-index nil)
 	(id 0))
@@ -117,6 +151,8 @@
 		       (terpri pane)
 		       (incf scan))))))
 
+(defgeneric compute-cache (pane syntax))
+
 (defmethod compute-cache (pane (syntax basic-syntax))
   (with-slots (top bot cache) syntax
      (let* ((buffer (buffer pane))
@@ -225,7 +261,7 @@
 ;;;
 ;;; Texinfo syntax
 
-(defclass texinfo-syntax (basic-syntax) ())
+(define-syntax texinfo-syntax ("Texinfo" (basic-syntax)) ())
 
 (define-presentation-type texinfo-command ()
   :inherit-from 'string)
@@ -236,4 +272,5 @@
 	(with-drawing-options (pane :ink +red+)
 	  (present contents 'texinfo-command :stream pane))
 	(present contents 'string :stream pane))))
+