November 2006 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 09 Nov '06

09 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11264/Drei Modified Files: drei-redisplay.lisp Log Message: Slight change of how full-redisplay works and fix of docstring (oops). --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 17:52:55 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/09 00:52:01 1.3 @@ -420,8 +420,7 @@ (if (full-redisplay-p drei-pane) (progn (reposition-pane drei-pane) (adjust-pane-bot drei-pane) - (setf (full-redisplay-p drei-pane) nil) - (window-clear drei-pane)) + (setf (full-redisplay-p drei-pane) nil)) (adjust-pane drei-pane)) (update-syntax-for-display buffer (syntax buffer) top bot) (display-drei-contents drei-pane drei-pane (syntax buffer)) @@ -432,8 +431,7 @@ (fix-pane-viewport drei-pane))) (defgeneric full-redisplay (pane) - (:documentation "Return T if `pane' is queued to do a full -redisplay, NIL otherwise.")) + (:documentation "Queue a full redisplay for `pane'.")) (defmethod full-redisplay ((pane drei-pane)) (setf (full-redisplay-p pane) t))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15306 Modified Files: lisp-syntax.lisp fundamental-syntax.lisp drei-redisplay.lisp Log Message: Fix obscure redisplay issue that appeared when the input begins with whitespace in the input-editor. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 17:52:55 1.2 @@ -2029,7 +2029,7 @@ (loop for child in (cdr children) do (display-parse-tree child stream drei syntax)))) -(defmethod display-drei-contents (stream (drei drei) (syntax lisp-syntax)) +(defmethod display-drei-contents ((stream clim-stream-pane) (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei (with-accessors ((cursor-positions cursor-positions)) syntax ;; There must always be room for at least one element of line --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 17:52:55 1.2 @@ -109,7 +109,7 @@ pane (- tab-width (mod x tab-width)) 0)))) (incf start)))))) -(defmethod display-line (stream (drei drei) mark) +(defmethod display-line ((stream clim-stream-pane) (drei drei) mark) (let ((mark (clone-mark mark))) (with-accessors ((space-width space-width) (tab-width tab-width)) stream (let ((saved-offset nil) @@ -120,7 +120,7 @@ saved-offset mark) 'string))) - (updating-output (stream :unique-id (cons stream (incf id)) + (updating-output (stream :unique-id (cons drei (incf id)) :id-test #'equal :cache-value contents :cache-test #'equal) @@ -162,7 +162,7 @@ (unless (end-of-buffer-p mark) (terpri stream))))))))) -(defmethod display-drei-contents (stream drei (syntax fundamental-syntax)) +(defmethod display-drei-contents ((stream clim-stream-pane) (drei drei) (syntax fundamental-syntax)) (with-slots (top bot) drei (with-accessors ((cursor-positions cursor-positions)) syntax (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 17:52:55 1.2 @@ -53,6 +53,16 @@ (letf (((stream-default-view stream) (view drei))) (call-next-method)))) +;; XXX: If the display begins with a blank area - for example spaces - +;; CLIM will (rightly) think the output records position is at the +;; first output. This is not good, because it means that the output +;; record will "walk" across the screen if the buffer starts with +;; blanks. Therefore, we make sure that an output record exists at the +;; very beginning of the output. +(defmethod display-drei-contents :before ((stream extended-output-stream) (drei drei-area) syntax) + (with-new-output-record (stream 'standard-sequence-output-record record) + (setf (output-record-position record) (stream-cursor-position stream)))) + (defgeneric display-drei-cursor (stream drei cursor syntax) (:documentation "Display the given cursor to `stream'.") (:method :around ((stream extended-output-stream) (drei drei)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9855 Modified Files: input-editor.lisp drei-clim.lisp Log Message: Implemented `add-input-editor-command' as per the Franz User Guide. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 13:08:12 1.2 @@ -176,8 +176,7 @@ (with-accessors ((buffer buffer)) (drei-instance stream) (let* ((array (buffer-sequence buffer 0 (size buffer)))) (make-array (length array) - :fill-pointer t - :adjustable t + :fill-pointer (length array) :initial-contents array)))) (defmethod replace-input ((stream drei-input-editing-mixin) (new-input array) @@ -252,6 +251,10 @@ printed-rep) args)))) +(defvar *drei-input-editing-stream* nil + "Used to provide CLIM-specified input-editing-commands with the +input-editing-stream. Bound when executing a command.") + ;;; Have to reexamine how many of the keyword arguments to ;;; stream-read-gesture should really be passed to the encapsulated ;;; stream. @@ -356,7 +359,8 @@ (drei (drei-instance stream)) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) - (minibuffer (or (minibuffer drei) *minibuffer*))) + (minibuffer (or (minibuffer drei) *minibuffer*)) + (*drei-input-editing-stream* stream)) (with-bound-drei-special-variables (drei ;; If the minibuffer is the ;; stream we are encapsulating @@ -500,19 +504,22 @@ ;;; CLIM spec does not define, or even suggest, any kind of ;;; programmatic access to the data structures of the input-editor for ;;; these function, it is utterly impossible to write portable -;;; input-editor functions using this -;;; facility. `Add-input-editor-command' is implemented like this in -;;; Drei: the specified gesture sequence is bound to the provided -;;; function in the `editor-table' command table, and will have a -;;; standard Drei command environment when invoked. This is sufficient -;;; for only the most trivial of commands, using `define-command' and -;;; `set-key' is a much, much more powerful mechanism, and it allows -;;; far more elegant handling of numeric arguments. +;;; input-editor functions using this facility. Fortunately, Franz's +;;; user guide saves us. An input-editor-command defined via this +;;; facility takes four arguments: the input-editing stream, the input +;;; buffer (ugh!), the gesture used to invoke the command, and the +;;; accumulated numeric argument. (defun add-input-editor-command (gestures function) "Set up Drei so performing `gestures' will result in the invocation of `function' " - (set-key function 'editor-table gestures)) + (set-key `(,(lambda (numeric-argument) + (funcall function *drei-input-editing-stream* + (stream-input-buffer *drei-input-editing-stream*) + gestures + numeric-argument)) ,*numeric-argument-marker*) + 'exclusive-input-editor-table + gestures)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 13:08:12 1.2 @@ -58,20 +58,20 @@ (make-command-table 'self-insert-table :errorp nil) ;;; Command table for concrete editor stuff. -(make-command-table 'editor-table - :errorp nil - :inherit-from '(comment-table - deletion-table - editing-table - case-table - fill-table - indent-table - marking-table - movement-table - search-table - info-table - self-insert-table - keyboard-macro-table)) +(define-syntax-command-table editor-table + :errorp nil + :inherit-from '(comment-table + deletion-table + editing-table + case-table + fill-table + indent-table + marking-table + movement-table + search-table + info-table + self-insert-table + keyboard-macro-table)) ;; Command table for commands that are only available when Drei is a ;; pane.

1 0

[mcclim-cvs] CVS mcclim/Apps/Inspector
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv25597/Apps/Inspector Modified Files: clouseau.asd Log Message: Make Clouseau's system definition inter-file dependencies explicit, just for good measure. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/clouseau.asd 2005/06/15 09:04:43 1.6 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/clouseau.asd 2006/11/08 01:19:49 1.7 @@ -25,5 +25,5 @@ :serial t :components ((:file "package") - (:file "disassembly") - (:file "inspector"))) + (:file "disassembly" :depends-on ("package")) + (:file "inspector" :depends-on ("disassembly"))))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25509 Modified Files: mcclim.asd Log Message: Commit mcclim.asd changes to load Drei and the other added files. May contain trace amounts of ugly (and necessary complexity). --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 19:00:54 1.32 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/08 01:19:02 1.33 @@ -32,6 +32,16 @@ (defparameter *clim-directory* (directory-namestring *load-truename*)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun find-swank-package () + (find-package :swank)) + (defun find-swank-system () + (handler-case (asdf:find-system :swank) + (asdf:missing-component ()))) + (defun find-swank () + (or (find-swank-package) + (find-swank-system)))) + ;;; Legacy CMUCL support stuff #+cmu (progn @@ -93,7 +103,7 @@ #+clisp "fix-clisp"))) (:file "package" :depends-on ("Lisp-Dep" "patch")))) -(defsystem :clim-core +(defsystem :clim-basic :depends-on (:clim-lisp :spatial-trees) :components ((:file "decls") (:file "protocol-classes" :depends-on ("decls")) @@ -145,7 +155,7 @@ "events")))) (defsystem :goatee-core - :depends-on (:clim-core) + :depends-on (:clim-basic) :components ((:module "Goatee" :components @@ -169,67 +179,140 @@ (:file "presentation-history" :depends-on ("editing-stream" "buffer" "flexivector" "editable-buffer" "goatee-command")))))) - ;;; CLIM-PostScript is not a backend in the normal sense. ;;; It is an extension (Chap. 35.1 of the spec) and is an ;;; "included" part of McCLIM. Hence the defsystem is here. (defsystem :clim-postscript - :depends-on (:clim-core) - :components - ((:module "Backends/PostScript" - :pathname #.(make-pathname :directory '(:relative "Backends" "PostScript")) - :components - ((:file "package") - (:file "encoding" :depends-on ("package")) - (:file "paper" :depends-on ("package")) - (:file "class" :depends-on ("paper" "package")) - (:file "font" :depends-on ("encoding" "class" "paper" "package")) - (:file "graphics" :depends-on ("encoding" "paper" "class" "font" "package")) - (:file "sheet" :depends-on ("paper" "class" "graphics" "package")) - (:file "afm" :depends-on ("class" "paper" "font" "package")) - (:file "standard-metrics" :depends-on ("font" "package")))))) + :depends-on (:clim-basic) + :components + ((:module "Backends/PostScript" + :pathname #.(make-pathname :directory '(:relative "Backends" "PostScript")) + :components + ((:file "package") + (:file "encoding" :depends-on ("package")) + (:file "paper" :depends-on ("package")) + (:file "class" :depends-on ("paper" "package")) + (:file "font" :depends-on ("encoding" "class" "paper" "package")) + (:file "graphics" :depends-on ("encoding" "paper" "class" "font" "package")) + (:file "sheet" :depends-on ("paper" "class" "graphics" "package")) + (:file "afm" :depends-on ("class" "paper" "font" "package")) + (:file "standard-metrics" :depends-on ("font" "package")))))) + +(defsystem :clim-core + :depends-on (:clim-basic :goatee-core :clim-postscript) + :components ((:file "text-formatting") + (:file "defresource") + (:file "input-editing") + (:file "presentations") + (:file "pointer-tracking" :depends-on ("input-editing")) + (:file "graph-formatting") + (:file "frames" :depends-on ("commands" "presentations" "presentation-defs" + "pointer-tracking" "incremental-redisplay")) + (:file "table-formatting" :depends-on ("presentation-defs" "panes" + "presentations" "input-editing")) + (:file "bordered-output" :depends-on ("input-editing" "incremental-redisplay" + "presentation-defs" "panes")) + (:file "dialog-views" :depends-on ("presentations" "incremental-redisplay" + "bordered-output" "presentation-defs")) + (:file "presentation-defs" :depends-on ("input-editing" "presentations")) + (:file "gadgets" :depends-on ("commands" "pointer-tracking" "input-editing" + "frames" "incremental-redisplay" "panes")) + (:file "describe" :depends-on ("presentations" "presentation-defs" "table-formatting")) + (:file "commands" :depends-on ("input-editing" "presentations" + "presentation-defs")) + (:file "incremental-redisplay" :depends-on ("presentation-defs")) + (:file "menu-choose" :depends-on ("commands" "table-formatting" "presentation-defs" + "panes" "frames" "pointer-tracking" + "presentations")) + (:file "menu" :depends-on ("panes" "commands" "gadgets" + "presentations" "frames")) + (:file "panes" :depends-on ("incremental-redisplay" "presentations" + "presentation-defs" "input-editing" "frames")) + (:file "dialog" :depends-on ("panes" "frames" "incremental-redisplay" + "table-formatting" "presentations" + "bordered-output" "presentation-defs" + "dialog-views" "input-editing" + "commands")) + (:file "builtin-commands" :depends-on ("table-formatting" "commands" "presentations" + "presentation-defs" "input-editing")))) + +(defsystem :esa-mcclim + :depends-on (:clim-core) + :components ((:module "ESA" + :components ((:file "packages") + (:file "utils" :depends-on ("packages")) + (:file "colors" :depends-on ("packages")) + (:file "esa" :depends-on ("colors" "packages" "utils")) + (:file "esa-buffer" :depends-on ("packages" "esa")) + (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) + (:file "esa-command-parser" :depends-on ("packages" "esa")))))) + + + +(defsystem :drei-mcclim + :depends-on (:flexichain :esa-mcclim :clim-core #.(if (find-swank-system) :swank (values))) + :components + ((:module "cl-automaton" + :pathname #.(make-pathname :directory '(:relative "Drei" "cl-automaton")) + :components ((:file "automaton-package") + (:file "eqv-hash" :depends-on ("automaton-package")) + (:file "state-and-transition" :depends-on ("eqv-hash")) + (:file "automaton" :depends-on ("state-and-transition" "eqv-hash")) + (:file "regexp" :depends-on ("automaton")))) + (:module "Persistent" + :pathname #.(make-pathname :directory '(:relative "Drei" "Persistent")) + :components ((:file "binseq-package") + (:file "binseq" :depends-on ("binseq-package")) + (:file "obinseq" :depends-on ("binseq-package" "binseq")) + (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq")))) + (:module "Drei" :depends-on ("cl-automaton" "Persistent") + :components ((:file "packages") + (:file "buffer" :depends-on ("packages")) + (:file "motion" :depends-on ("packages" "buffer" "syntax")) + (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) + (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) + (:file "syntax" :depends-on ("packages" "buffer" "base")) + (:file "drei" :depends-on ("packages" "syntax" "buffer" "base" + "persistent-undo" "persistent-buffer" "abbrev" + "delegating-buffer" "undo" "motion" "editing")) + (:file "drei-clim" :depends-on ("drei")) + (:file "drei-redisplay" :depends-on ("drei-clim")) + (:file "input-editor" :depends-on ("drei-redisplay" "lisp-syntax")) + (:file "fundamental-syntax" :depends-on ("packages" "drei-redisplay")) + (:file "abbrev" :depends-on ("packages")) + (:file "kill-ring" :depends-on ("packages")) + (:file "undo" :depends-on ("packages")) + (:file "delegating-buffer" :depends-on ("packages" "buffer")) + (:file "basic-commands" :depends-on ("drei-clim" "motion" "editing")) + (:file "core" :depends-on ("drei")) + (:file "rectangle" :depends-on ("core")) + (:file "core-commands" :depends-on ("core" "rectangle" "drei-clim")) + (:file "persistent-buffer" + :pathname #.(make-pathname :directory '(:relative "Persistent") + :name "persistent-buffer" + :type "lisp") + :depends-on ("packages")) + (:file "persistent-undo" + :pathname #p"Persistent/persistent-undo.lisp" + :depends-on ("packages" "buffer" "persistent-buffer" "undo")) + (:file "misc-commands" :depends-on ("basic-commands")) + (:file "unicode-commands" :depends-on ("core" "drei-clim")) + (:file "search-commands" :depends-on ("core" "drei-clim")) + (:file "lisp-syntax" :depends-on ("core" "motion" "fundamental-syntax")) + (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) + #.(if (find-swank) + '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) + (values)))))) (defsystem :clim - :depends-on (:clim-core :goatee-core) - :components - ((:file "text-formatting") - (:file "input-editing") - (:file "presentations") - (:file "defresource") - (:file "presentation-defs" :depends-on ("input-editing" "presentations")) - (:file "pointer-tracking" :depends-on ("input-editing")) - (:file "commands" :depends-on ("input-editing" "presentations" - "presentation-defs")) - (:file "incremental-redisplay" :depends-on ("presentation-defs")) - (:file "frames" :depends-on ("commands" "presentations" "presentation-defs" - "pointer-tracking" "incremental-redisplay")) - (:file "panes" :depends-on ("incremental-redisplay" "presentations" - "presentation-defs" "input-editing" "frames")) - (:file "gadgets" :depends-on ("commands" "pointer-tracking" "input-editing" - "frames" "incremental-redisplay" "panes")) - (:file "menu" :depends-on ("panes" "commands" "gadgets" - "presentations" "frames")) - (:file "table-formatting" :depends-on ("presentation-defs" "panes" - "presentations" "input-editing")) - (:file "graph-formatting") - (:file "bordered-output" :depends-on ("input-editing" "incremental-redisplay" - "presentation-defs" "panes")) - (:file "dialog-views" :depends-on ("presentations" "incremental-redisplay" - "bordered-output" "presentation-defs")) - (:file "dialog" :depends-on ("panes" "frames" "incremental-redisplay" - "table-formatting" "presentations" - "bordered-output" "presentation-defs" - "dialog-views" "input-editing" - "commands")) - (:file "builtin-commands" :depends-on ("table-formatting" "commands" "presentations" - "presentation-defs" "input-editing")) - (:file "describe" :depends-on ("presentations" "presentation-defs" "table-formatting")) - (:file "menu-choose" :depends-on ("commands" "table-formatting" "presentation-defs" - "panes" "frames" "pointer-tracking" - "presentations")) - (:file "Goatee/presentation-history" :depends-on ("presentation-defs") ; XXX: this is loaded as part of the Goatee system. huh? - :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp")) - )) + :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) + :components + ((:file "Goatee/presentation-history" ; XXX: this is loaded as part of the Goatee system. huh? + :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp")) + (:file "input-editing-goatee") + (:file "input-editing-drei") + (:file "text-editor-gadget"))) (defsystem :clim-clx :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) @@ -437,3 +520,15 @@ (defmethod perform :after ((op load-op) (c (eql (find-system :mcclim)))) (pushnew :clim *features*) (pushnew :mcclim *features*)) + +;; XXX This is very ugly, but ESA and Drei need to know whether they +;; are being compiled as part of McCLIM, or in another CLIM +;; implementation. +(defmethod perform :around (op c) + (if (and (or (eql (component-system c) (find-system :esa-mcclim)) + (eql (component-system c) (find-system :drei-mcclim))) + (not (find :building-mcclim *features*))) + (unwind-protect (progn (push :building-mcclim *features*) + (call-next-method)) + (setf *features* (delete :building-mcclim *features*))) + (call-next-method)))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24994/Drei Added Files: unicode-commands.lisp undo.lisp syntax.lisp search-commands.lisp rectangle.lisp packages.lisp motion.lisp motion-commands.lisp misc-commands.lisp lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-swank.lisp lisp-syntax-commands.lisp kill-ring.lisp kill-ring-test.lisp input-editor.lisp fundamental-syntax.lisp editing.lisp editing-commands.lisp drei.lisp drei.asd drei-redisplay.lisp drei-clim.lisp delegating-buffer.lisp core.lisp core-commands.lisp buffer.lisp buffer-test.lisp basic-commands.lisp base.lisp base-test.lisp abbrev.lisp Log Message: Committed Drei. --- /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2006/11/08 01:15:33 1.1 ;;; -*- Mode: Lisp; Package: DREI-COMMANDS -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson(a)fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; 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. ;;; Unicode handling for the editing component of the Climacs editor. (in-package :drei-commands) (do ((i 160 (+ i 1))) ((> i 255)) (set-key `(com-self-insert ,*numeric-argument-marker*) 'self-insert-table (list (code-char i)))) (define-command (com-insert-charcode :name t :command-table self-insert-table) ((code 'integer :prompt "Code point") (count 'integer)) (let ((char (code-char code))) (loop repeat count do (insert-character char)))) (macrolet ((set-charcode-key (code sequence) `(set-key `(com-insert-charcode ,',code ,*numeric-argument-marker*) 'self-insert-table ',sequence)) (set-dead-acute-key (code &rest sequence) `(set-charcode-key ,code ((:dead-acute) ,@sequence))) (set-dead-grave-key (code &rest sequence) `(set-charcode-key ,code ((:dead-grave) ,@sequence))) (set-dead-diaresis-key (code &rest sequence) `(set-charcode-key ,code ((:dead-diaresis :shift) ,@sequence))) (set-dead-tilde-key (code &rest sequence) `(set-charcode-key ,code ((:dead-tilde :shift) ,@sequence))) (set-dead-circumflex-key (code &rest sequence) `(set-charcode-key ,code ((:dead-circumflex :shift) ,@sequence)))) (set-dead-acute-key 193 (#\A)) (set-dead-acute-key 201 (#\E)) (set-dead-acute-key 205 (#\I)) (set-dead-acute-key 211 (#\O)) (set-dead-acute-key 218 (#\U)) (set-dead-acute-key 221 (#\Y)) (set-dead-acute-key 225 (#\a)) (set-dead-acute-key 233 (#\e)) (set-dead-acute-key 237 (#\i)) (set-dead-acute-key 243 (#\o)) (set-dead-acute-key 250 (#\u)) (set-dead-acute-key 253 (#\y)) (set-dead-acute-key 199 (#\C)) (set-dead-acute-key 231 (#\c)) (set-dead-acute-key 215 (#\x)) (set-dead-acute-key 247 (#\-)) (set-dead-acute-key 222 (#\T)) (set-dead-acute-key 254 (#\t)) (set-dead-acute-key 223 (#\s)) (set-dead-acute-key 39 (#\Space)) (set-dead-acute-key 197 (:dead-acute) (#\A)) (set-dead-acute-key 229 (:dead-acute) (#\a)) (set-dead-grave-key 192 (#\A)) (set-dead-grave-key 200 (#\E)) (set-dead-grave-key 204 (#\I)) (set-dead-grave-key 210 (#\O)) (set-dead-grave-key 217 (#\U)) (set-dead-grave-key 224 (#\a)) (set-dead-grave-key 232 (#\e)) (set-dead-grave-key 236 (#\i)) (set-dead-grave-key 242 (#\o)) (set-dead-grave-key 249 (#\u)) (set-dead-grave-key 96 (#\Space)) (set-dead-diaresis-key 196 (#\A)) (set-dead-diaresis-key 203 (#\E)) (set-dead-diaresis-key 207 (#\I)) (set-dead-diaresis-key 214 (#\O)) (set-dead-diaresis-key 220 (#\U)) (set-dead-diaresis-key 228 (#\a)) (set-dead-diaresis-key 235 (#\e)) (set-dead-diaresis-key 239 (#\i)) (set-dead-diaresis-key 246 (#\o)) (set-dead-diaresis-key 252 (#\u)) (set-dead-diaresis-key 255 (#\y)) (set-dead-diaresis-key 34 (#\Space)) (set-dead-tilde-key 195 (#\A)) (set-dead-tilde-key 209 (#\N)) (set-dead-tilde-key 227 (#\a)) (set-dead-tilde-key 241 (#\n)) (set-dead-tilde-key 198 (#\E)) (set-dead-tilde-key 230 (#\e)) (set-dead-tilde-key 208 (#\D)) (set-dead-tilde-key 240 (#\d)) (set-dead-tilde-key 248 (#\o)) (set-dead-tilde-key 126 (#\Space)) (set-dead-circumflex-key 194 (#\A)) (set-dead-circumflex-key 202 (#\E)) (set-dead-circumflex-key 206 (#\I)) (set-dead-circumflex-key 212 (#\O)) (set-dead-circumflex-key 219 (#\U)) (set-dead-circumflex-key 226 (#\a)) (set-dead-circumflex-key 234 (#\e)) (set-dead-circumflex-key 238 (#\i)) (set-dead-circumflex-key 244 (#\o)) (set-dead-circumflex-key 251 (#\u)) (set-dead-circumflex-key 94 (#\Space))) --- /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/08 01:15:33 1.1 ;;; -*- Mode: Lisp; Package: DREI-UNDO -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; 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. ;;; General-purpose undo module (in-package :drei-undo) (defgeneric add-undo (undo-record undo-tree) (:documentation "Add an undo record to the undo tree below the current state, and set the current state to be below the transition represented by the undo record.")) (defgeneric flip-undo-record (undo-record) (:documentation "This function is called by the undo module whenever the current state is changed from its current value to that of the parent state (presumably as a result of a call to undo) or to that of one of its child states. Client code is required to supply methods for this function on client-specific subclasses of undo-record.")) (defgeneric undo (undo-tree &optional n) (:documentation "Move the current state n steps up the undo tree and call flip-undo-record on each step. If the current state is at a level less than n, a no-more-undo condition is signaled and the current state is not moved (and no calls to flip-undo-record are made). As long as no new record are added to the tree, the undo module remembers which branch it was in before a sequence of calls to undo.")) (defgeneric redo (undo-tree &optional n) (:documentation "Move the current state n steps down the remembered branch of the undo tree and call flip-undo-record on each step. If the remembered branch is shorter than n, a no-more-undo condition is signaled and the current state is not moved (and no calls to flip-undo-record are made).")) (define-condition no-more-undo (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No more undo"))) (:documentation "This condition is signaled whenever an attempt is made to call undo on a tree that is in its initial state.")) (defclass undo-tree () () (:documentation "Protocol class for all undo trees")) (defclass standard-undo-tree (undo-tree) ((current-record :accessor current-record) (leaf-record :accessor leaf-record) (redo-path :initform '() :accessor redo-path) (children :initform '() :accessor children) (depth :initform 0 :reader depth)) (:documentation "Standard instantiable class for undo trees.")) (defmethod initialize-instance :after ((tree standard-undo-tree) &rest args) (declare (ignore args)) (setf (current-record tree) tree (leaf-record tree) tree)) (defclass undo-record () () (:documentation "The protocol class for all undo records.")) (defclass standard-undo-record (undo-record) ((parent :initform nil :accessor parent) (tree :initform nil :accessor undo-tree) (children :initform '() :accessor children) (depth :initform nil :accessor depth)) (:documentation "Standard instantiable class for undo records.")) (defmethod add-undo ((record standard-undo-record) (tree standard-undo-tree)) (push record (children (current-record tree))) (setf (undo-tree record) tree (parent record) (current-record tree) (depth record) (1+ (depth (current-record tree))) (current-record tree) record (leaf-record tree) record (redo-path tree) '())) (defmethod undo ((tree standard-undo-tree) &optional (n 1)) (assert (<= n (depth (current-record tree))) () (make-condition 'no-more-undo)) (loop repeat n do (flip-undo-record (current-record tree)) (push (current-record tree) (redo-path tree)) (setf (current-record tree) (parent (current-record tree))))) (defmethod redo ((tree standard-undo-tree) &optional (n 1)) (assert (<= n (- (depth (leaf-record tree)) (depth (current-record tree)))) () (make-condition 'no-more-undo)) (loop repeat n do (setf (current-record tree) (pop (redo-path tree))) (flip-undo-record (current-record tree)))) --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/08 01:15:33 1.1 ;;; -*- Mode: Lisp; Package: DREI-SYNTAX -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) ;;; 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. (in-package :drei-syntax) (defclass syntax (name-mixin) ((buffer :initarg :buffer :reader buffer) (command-table :initarg :command-table :initform nil :reader command-table) (%cursor-positions :accessor cursor-positions :initform nil))) (defun syntaxp (object) "Return T if `object' is an instance of a syntax, NIL otherwise." (typep object 'syntax)) (define-condition no-such-operation (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "Operation unavailable for this syntax"))) (:documentation "This condition is signaled whenever an attempt is made to execute an operation that is unavailable for the particular syntax" )) (define-condition no-expression (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No expression at point"))) (:documentation "This condition is signaled whenever an attempt is made to execute a by-experssion motion command and no expression is available." )) (defgeneric update-syntax (buffer syntax)) (defgeneric update-syntax-for-display (buffer syntax from to)) (defgeneric syntax-line-indentation (mark tab-width syntax) (:documentation "Return the correct indentation for the line containing the mark, according to the specified syntax.")) (defgeneric eval-defun (mark syntax)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax command tables. (defclass syntax-command-table (standard-command-table) () (:documentation "A syntax command table provides facilities for having frame-specific commands that do not show up when the syntax is used in other applications than the one it is supposed to. For example, the Return From Definition command should be available when Lisp syntax is used in Climacs (or another editor), but not anywhere else.")) (defgeneric additional-command-tables (editor command-table) (:method-combination append) (:documentation "Get a list of additional command tables that should be checked for commands in addition to those `command-table' inherits from. The idea is that methods are specialised to `editor', and that those methods may call the function again recursively with a new `editor' argument to provide arbitrary granularity for command-table-selection. For instance, some commands may be applicable in a situation where the editor is a pane or gadget in its own right, but not when it functions as an input-editor. In this case, a method could be defined for `application-frame' as the `editor' argument, that calls `additional-command-tables' again with whatever the \"current\" editor instance is.") (:method append (editor command-table) '())) (defmethod command-table-inherit-from ((table syntax-command-table)) "Fetch extra command tables to inherit from (using `additional-command-tables') as well as the command tables `table' actually directly inherits from." (append (additional-command-tables *application-frame* table) (call-next-method))) (defmacro define-syntax-command-table (name &rest args &key &allow-other-keys) "Define a syntax command table class with the provided name, as well as defining a CLIM command table of the same name. `Args' will be passed on to `make-command-table'. An :around method on `command-table-inherit-from' for the defined class will also be defined. This method will make sure that when an instance of the syntax command table is asked for its inherited command tables, it will return those of the defined CLIM command table, as well as those provided by methods on `additional-command-tables'. Command tables provided through `additional-command-tables' will take precence over those specified in the usual way with :inherit-from." `(progn (make-command-table ',name ,@args) (defclass ,name (syntax-command-table) ()) (defmethod command-table-inherit-from :around ((table ,name)) (append (call-next-method) '(,name) (command-table-inherit-from (find-command-table ',name)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting (defgeneric syntax-line-comment-string (syntax) (:documentation "string to use at the beginning of a line to indicate a line comment")) (defgeneric line-comment-region (syntax mark1 mark2) (:documentation "inset a line comment string at the beginning of every line in the region")) (defmethod line-comment-region (syntax mark1 mark2) (when (mark< mark2 mark1) (rotatef mark1 mark2)) (let ((mark (clone-mark mark1))) (unless (beginning-of-line-p mark) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))) (loop while (mark< mark mark2) do (insert-sequence mark (syntax-line-comment-string syntax)) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))))) (defgeneric line-uncomment-region (syntax mark1 mark2) (:documentation "inset a line comment string at the beginning of every line in the region")) (defmethod line-uncomment-region (syntax mark1 mark2) (when (mark< mark2 mark1) (rotatef mark1 mark2)) (let ((mark (clone-mark mark1))) (unless (beginning-of-line-p mark) (end-of-line mark) (unless (end-of-buffer-p mark) [666 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2006/11/08 01:15:33 1.1 [1120 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/rectangle.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/rectangle.lisp 2006/11/08 01:15:33 1.1 [1257 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/08 01:15:33 1.1 [1681 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/08 01:15:33 1.1 [2188 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/motion-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/motion-commands.lisp 2006/11/08 01:15:33 1.1 [2210 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2006/11/08 01:15:33 1.1 [2295 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 01:15:33 1.1 [5304 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/08 01:15:33 1.1 [6407 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2006/11/08 01:15:33 1.1 [6513 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/08 01:15:33 1.1 [6803 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/08 01:15:33 1.1 [6978 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring-test.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring-test.lisp 2006/11/08 01:15:33 1.1 [7096 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 01:15:33 1.1 [7680 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 01:15:33 1.1 [8031 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/08 01:15:33 1.1 [8297 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/editing-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/editing-commands.lisp 2006/11/08 01:15:33 1.1 [8331 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/08 01:15:33 1.1 [9041 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei.asd 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei.asd 2006/11/08 01:15:33 1.1 [9088 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 01:15:33 1.1 [9519 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 01:15:33 1.1 [10008 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/delegating-buffer.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/delegating-buffer.lisp 2006/11/08 01:15:33 1.1 [10080 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2006/11/08 01:15:33 1.1 [10498 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/08 01:15:33 1.1 [11224 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/08 01:15:33 1.1 [11886 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/buffer-test.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/buffer-test.lisp 2006/11/08 01:15:33 1.1 [12948 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/08 01:15:33 1.1 [13455 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/08 01:15:33 1.1 [14262 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/base-test.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/base-test.lisp 2006/11/08 01:15:33 1.1 [15544 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/abbrev.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/abbrev.lisp 2006/11/08 01:15:33 1.1 [15635 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Drei/cl-automaton
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv24994/Drei/cl-automaton Added Files: state-and-transition.lisp state-and-transition-test.lisp regexp.lisp regexp-test.lisp eqv-hash.txt eqv-hash.lisp eqv-hash-test.lisp automaton.lisp automaton.asd automaton-test.lisp automaton-test.asd automaton-test-package.lisp automaton-package.lisp Log Message: Committed Drei. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders Møller (in-package :automaton) (defconstant +min-char-code+ 0) (defconstant +max-char-code+ (1- char-code-limit)) ;;; In Allegro (for one), defconstants aren't available as values at compile ;;; time. (deftype char-code-type () `(integer 0 ,(1- char-code-limit))) (defclass state () ((accept :initform nil :accessor accept :type boolean) (transitions :accessor transitions :type generalized-hash-table) (num :initform 0 :accessor num :type fixnum) (id :accessor id :type fixnum) (next-id :allocation :class :initform -1 :accessor next-id :type fixnum))) (declaim (special *state-ht*)) (defun state-equal (s1 s2) ; for testing, assuming minimization (multiple-value-bind (se se-p) (gethash (cons s1 s2) *state-ht*) ; TODO: consider (cons s2 s1), too (if se-p se (setf (gethash (cons s1 s2) *state-ht*) t ; bound recursion temporarily (gethash (cons s1 s2) *state-ht*) (and (eq (accept s1) (accept s2)) (transitions-equal (transitions s1) (transitions s2))))))) (declaim (special *to-first*)) (defun transitions-equal (ts1 ts2) ; for testing, assuming minimization (let* ((*to-first* nil) (tss1 (sort (with-ht-collect (t1 nil) ts1 t1) #'transition<)) (tss2 (sort (with-ht-collect (t2 nil) ts2 t2) #'transition<))) (flet ((%transition-equal (t1 t2) (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) t1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) t2 (and (= minc1 minc2) (= maxc1 maxc2) (state-equal to1 to2)))))) (and (= (length tss1) (length tss2)) (loop for t1 in tss1 and t2 in tss2 always (%transition-equal t1 t2)))))) (defclass state-pair () ((s :initarg :s :accessor s :type (or null state)) (s1 :initarg :s1 :accessor s1 :type state) (s2 :initarg :s2 :accessor s2 :type state))) (defclass transition () ((minc :initarg :minc :accessor minc :type char-code-type) (maxc :initarg :maxc :accessor maxc :type char-code-type) (to :initarg :to :accessor to :type state))) (defclass state-set () ((ht :initform (make-hash-table) :initarg :ht :accessor ht :type hash-table))) (defmethod initialize-instance :after ((s state) &rest initargs) (declare (ignorable initargs)) (with-slots (transitions id next-id) s (setf transitions (make-generalized-hash-table +equalp-key-situation+) id (incf next-id)))) (defmethod initialize-instance :after ((tr transition) &rest initargs) (declare (ignorable initargs)) (with-slots (minc maxc to) tr (cond ((not minc) (assert maxc nil "MINC or MAXC required") (setf minc maxc)) ((not maxc) (assert minc nil "MINC or MAXC required") (setf maxc minc)) ((> minc maxc) (rotatef minc maxc))) (assert to nil "TO required"))) (defmethod eqv ((sp1 state-pair) (sp2 state-pair) (s (eql +equalp-key-situation+))) (and (eq (s1 sp1) (s1 sp2)) (eq (s2 sp1) (s2 sp2)))) (defmethod hash ((sp state-pair) (s (eql +equalp-key-situation+))) "Returns the hash code for state-pair SP." (the fixnum (mod (+ (sxhash (s1 sp)) (sxhash (s2 sp))) most-positive-fixnum))) (defmethod eqv ((tr1 transition) (tr2 transition) (s (eql +equalp-key-situation+))) "Returns true if transitions TR1 and TR2 have equal interval and same (eq) destination state." (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2 (and (= minc1 minc2) (= maxc1 maxc2) (eq to1 to2))))) (defmethod hash ((tr transition) (s (eql +equalp-key-situation+))) "Returns the hash code for transition TR." (with-slots (minc maxc) tr (the fixnum (mod (+ (* 2 minc) (* 3 maxc)) most-positive-fixnum)))) (defmethod clone ((tr transition)) "Returns a clone of TR." (with-slots (minc maxc to) tr (make-instance 'transition :minc minc :maxc maxc :to to))) (defmethod eqv ((ss1 state-set) (ss2 state-set) (s (eql +equalp-key-situation+))) "Returns true if state-set objects SS1 and SS2 contain the same (eql) state objects." (and (= (hash-table-count (ht ss1)) (hash-table-count (ht ss2))) (loop for st being the hash-key of (ht ss1) always (gethash st (ht ss2))))) (defmethod hash ((ss state-set) (s (eql +equalp-key-situation+))) "Returns the hash code for state-set SS." (the fixnum (mod (loop for st being the hash-key of (ht ss) sum (sxhash st)) most-positive-fixnum))) (defvar *escape-unicode-chars* nil) ; true may be useful in Slime (defun escaped-char (c) (if (or (not *escape-unicode-chars*) (and (<= #x21 c #x7e) (/= c (char-code #\\)))) (code-char c) (format nil "\\u~4,'0O" c))) (defmethod print-object ((st state) s) (with-slots (accept transitions num) st (format s "~@<state ~A [~A]: ~2I~_~@<~{~W~^ ~_~}~:>~:>" num (if accept "accept" "reject") (with-ht-collect (tr nil) transitions tr))) st) (defmethod print-object ((tr transition) s) (with-slots (minc maxc to) tr (format s "~@<~A~:[~*~;-~A~] -> ~A~:>" (escaped-char minc) (/= minc maxc) (escaped-char maxc) (num to)) tr)) (defun transition< (tr1 tr2) "Returns true if TR1 is strictly less than TR2. If *TO-FIRST* special variable is bound to true, the values of the destination states' NUM slots are compared first, followed by the intervals comparison. The intervals comparison is done as follows: the lower interval bounds are compared first, followed by reversed upper interval bounds comparisons. If *TO-FIRST* is bound to nil, the interval comparison is done first, followed by the NUM comparisons." (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2 (let ((to< (< (num to1) (num to2))) (to= (= (num to1) (num to2))) (min-rmax< (or (< minc1 minc2) (and (= minc1 minc2) (> maxc1 maxc2)))) (min-rmax= (and (= minc1 minc2) (= maxc1 maxc2)))) (if *to-first* (or to< (and to= min-rmax<)) (or min-rmax< (and min-rmax= to<))))))) (defun reset-transitions (s) (setf (transitions s) (make-generalized-hash-table +equalp-key-situation+))) (defun sstep (s c) "Returns a state reachable from S, given the input character code C." (with-ht (tr nil) (transitions s) (when (<= (minc tr) (char-code c) (maxc tr)) (return-from sstep (to tr))))) (defun add-epsilon (s to) "Adds transitions of state TO to state S. Also, if TO accepts, so does S." (when (accept to) (setf (accept s) t)) (let ((s-table (transitions s))) (with-ht (tr nil) (transitions to) (htadd s-table tr)))) (defun sorted-transition-vector (s *to-first*) "Returns a vector of all transitions of S, sorted using TRANSITION< and *TO-FIRST*." (let ((v (make-array `(,(cnt (transitions s))) :element-type '(or null transition))) (i -1)) (sort (progn (with-ht (tr nil) (transitions s) (setf (aref v (incf i)) tr)) v) #'transition<))) (defun sorted-transition-list (s *to-first*) "Returns a list of all transitions of S, sorted using TRANSITION< and *TO-FIRST*." (sort (with-ht-collect (tr nil) (transitions s) tr) #'transition<))--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition-test.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; (in-package :automaton-user) (deftest clone.transition.test-1 (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (automaton::clone t1))) (and (eqv t1 t2 +equalp-key-situation+) (eql (hash t1 +equalp-key-situation+) (hash t2 +equalp-key-situation+)))) t) (deftest transition<.test-1 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (automaton::transition< t1 t2)) t) (deftest transition<.test-2 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (setf (automaton::num (automaton::to t1)) 1) (automaton::transition< t2 t1)) t) (deftest transition<.test-2a (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (automaton::transition< t2 t1)) t) (deftest transition<.test-3 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (automaton::transition< t1 t2)) t) (deftest sstep.test-1 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (eq (automaton::sstep s #\a) s)) t) (deftest sstep.test-2 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (automaton::sstep s #\c)) nil) (deftest add-epsilon.test-1 (let* ((s1 (make-instance 'automaton::state)) (s2 (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s2))) (htadd (automaton::transitions s2) tr) (automaton::add-epsilon s1 s2) (htpresent (automaton::transitions s1) tr)) t) (deftest sorted-transition-vector.test-1 (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (equalp (automaton::sorted-transition-vector s nil) (vector t1 t2))) t) (deftest sorted-transition-list.test-1 (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (equal (automaton::sorted-transition-list s nil) (list t1 t2))) t)--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders Møller ;;; - Some comments have been copied verbatim from the original code. ;;; Regular expressions are built from the following abstract syntax: ;;; regexp ::= unionexp ;;; unionexp ::= interexp | unionexp (union) ;;; | interexp ;;; interexp ::= concatexp & interexp (intersection) [OPTIONAL] ;;; | concatexp ;;; concatexp ::= repeatexp concatexp (concatenation) ;;; | repeatexp ;;; repeatexp ::= repeatexp ? (zero or one occurrence) ;;; | repeatexp * (zero or more occurrences) ;;; | repeatexp + (one or more occurrences) ;;; | repeatexp {n} (n occurrences) ;;; | repeatexp {n,} (n or more occurrences) ;;; | repeatexp {n,m} (n to m occurrences, including both) ;;; | complexp ;;; complexp ::= ~ complexp (complement) [OPTIONAL] ;;; | charclassexp ;;; charclassexp ::= [ charclasses ] (character class) ;;; | [^ charclasses ] (negated character class) ;;; | simpleexp ;;; charclasses ::= charclass charclasses ;;; | charclass ;;; charclass ::= charexp - charexp (character range, including end-points) ;;; | charexp ;;; simpleexp ::= charexp ;;; | . (any single character) ;;; | # (the empty language) [OPTIONAL] ;;; | @ (any string) [OPTIONAL] ;;; | " <Unicode string without double-quotes> " (a string) ;;; | ( ) (the empty string) ;;; | ( unionexp ) (precedence override) ;;; | < <identifier> > (named automaton) [OPTIONAL] ;;; | <n-m> (numerical interval) [OPTIONAL] ;;; charexp ::= <Unicode character> (a single non-reserved character) ;;; | \ <Unicode character> (a single character) ;;; The productions marked [OPTIONAL] are only allowed if specified by ;;; the syntax flags passed to the string-regexp constructor. The ;;; reserved characters used in the (enabled) syntax must be escaped ;;; with backslash (\) or double-quotes ("..."). (In contrast to other ;;; regexp syntaxes, this is required also in character classes.) Be ;;; aware that dash (-) has a special meaning in charclass ;;; expressions. An identifier is a string not containing right angle ;;; bracket (>) or dash (-). Numerical intervals are specified by ;;; non-negative decimal integers and include both end points, and if ;;; n and m have the same number of digits, then the conforming ;;; strings must have that length (i.e. prefixed by 0's). (in-package :automaton) (deftype kind () '(member nil :union :concatenation :intersection :optional :repeat :repeat-min :repeat-minmax :complement :char :char-range :anychar :empty :string :anystring :automaton :interval)) (defconstant +intersection+ #x0001) ; enables intersection (&) (defconstant +complement+ #x0002) ; enables complement (~) (defconstant +empty+ #x0004) ; enables empty language (#) (defconstant +anystring+ #x0008) ; enables anystring (@) (defconstant +automaton+ #x0010) ; enables named automaton (<id>) (defconstant +interval+ #x0020) ; enables numerical intervals (n-m) (defconstant +all+ #xffff) ; enables all optional syntax (defconstant +none+ #x0000) ; enables no optional syntax (deftype flags-type () `(integer ,+none+ ,+all+)) (defclass regexp () ((kind :initform nil :initarg :kind :reader kind :type kind) (exp1 :initform nil :initarg :exp1 :reader exp1 :type (or null regexp)) (exp2 :initform nil :initarg :exp2 :reader exp2 :type (or null regexp)) (text :initform nil :initarg :text :reader text :type (or null string)) (s :initform nil :initarg :s :reader s :type (or null string)) [342 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp-test.lisp 2006/11/08 01:15:32 1.1 [592 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.txt 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.txt 2006/11/08 01:15:32 1.1 [790 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 1.1 [911 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash-test.lisp 2006/11/08 01:15:32 1.1 [1087 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 1.1 [2300 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.asd 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.asd 2006/11/08 01:15:32 1.1 [2315 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.lisp 2006/11/08 01:15:32 1.1 [2642 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.asd 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.asd 2006/11/08 01:15:32 1.1 [2657 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test-package.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test-package.lisp 2006/11/08 01:15:32 1.1 [2666 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2006/11/08 01:15:32 1.1 [2708 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Drei/Persistent
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei/Persistent In directory clnet:/tmp/cvs-serv24994/Drei/Persistent Added Files: persistent-undo.lisp persistent-buffer.lisp obinseq.lisp binseq2.lisp binseq.lisp binseq-package.lisp README Log Message: Committed Drei. --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-undo.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-undo.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; ;;; 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. ;;; Part of the Undo protocol that works with persistent buffers (in-package :drei-undo) (defclass p-undo-mixin () ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree) (undo-accumulate :initform '() :accessor undo-accumulate) (performing-undo :initform nil :accessor performing-undo))) (defclass p-undo-record (climacs-undo-record) ((contents :initarg :contents))) (defun save-p-undo-record (buffer) (unless (performing-undo buffer) (push (make-instance 'p-undo-record :buffer buffer :contents (slot-value buffer 'drei-buffer::contents)) (undo-accumulate buffer)))) (defmethod insert-buffer-object :before ((buffer p-undo-mixin) offset object) (declare (ignore offset object)) (save-p-undo-record buffer)) (defmethod insert-buffer-sequence :before ((buffer p-undo-mixin) offset seq) (declare (ignore offset seq)) (save-p-undo-record buffer)) (defmethod delete-buffer-range :before ((buffer p-undo-mixin) offset n) (declare (ignore offset n)) (save-p-undo-record buffer)) (defmethod (setf buffer-object) :before (object (buffer p-undo-mixin) offset) (declare (ignore object offset)) (save-p-undo-record buffer)) (defmethod flip-undo-record ((record p-undo-record)) (with-slots (buffer contents) record (setf (slot-value buffer 'drei-buffer::contents) contents) (drei-buffer::filter-and-update (drei-buffer::cursors buffer) #'(lambda (c) (flexichain::weak-pointer-value c buffer)) #'(lambda (wpc) (setf (cursor-pos wpc) (max 0 (min (cursor-pos wpc) (1- (size buffer)))))))))--- /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; ;;; 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. ;;; A persistent buffer uses a persistent data structure for its ;;; contents, provides cursors into contents, and contains cursors ;;; into the current contents. (in-package :drei-buffer) ;;; For now, pos contains just an integer, while it might contain a cons ;;; of two adjacent buffer elements for higher performance (with the help ;;; of buffer implementation, especially the rebalancing part). (defclass persistent-cursor () ((buffer :reader buffer :initarg :buffer) ; TODO: fix overlap with mark? (pos :accessor cursor-pos)) (:documentation "The (non-persistent) cursor into PERSISTENT-BUFFER.")) (defclass left-sticky-persistent-cursor (persistent-cursor) ()) (defclass right-sticky-persistent-cursor (persistent-cursor) ()) (defclass line-cursor-mixin () () (:documentation "Support for line-oriented buffers.")) (defclass left-sticky-line-persistent-cursor (left-sticky-persistent-cursor line-cursor-mixin) ()) (defclass right-sticky-line-persistent-cursor (right-sticky-persistent-cursor line-cursor-mixin) ()) (defmethod cursor-pos ((cursor left-sticky-persistent-cursor)) (1+ (slot-value cursor 'pos))) (defmethod (setf cursor-pos) (position (cursor left-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) (1- position))) (defmethod cursor-pos ((cursor right-sticky-persistent-cursor)) (slot-value cursor 'pos)) (defmethod (setf cursor-pos) (position (cursor right-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) position)) (defclass persistent-buffer (buffer) ((low-mark :reader low-mark) (high-mark :reader high-mark) (cursors :accessor cursors :initform nil) (modified :initform nil :reader modified-p)) (:documentation "The Climacs persistent buffer base class \(non-instantiable).")) (defmethod initialize-instance :after ((cursor left-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos (1- position)) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors)))) (defmethod initialize-instance :after ((cursor right-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos position) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors)))) (defclass binseq-buffer (persistent-buffer) ((contents :initform (list-binseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses a binary sequence for the CONTENTS slot.")) (defclass obinseq-buffer (persistent-buffer) ((contents :initform (list-obinseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses an optimized binary sequence (only non-nil atoms are allowed as elements) for the CONTENTS slot.")) (defclass binseq2-buffer (persistent-buffer) ((contents :initform (list-binseq2 nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses a binary sequence for lines and optimized binary sequences for line contents, all kept in the CONTENTS slot.")) (defclass p-mark-mixin () ((buffer :initarg :buffer :reader buffer) (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark that is used in a PERSISTENT-BUFFER.")) (defclass p-line-mark-mixin (p-mark-mixin) () (:documentation "A persistent mark mixin class that works with cursors that can efficiently work with lines.")) (defmethod backward-object ((mark p-mark-mixin) &optional (count 1)) (decf (offset mark) count)) (defmethod forward-object ((mark p-mark-mixin) &optional (count 1)) (incf (offset mark) count)) (defmethod offset ((mark p-mark-mixin)) (cursor-pos (cursor mark))) (defmethod (setf offset) (new-offset (mark p-mark-mixin)) (assert (<= 0 new-offset) () (make-condition 'motion-before-beginning :offset new-offset)) (assert (<= new-offset (size (buffer mark))) () (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) (defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) () (:documentation "A LEFT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-right-sticky-mark (right-sticky-mark p-mark-mixin) () (:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-left-sticky-line-mark (left-sticky-mark p-line-mark-mixin) () (:documentation "A LEFT-STICKY-MARK subclass with line support, suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-right-sticky-line-mark (right-sticky-mark p-line-mark-mixin) () (:documentation "A RIGHT-STICKY-MARK subclass with line support, suitable for use in a PERSISTENT-BUFFER.")) (defmethod initialize-instance :after ((mark persistent-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-left-sticky-line-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-line-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-right-sticky-line-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-line-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((buffer binseq-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) (setf high-mark (make-instance 'persistent-right-sticky-mark :buffer buffer)))) (defmethod initialize-instance :after ((buffer obinseq-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) (setf high-mark (make-instance 'persistent-right-sticky-mark :buffer buffer)))) (defmethod initialize-instance :after ((buffer binseq2-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer (setf low-mark (make-instance 'persistent-left-sticky-line-mark :buffer buffer)) (setf high-mark (make-instance 'persistent-right-sticky-line-mark :buffer buffer)))) (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'persistent-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'persistent-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-left-sticky-line-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'persistent-left-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'persistent-right-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-right-sticky-line-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'persistent-right-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'persistent-left-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod size ((buffer binseq-buffer)) (binseq-length (slot-value buffer 'contents))) (defmethod size ((buffer obinseq-buffer)) (obinseq-length (slot-value buffer 'contents))) (defmethod size ((buffer binseq2-buffer)) (binseq2-size (slot-value buffer 'contents))) (defmethod number-of-lines ((buffer persistent-buffer)) (loop for offset from 0 below (size buffer) count (eql (buffer-object buffer offset) #\Newline))) (defmethod number-of-lines ((buffer binseq2-buffer)) (let ((len (binseq2-length (slot-value buffer 'contents))) (size (size buffer))) (if (or (eql 0 size) (eq (buffer-object buffer (1- size)) #\Newline)) len (max 0 (1- len))))) ; weird? (defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (< (offset mark1) (offset mark2))) (defmethod mark< ((mark1 p-mark-mixin) (mark2 integer)) (< (offset mark1) mark2)) (defmethod mark< ((mark1 integer) (mark2 p-mark-mixin)) (< mark1 (offset mark2))) (defmethod mark<= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (<= (offset mark1) (offset mark2))) (defmethod mark<= ((mark1 p-mark-mixin) (mark2 integer)) (<= (offset mark1) mark2)) (defmethod mark<= ((mark1 integer) (mark2 p-mark-mixin)) (<= mark1 (offset mark2))) (defmethod mark= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (= (offset mark1) (offset mark2))) (defmethod mark= ((mark1 p-mark-mixin) (mark2 integer)) (= (offset mark1) mark2)) (defmethod mark= ((mark1 integer) (mark2 p-mark-mixin)) (= mark1 (offset mark2))) (defmethod mark> ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (> (offset mark1) (offset mark2))) (defmethod mark> ((mark1 p-mark-mixin) (mark2 integer)) (> (offset mark1) mark2)) (defmethod mark> ((mark1 integer) (mark2 p-mark-mixin)) (> mark1 (offset mark2))) (defmethod mark>= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (>= (offset mark1) (offset mark2))) (defmethod mark>= ((mark1 p-mark-mixin) (mark2 integer)) (>= (offset mark1) mark2)) (defmethod mark>= ((mark1 integer) (mark2 p-mark-mixin)) (>= mark1 (offset mark2))) [398 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/obinseq.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/obinseq.lisp 2006/11/08 01:15:32 1.1 [631 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq2.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq2.lisp 2006/11/08 01:15:32 1.1 [1007 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq.lisp 2006/11/08 01:15:32 1.1 [1233 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq-package.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq-package.lisp 2006/11/08 01:15:32 1.1 [1327 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/README 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/README 2006/11/08 01:15:32 1.1 [1337 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Drei/Persistent
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei/Persistent In directory clnet:/tmp/cvs-serv24888/Persistent Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/Persistent added to the repository

1 0

[mcclim-cvs] CVS mcclim/Drei/cl-automaton
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv24849/cl-automaton Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/cl-automaton added to the repository

1 0