- climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
by rstrandh＠common-lisp.net 05 Feb '05

05 Feb '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv20634/Doc Modified Files: climacs-internals.texi Log Message: Moved forward-object and backward-object to the buffer protocol. Updated buffer.lisp and base.lisp accordingly. Also added the documentation of these functions to the Texinfo documentation. Date: Sat Feb 5 08:04:07 2005 Author: rstrandh Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.10 climacs/Doc/climacs-internals.texi:1.11 --- climacs/Doc/climacs-internals.texi:1.10 Wed Feb 2 16:20:17 2005 +++ climacs/Doc/climacs-internals.texi Sat Feb 5 08:04:06 2005 @@ -157,6 +157,22 @@ the size of the buffer. @end deffn +@deffn {Generic Function} {forward-object} mark &optional (count 1) + +Move the mark forward the number of positions indicated by count. +This function could be implemented by an incf on the offset of the +mark, but many buffer implementations can implement this function much +more efficiently in a different way. +@end deffn + +@deffn {Generic Function} {backward-object} mark &optional (count 1) + +Move the mark backward the number of positions indicated by count. +This function could be implemented by a decf on the offset of the +mark, but many buffer implementations can implement this function much +more efficiently in a different way. +@end deffn + @deffn {Generic Function} {mark<} mark1 mark2 Return t if the offset of mark1 is strictly less than that of mark2.

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 05 Feb '05

05 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20634 Modified Files: base.lisp buffer.lisp packages.lisp Log Message: Moved forward-object and backward-object to the buffer protocol. Updated buffer.lisp and base.lisp accordingly. Also added the documentation of these functions to the Texinfo documentation. Date: Sat Feb 5 08:04:04 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.30 climacs/base.lisp:1.31 --- climacs/base.lisp:1.30 Sun Jan 30 20:56:53 2005 +++ climacs/base.lisp Sat Feb 5 08:04:03 2005 @@ -39,16 +39,6 @@ (loop for ,offset from ,offset1 below ,offset2 do ,@body))) -(defgeneric backward-object (mark &optional count)) - -(defmethod backward-object ((mark mark) &optional (count 1)) - (decf (offset mark) count)) - -(defgeneric forward-object (mark &optional count)) - -(defmethod forward-object ((mark mark) &optional (count 1)) - (incf (offset mark) count)) - (defun previous-line (mark &optional column) "Move a mark up one line conserving horizontal position." (unless column Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.24 climacs/buffer.lisp:1.25 --- climacs/buffer.lisp:1.24 Wed Jan 26 17:10:40 2005 +++ climacs/buffer.lisp Sat Feb 5 08:04:03 2005 @@ -86,6 +86,16 @@ (make-condition 'no-such-offset :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) +(defgeneric backward-object (mark &optional count)) + +(defmethod backward-object ((mark mark) &optional (count 1)) + (decf (offset mark) count)) + +(defgeneric forward-object (mark &optional count)) + +(defmethod forward-object ((mark mark) &optional (count 1)) + (incf (offset mark) count)) + (defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) () (:documentation "A left-sticky-mark subclass suitable for use in a standard-buffer")) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.46 climacs/packages.lisp:1.47 --- climacs/packages.lisp:1.46 Sat Feb 5 07:49:53 2005 +++ climacs/packages.lisp Sat Feb 5 08:04:03 2005 @@ -29,6 +29,7 @@ #:standard-left-sticky-mark #:standard-right-sticky-mark #:clone-mark #:no-such-offset #:size #:number-of-lines #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>= + #:forward-object #:backward-object #:beginning-of-buffer #:end-of-buffer #:beginning-of-buffer-p #:end-of-buffer-p #:beginning-of-line #:end-of-line @@ -49,7 +50,6 @@ (defpackage :climacs-base (:use :clim-lisp :climacs-buffer) (:export #:do-buffer-region - #:forward-object #:backward-object #:previous-line #:next-line #:open-line #:kill-line #:empty-line-p

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 05 Feb '05

05 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20065 Modified Files: html-syntax.lisp packages.lisp pane.lisp syntax.lisp Log Message: Implemented the new buffer-modification protocol with both update-syntax and update-syntax-for-display. Date: Sat Feb 5 07:49:53 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.2 climacs/html-syntax.lisp:1.3 --- climacs/html-syntax.lisp:1.2 Sat Feb 5 07:25:29 2005 +++ climacs/html-syntax.lisp Sat Feb 5 07:49:53 2005 @@ -181,6 +181,8 @@ (return-from find-bad-parse-tree parse-tree)))) (parse-trees state))) +(defgeneric empty-state-p (state)) + (defmethod empty-state-p (state) (maphash (lambda (key val) (declare (ignore key)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.45 climacs/packages.lisp:1.46 --- climacs/packages.lisp:1.45 Wed Feb 2 08:59:41 2005 +++ climacs/packages.lisp Sat Feb 5 07:49:53 2005 @@ -84,7 +84,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax #:basic-syntax - #:update-syntax + #:update-syntax #:update-syntax-for-display #:syntax-line-indentation #:beginning-of-paragraph #:end-of-paragraph #:forward-to-error #:backward-to-error)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.17 climacs/pane.lisp:1.18 --- climacs/pane.lisp:1.17 Wed Feb 2 08:59:41 2005 +++ climacs/pane.lisp Sat Feb 5 07:49:53 2005 @@ -464,6 +464,7 @@ (setf (full-redisplay-p pane) nil)) (adjust-cache pane)) (fill-cache pane) + (update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane)) (display-cache pane (if current-p +red+ +blue+))) (defgeneric full-redisplay (pane)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.29 climacs/syntax.lisp:1.30 --- climacs/syntax.lisp:1.29 Wed Feb 2 08:59:41 2005 +++ climacs/syntax.lisp Sat Feb 5 07:49:53 2005 @@ -27,6 +27,8 @@ (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.")) @@ -66,6 +68,10 @@ (defmethod update-syntax (buffer (syntax basic-syntax)) (declare (ignore buffer)) + nil) + +(defmethod update-syntax-for-display (buffer (syntax basic-syntax) from to) + (declare (ignore buffer from to)) nil) (defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax))

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp
by rstrandh＠common-lisp.net 05 Feb '05

05 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18556 Modified Files: html-syntax.lisp Log Message: Improvements to HTML syntax. Date: Sat Feb 5 07:25:30 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.1 climacs/html-syntax.lisp:1.2 --- climacs/html-syntax.lisp:1.1 Wed Feb 2 09:01:30 2005 +++ climacs/html-syntax.lisp Sat Feb 5 07:25:29 2005 @@ -128,25 +128,9 @@ (defparameter *html-grammar* (grammar (html -> (<html> head body </html>)) - (<html> -> (html-sym) :badness 5 :message "substituted <html>") - (</html> -> (html-sym) :badness 5 :message "substituted </html>") - (<html> -> () :badness 10 :message "missing <html> inserted") - (</html> -> () :badness 10 :message "missing </html> inserted") (head -> (<head> title </head>)) - (<head> -> (html-sym) :badness 5 :message "substituted <head>") - (</head> -> (html-sym) :badness 5 :message "substituted </head>") - (<head> -> () :badness 10 :message "missing <head> inserted") - (</head> -> () :badness 10 :message "missing </head> inserted") (title -> (<title> texts </title>)) - (<title> -> (html-sym) :badness 5 :message "substituted <title>") - (</title> -> (html-sym) :badness 5 :message "substituted </title>") - (<title> -> () :badness 10 :message "missing <title> inserted") - (</title> -> () :badness 10 :message "missing </title> inserted") (body -> (<body> texts </body>)) - (<body> -> (html-sym) :badness 5 :message "substituted <body>") - (</body> -> (html-sym) :badness 5 :message "substituted </body>") - (<body> -> () :badness 10 :message "missing <body> inserted") - (</body> -> () :badness 10 :message "missing </body> inserted") (texts -> ()) (texts -> (texts text)))) @@ -178,7 +162,11 @@ do (let ((token (lex lexer))) (push (cons (clone-mark mark) (advance-parse parser (list token) (cdar states))) - states)))))))) + states))))) + (print (find 'html (gethash (initial-state parser) (parse-trees (cdar states))) + :key #'type-of) + *query-io*) + (finish-output *query-io*)))) (defgeneric forward-to-error (point syntax)) (defgeneric backward-to-error (point syntax)) @@ -193,11 +181,31 @@ (return-from find-bad-parse-tree parse-tree)))) (parse-trees state))) +(defmethod empty-state-p (state) + (maphash (lambda (key val) + (declare (ignore key)) + (loop for parse-tree in val + do (return-from empty-state-p nil))) + (parse-trees state)) + (maphash (lambda (key val) + (declare (ignore key)) + (loop for parse-tree in val + do (return-from empty-state-p nil))) + (incomplete-items state))) + (defmethod backward-to-error (point (syntax html-syntax)) (let ((states (slot-value syntax 'states))) + ;; find the last state before point (loop until (or (null states) (mark< (caar states) point)) do (pop states)) + (when (null states) + (return-from backward-to-error "no more errors")) + (when (empty-state-p (cdar states)) + (loop for ((m1 . s1) (m2 . s2)) on states + until (not (empty-state-p s2)) + finally (setf (offset point) (offset m1))) + (return-from backward-to-error "no valid parse from this point")) (loop for (mark . state) in states for tree = (find-bad-parse-tree state) when tree

1 0

[climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
by rstrandh＠common-lisp.net 02 Feb '05

02 Feb '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv10569 Modified Files: climacs-internals.texi Log Message: Fixing the syntax protocol according to the IRC discuccion with Christophe Rhodes. Date: Wed Feb 2 16:20:18 2005 Author: rstrandh Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.9 climacs/Doc/climacs-internals.texi:1.10 --- climacs/Doc/climacs-internals.texi:1.9 Sat Jan 22 06:15:50 2005 +++ climacs/Doc/climacs-internals.texi Wed Feb 2 16:20:17 2005 @@ -601,27 +601,40 @@ particular point beyond which the structure of the buffer does not need to be known. -There are two situations where updating might be needed: +There are three situations where updating might be needed: @itemize @bullet -@item before redisplay is about to show the contents of part of the -buffer in a pane. +@item once, before any panes are displayed to inform the syntax module +that some part of the buffer has been altered, +@item once for each pane on display, before redisplay is about to show +the contents of part of the buffer in a pane to inform the syntax +module that its syntax must be valid in the particular region on +display, @item as a result of a command that exploits the syntactic entities of the buffer contents. @end itemize The first case is handled by the redisplay invoking the following -generic function before proceeding to display the buffer contents in a -pane: +generic function: -@deffn {Generic Function} {update-syntax} buffer syntax mark +@deffn {Generic Function} {update-syntax} buffer syntax Inform the syntax module that it must update its view of the buffer -contents up to the point indicated by the mark. It is acceptable to -pass an offset instead of the mark. +The low-mark and the high-mark of the buffer indicate what region has +been updated. It is acceptable to pass an offset instead of the mark. @end deffn -The second case is handled by the syntax module itself when needed in +The second case is handled by the following generic function: + +@deffn {Generic Function} {update-syntax-for-display} buffer syntax from to + +Inform the syntax module that it must update its syntactic analysis to +cover the region between the two marks from and to. It is acceptable +to pass and offset instead of a mark for either or both of the last +two arguments. +@end deffn + +The third case is handled by the syntax module itself when needed in order to correctly compute the effects of a command. It is important to realize that the syntax module is not directly

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp
by rstrandh＠common-lisp.net 02 Feb '05

02 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19383 Added Files: html-syntax.lisp Log Message: Implemented an embryonic html-syntax module that uses the incremental Earley parser. Implemented a command (backward-to-error) to illustrate how the module can be used. I am not happy with my syntax yet, though. It reports too many errors. Date: Wed Feb 2 09:01:30 2005 Author: rstrandh

1 0

[climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 02 Feb '05

02 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19199 Modified Files: climacs.asd gui.lisp packages.lisp pane.lisp syntax.lisp Log Message: Fixed the display-message function so that it actually displays a message in the minibuffer. Implemented an incremental Earley parser for the syntax module. Date: Wed Feb 2 08:59:41 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.16 climacs/climacs.asd:1.17 --- climacs/climacs.asd:1.16 Wed Jan 26 17:10:40 2005 +++ climacs/climacs.asd Wed Feb 2 08:59:41 2005 @@ -61,6 +61,7 @@ "abbrev" "syntax" "text-syntax" + "html-syntax" "kill-ring" "undo" "pane" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.105 climacs/gui.lisp:1.106 --- climacs/gui.lisp:1.105 Sun Jan 30 23:17:30 2005 +++ climacs/gui.lisp Wed Feb 2 08:59:41 2005 @@ -77,6 +77,7 @@ info-pane))) (int (make-pane 'minibuffer-pane :width 900 :height 20 :max-height 20 :min-height 20 + :display-function 'display-minibuffer :scroll-bars nil))) (:layouts (default @@ -85,6 +86,18 @@ int))) (:top-level (climacs-top-level))) +(defparameter *message* nil) + +(defun display-message (format-string &rest format-args) + (setf *message* + (apply #'format nil format-string format-args))) + +(defun display-minibuffer (frame pane) + (declare (ignore frame)) + (unless (null *message*) + (princ *message* pane) + (setf *message* nil))) + (defmacro current-window () ; shouldn't this be an inlined function? --amb `(car (windows *application-frame*))) @@ -107,9 +120,6 @@ (let ((frame (make-application-frame 'climacs))) (run-frame-top-level frame))) -(defun display-message (format-string &rest format-args) - (apply #'format *standard-input* format-string format-args)) - (defun display-info (frame pane) (declare (ignore frame)) (with-slots (climacs-pane) pane @@ -649,7 +659,7 @@ (pane (current-window))) (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) - (setf (syntax buffer) (make-instance 'basic-syntax)) + (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer)) ;; Don't want to create the file if it doesn't exist. (when (probe-file filename) (with-open-file (stream filename :direction :input) @@ -722,7 +732,7 @@ (let ((buffer (accept 'buffer :prompt "Switch to buffer"))) (setf (buffer (current-window)) buffer) - (setf (syntax buffer) (make-instance 'basic-syntax)) + (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer)) (beginning-of-buffer (point (current-window))) (full-redisplay (current-window)))) @@ -800,7 +810,8 @@ (let* ((pane (current-window)) (buffer (buffer pane))) (setf (syntax buffer) - (make-instance (accept 'syntax :prompt "Set Syntax"))) + (make-instance (accept 'syntax :prompt "Set Syntax") + :buffer buffer)) (setf (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)))) @@ -1242,6 +1253,18 @@ (point (point pane)) (syntax (syntax (buffer pane)))) (end-of-paragraph point syntax))) + +(define-named-command com-backward-to-error () + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (display-message "~a" (backward-to-error point syntax)))) + +(define-named-command com-forward-to-error () + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (display-message "~a" (forward-to-error point syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.44 climacs/packages.lisp:1.45 --- climacs/packages.lisp:1.44 Sun Jan 30 23:17:31 2005 +++ climacs/packages.lisp Wed Feb 2 08:59:41 2005 @@ -86,7 +86,8 @@ #:basic-syntax #:update-syntax #:syntax-line-indentation - #:beginning-of-paragraph #:end-of-paragraph)) + #:beginning-of-paragraph #:end-of-paragraph + #:forward-to-error #:backward-to-error)) (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.16 climacs/pane.lisp:1.17 --- climacs/pane.lisp:1.16 Sun Jan 30 23:17:31 2005 +++ climacs/pane.lisp Wed Feb 2 08:59:41 2005 @@ -167,11 +167,15 @@ (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ;PB ((needs-saving :initform nil :accessor needs-saving) - (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) + (syntax :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t :accessor indent-tabs-mode)) (:default-initargs :name "*scratch*")) +(defmethod initialize-instance :after ((buffer climacs-buffer) &rest args) + (declare (ignore args)) + (with-slots (syntax) buffer + (setf syntax (make-instance 'basic-syntax :buffer buffer)))) (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.28 climacs/syntax.lisp:1.29 --- climacs/syntax.lisp:1.28 Tue Jan 18 00:10:24 2005 +++ climacs/syntax.lisp Wed Feb 2 08:59:41 2005 @@ -22,7 +22,8 @@ (in-package :climacs-syntax) -(defclass syntax (name-mixin) ()) +(defclass syntax (name-mixin) + ((buffer :initarg :buffer))) (defgeneric update-syntax (buffer syntax)) @@ -70,3 +71,217 @@ (defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax)) (declare (ignore mark tab-width)) 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Incremental Earley parser + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; grammar + +(defclass rule () + ((left-hand-side :initarg :left-hand-side :reader left-hand-side) + (right-hand-side :initarg :right-hand-side :reader right-hand-side) + (symbols :initarg :symbols :reader symbols))) + +(defclass grammar () + ((rules :initarg :rules :reader rules))) + +(defmacro grammar (&body body) + (labels ((var-of (arg) + (if (symbolp arg) + arg + (car arg))) + (sym-of (arg) + (cond ((symbolp arg) arg) + ((= (length arg) 3) (cadr arg)) + ((symbolp (cadr arg)) (cadr arg)) + (t (car arg)))) + (test-of (arg) + (cond ((symbolp arg) t) + ((= (length arg) 3) (caddr arg)) + ((symbolp (cadr arg)) t) + (t (cadr arg)))) + (build-rule (arglist body) + (if (null arglist) + body + (let ((arg (car arglist))) + `(lambda (,(var-of arg)) + (when (and (typep ,(var-of arg) ',(sym-of arg)) + ,(test-of arg)) + ,(build-rule (cdr arglist) body)))))) + (make-rule (rule) + `(make-instance 'rule + :left-hand-side ',(car rule) + :right-hand-side + ,(build-rule (caddr rule) + (if (or (= (length rule) 3) + (symbolp (cadddr rule))) + `(make-instance ',(car rule) ,@(cdddr rule)) + `(progn ,@(cdddr rule)))) + :symbols ,(coerce (mapcar #'sym-of (caddr rule)) 'vector)))) + `(make-instance 'grammar + :rules (list ,@(mapcar #'make-rule body))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; parser + +(defclass parser () + ((grammar :initarg :grammar) + (target :initarg :target :reader target) + (initial-state :reader initial-state) + (lexer :initarg :lexer))) + +(defclass rule-item () ()) + +(defclass incomplete-item (rule-item) + ((rule :initarg :rule :reader rule) + (dot-position :initarg :dot-position :reader dot-position) + (parse-trees :initarg :parse-trees :reader parse-trees) + (suffix :initarg :suffix :reader suffix))) + +(defmethod print-object ((item incomplete-item) stream) + (format stream "[~a ->" (left-hand-side (rule item))) + (loop for i from 0 below (dot-position item) + do (format stream " ~a" (aref (symbols (rule item)) i))) + (format stream " *") + (loop for i from (dot-position item) below (length (symbols (rule item))) + do (format stream " ~a" (aref (symbols (rule item)) i))) + (format stream "]")) + +(defclass complete-item (rule-item) + ((parse-tree :initarg :parse-tree :reader parse-tree))) + +(defmethod print-object ((item complete-item) stream) + (format stream "[~a]" (parse-tree item))) + +(defgeneric derive-item (prev-item parse-tree)) + +(defmethod derive-item ((prev-item incomplete-item) parse-tree) + (let ((remaining (funcall (suffix prev-item) parse-tree))) + (cond ((null remaining) + nil) + ((functionp remaining) + (make-instance 'incomplete-item + :rule (rule prev-item) + :dot-position (1+ (dot-position prev-item)) + :parse-trees (cons parse-tree (parse-trees prev-item)) + :suffix remaining)) + (t + (make-instance 'complete-item + :parse-tree remaining))))) + +(defgeneric item-equal (item1 item2)) + +(defgeneric parse-tree-equal (tree1 tree2)) + +(defmethod item-equal ((item1 rule-item) (item2 rule-item)) + nil) + +(defmethod item-equal ((item1 incomplete-item) (item2 incomplete-item)) + (and (eq (rule item1) (rule item2)) + (eq (length (parse-trees item1)) (length (parse-trees item2))) + (every #'parse-tree-equal (parse-trees item1) (parse-trees item2)))) + +(defmethod parse-tree-equal (tree1 tree2) + (eq (class-of tree1) (class-of tree2))) + +(defgeneric parse-tree-better (tree1 tree2)) + +(defmethod parse-tree-better (tree1 tree2) + nil) + +(defclass parser-state () + ((grammar :initarg :grammar :reader state-grammar) + (incomplete-items :initform (make-hash-table :test #'eq) + :reader incomplete-items) + (parse-trees :initform (make-hash-table :test #'eq) + :reader parse-trees))) + +(defun map-over-incomplete-items (state fun) + (maphash (lambda (key incomplete-items) + (loop for incomplete-item in incomplete-items + do (funcall fun key incomplete-item))) + (incomplete-items state))) + +(defgeneric handle-item (item orig-state to-state)) + +(defun potentially-handle-parse-tree (parse-tree from-state to-state) + (let ((parse-trees (parse-trees to-state))) + (flet ((handle-parse-tree () + (map-over-incomplete-items from-state + (lambda (orig-state incomplete-item) + (handle-item (derive-item incomplete-item parse-tree) + orig-state to-state))))) + (cond ((find parse-tree (gethash from-state parse-trees) + :test #'parse-tree-better) + (setf (gethash from-state parse-trees) + (cons parse-tree + (remove parse-tree (gethash from-state parse-trees) + :test #'parse-tree-better))) + (handle-parse-tree)) + ((find parse-tree (gethash from-state parse-trees) + :test (lambda (x y) (or (parse-tree-better y x) (parse-tree-equal y x)))) + nil) + (t (push parse-tree (gethash from-state parse-trees)) + (handle-parse-tree)))))) + +(defmethod handle-item ((item (eql nil)) orig-state to-state) + nil) + +(defmethod handle-item ((item incomplete-item) orig-state to-state) + (cond ((find item (gethash orig-state (incomplete-items to-state)) + :test #'item-equal) + nil) + (t + (push item (gethash orig-state (incomplete-items to-state))) + (loop for rule in (rules (state-grammar to-state)) + do (when (let ((sym1 (aref (symbols (rule item)) (dot-position item))) + (sym2 (left-hand-side rule))) + (or (subtypep sym1 sym2) (subtypep sym2 sym1))) + (handle-item (if (functionp (right-hand-side rule)) + (make-instance 'incomplete-item + :rule rule + :dot-position 0 + :parse-trees '() + :suffix (right-hand-side rule)) + (make-instance 'complete-item + :parse-tree (right-hand-side rule))) + to-state to-state))) + (loop for parse-tree in (gethash to-state (parse-trees to-state)) + do (handle-item (derive-item item parse-tree) + to-state to-state))))) + +(defmethod handle-item ((item complete-item) orig-state to-state) + (potentially-handle-parse-tree (parse-tree item) orig-state to-state)) + +(defmethod initialize-instance :after ((parser parser) &rest args) + (declare (ignore args)) + (with-slots (grammar initial-state) parser + (setf initial-state (make-instance 'parser-state :grammar grammar)) + (loop for rule in (rules grammar) + do (when (let ((sym (left-hand-side rule))) + (or (subtypep (target parser) sym) + (subtypep sym (target parser)))) + (handle-item (if (functionp (right-hand-side rule)) + (make-instance 'incomplete-item + :rule rule + :dot-position 0 + :parse-trees '() + :suffix (right-hand-side rule)) + (make-instance 'complete-item + :parse-tree (right-hand-side rule))) + initial-state initial-state))))) + +(defun advance-parse (parser tokens state) + (with-slots (grammar) parser + (let ((new-state (make-instance 'parser-state :grammar grammar))) + (loop for token in tokens + do (potentially-handle-parse-tree token state new-state)) + new-state))) + +(defclass lexer () ()) + +(defgeneric lex (lexer))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
by mvilleneuve＠common-lisp.net 30 Jan '05

30 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30608 Modified Files: gui.lisp packages.lisp pane.lisp Log Message: Fixed bad isearch behaviour when searching after a failure Date: Sun Jan 30 14:17:31 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.104 climacs/gui.lisp:1.105 --- climacs/gui.lisp:1.104 Sun Jan 30 11:56:53 2005 +++ climacs/gui.lisp Sun Jan 30 14:17:30 2005 @@ -1031,7 +1031,8 @@ (list (make-instance 'isearch-state :search-string "" :search-mark (clone-mark point) - :search-forward-p forwardp))) + :search-forward-p forwardp + :search-success-p t))) (simple-command-loop 'isearch-climacs-table (isearch-mode pane) ((setf (isearch-mode pane) nil))))) @@ -1047,18 +1048,19 @@ mark2 string :test #'object-equal))) - (cond (success - (setf (offset point) (offset mark2) - (offset mark) (if forwardp - (- (offset mark2) (length string)) - (+ (offset mark2) (length string)))) - (push (make-instance 'isearch-state - :search-string string - :search-mark mark - :search-forward-p forwardp) - (isearch-states pane))) - (t - (beep)))))) + (when success + (setf (offset point) (offset mark2) + (offset mark) (if forwardp + (- (offset mark2) (length string)) + (+ (offset mark2) (length string))))) + (push (make-instance 'isearch-state + :search-string string + :search-mark mark + :search-forward-p forwardp + :search-success-p success) + (isearch-states pane)) + (unless success + (beep))))) (define-named-command com-isearch-mode-forward () (isearch-command-loop (current-window) t)) @@ -1084,6 +1086,9 @@ (beep)) (t (pop (isearch-states pane)) + (loop until (endp (rest (isearch-states pane))) + until (search-success-p (first (isearch-states pane))) + do (pop (isearch-states pane))) (let ((state (first (isearch-states pane)))) (setf (offset (point pane)) (if (search-forward-p state) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.43 climacs/packages.lisp:1.44 --- climacs/packages.lisp:1.43 Sun Jan 30 11:56:53 2005 +++ climacs/packages.lisp Sun Jan 30 14:17:31 2005 @@ -111,7 +111,8 @@ #:tab-space-count #:indent-tabs-mode #:auto-fill-mode #:auto-fill-column - #:isearch-state #:search-string #:search-mark #:search-forward-p + #:isearch-state #:search-string #:search-mark + #:search-forward-p #:search-success-p #:isearch-mode #:isearch-states #:isearch-previous-string #:query-replace-state #:string1 #:string2 #:query-replace-mode Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.15 climacs/pane.lisp:1.16 --- climacs/pane.lisp:1.15 Wed Jan 26 14:49:47 2005 +++ climacs/pane.lisp Sun Jan 30 14:17:31 2005 @@ -142,7 +142,8 @@ (defclass isearch-state () ((search-string :initarg :search-string :accessor search-string) (search-mark :initarg :search-mark :accessor search-mark) - (search-forward-p :initarg :search-forward-p :accessor search-forward-p))) + (search-forward-p :initarg :search-forward-p :accessor search-forward-p) + (search-success-p :initarg :search-success-p :accessor search-success-p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
by mvilleneuve＠common-lisp.net 30 Jan '05

30 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23067 Modified Files: base.lisp gui.lisp packages.lisp Log Message: Made query-replace respect the case of replaced strings. Date: Sun Jan 30 11:56:54 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.29 climacs/base.lisp:1.30 --- climacs/base.lisp:1.29 Sat Jan 29 05:16:25 2005 +++ climacs/base.lisp Sun Jan 30 11:56:53 2005 @@ -219,6 +219,29 @@ ;;; ;;; Character case +(defun buffer-region-case (buffer offset1 offset2) + (let ((possibly-uppercase t) + (possibly-lowercase t) + (possibly-capitalized t)) + (do-buffer-region (object offset buffer offset1 offset2) + (unless (characterp object) + (return-from buffer-region-case nil)) + (when (lower-case-p object) + (setf possibly-uppercase nil)) + (when (upper-case-p object) + (setf possibly-lowercase nil)) + (when (plusp offset) + (let ((previous-object (buffer-object buffer (1- offset)))) + (when (and (characterp previous-object) + (if (constituentp previous-object) + (upper-case-p object) + (lower-case-p object))) + (setf possibly-capitalized nil))))) + (cond (possibly-uppercase :upper-case) + (possibly-lowercase :lower-case) + (possibly-capitalized :capitalized) + (t nil)))) + ;;; I'd rather have update-buffer-range methods spec. on buffer for this, ;;; for performance and history-size reasons --amb (defun downcase-buffer-region (buffer offset1 offset2) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.103 climacs/gui.lisp:1.104 --- climacs/gui.lisp:1.103 Fri Jan 28 23:05:42 2005 +++ climacs/gui.lisp Sun Jan 30 11:56:53 2005 @@ -1120,9 +1120,13 @@ ;;; Query replace (defun query-replace-find-next-match (mark string) - (let ((offset-before (offset mark))) - (search-forward mark string) - (/= (offset mark) offset-before))) + (flet ((object-equal (x y) + (and (characterp x) + (characterp y) + (char-equal x y)))) + (let ((offset-before (offset mark))) + (search-forward mark string :test #'object-equal) + (/= (offset mark) offset-before)))) (define-named-command com-query-replace () (let* ((string1 (accept 'string :prompt "Query replace")) @@ -1143,11 +1147,21 @@ (define-named-command com-query-replace-replace () (let* ((pane (current-window)) (point (point pane)) + (buffer (buffer pane)) (state (query-replace-state pane)) (string1-length (length (string1 state)))) (backward-object point string1-length) - (delete-range point string1-length) - (insert-sequence point (string2 state)) + (let* ((offset1 (offset point)) + (offset2 (+ offset1 string1-length)) + (region-case (buffer-region-case buffer offset1 offset2))) + (delete-range point string1-length) + (insert-sequence point (string2 state)) + (setf offset2 (+ offset1 (length (string2 state)))) + (finish-output *error-output*) + (case region-case + (:upper-case (upcase-buffer-region buffer offset1 offset2)) + (:lower-case (downcase-buffer-region buffer offset1 offset2)) + (:capitalized (capitalize-buffer-region buffer offset1 offset2)))) (unless (query-replace-find-next-match point (string1 state)) (setf (query-replace-mode pane) nil)))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.42 climacs/packages.lisp:1.43 --- climacs/packages.lisp:1.42 Wed Jan 26 14:49:47 2005 +++ climacs/packages.lisp Sun Jan 30 11:56:53 2005 @@ -59,7 +59,10 @@ #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word - #:upcase-region #:downcase-region #:capitalize-region + #:buffer-region-case + #:upcase-buffer-region #:upcase-region + #:downcase-buffer-region #:downcase-region + #:capitalize-buffer-region #:capitalize-region #:upcase-word #:downcase-word #:capitalize-word #:tabify-region #:untabify-region #:indent-line

1 0

[climacs-cvs] CVS update: climacs/Persistent/persistent-base-test.lisp
by abakic＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv20755/Persistent Modified Files: persistent-base-test.lisp Log Message: Test updates. Date: Sat Jan 29 14:23:17 2005 Author: abakic Index: climacs/Persistent/persistent-base-test.lisp diff -u climacs/Persistent/persistent-base-test.lisp:1.3 climacs/Persistent/persistent-base-test.lisp:1.4 --- climacs/Persistent/persistent-base-test.lisp:1.3 Fri Jan 28 10:47:34 2005 +++ climacs/Persistent/persistent-base-test.lisp Sat Jan 29 14:23:14 2005 @@ -622,10 +622,10 @@ (deftest binseq-buffer-downcase-buffer-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "CLi mac5") + (climacs-base::downcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli mac5") + "Cli mac5") (deftest binseq-buffer-downcase-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) @@ -658,21 +658,21 @@ (deftest binseq-buffer-downcase-word.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "CLI MA CS") + (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") (let ((m (make-instance 'persistent-right-sticky-mark :buffer buffer :offset 0))) (downcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "cli ma cs" 9) + "cli ma cs CLIMACS" 9) (deftest binseq-buffer-upcase-buffer-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "cli mac5") + (climacs-base::upcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "CLI MAC5") + "cLI MAC5") (deftest binseq-buffer-upcase-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) @@ -705,21 +705,21 @@ (deftest binseq-buffer-upcase-word.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs") + (insert-buffer-sequence buffer 0 "cli ma cs climacs") (let ((m (make-instance 'persistent-right-sticky-mark :buffer buffer :offset 0))) (upcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "CLI MA CS" 9) + "CLI MA CS climacs" 9) (deftest binseq-buffer-capitalize-buffer-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-sequence buffer 0 "cli ma cs") (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli Ma Cs") + "cLi Ma Cs") (deftest binseq-buffer-capitalize-buffer-region.test-2 (let ((buffer (make-instance 'binseq-buffer))) @@ -759,14 +759,14 @@ (deftest binseq-buffer-capitalize-word.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs") + (insert-buffer-sequence buffer 0 "cli ma cs climacs") (let ((m (make-instance 'persistent-right-sticky-mark :buffer buffer :offset 0))) (capitalize-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "Cli Ma Cs" 9) + "Cli Ma Cs climacs" 9) ;;; obinseq tests @@ -1370,10 +1370,10 @@ (deftest obinseq-buffer-downcase-buffer-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "CLi mac5") + (climacs-base::downcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli mac5") + "Cli mac5") (deftest obinseq-buffer-downcase-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) @@ -1417,10 +1417,10 @@ (deftest obinseq-buffer-upcase-buffer-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "cli mac5") + (climacs-base::upcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "CLI MAC5") + "cLI MAC5") (deftest obinseq-buffer-upcase-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) @@ -1467,7 +1467,7 @@ (insert-buffer-sequence buffer 0 "cli ma cs") (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli Ma Cs") + "cLi Ma Cs") (deftest obinseq-buffer-capitalize-buffer-region.test-2 (let ((buffer (make-instance 'obinseq-buffer)))

1 0