climacs-cvs May 2005

climacs-cvs@common-lisp.net

4 participants
64 discussions

[climacs-cvs] CVS update: climacs/buffer.lisp climacs/gui.lisp
by crhodes＠common-lisp.net 10 May '05

10 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19641 Modified Files: buffer.lisp gui.lisp Log Message: Restore the (in-package ...) and the copyright information to buffer.lisp The buffer accessor is FILEPATH, not FILENAME Date: Tue May 10 18:28:54 2005 Author: crhodes Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.30 climacs/buffer.lisp:1.31 --- climacs/buffer.lisp:1.30 Mon May 9 16:13:44 2005 +++ climacs/buffer.lisp Tue May 10 18:28:53 2005 @@ -1,3 +1,35 @@ +;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*- + +;;; (c) copyright 2004-2005 by +;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2004-2005 by +;;; Elliott Johnson (ejohnson at fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at 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. + +;;; A not-so-stupid implementation of the buffer protocol. This +;;; implementation serves two purposes: First, so that higher-level +;;; functionality can be built on top of a working implementation of +;;; the buffer protocol, and second, to use as a comparison for +;;; testing a new, better implementation of the buffer protocol. + +(in-package :climacs-buffer) + (defclass buffer () () (:documentation "A base class for all buffers. A buffer conceptually contains a large array of arbitrary objects. Lines of objects are separated by Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.137 climacs/gui.lisp:1.138 --- climacs/gui.lisp:1.137 Mon May 9 16:47:45 2005 +++ climacs/gui.lisp Tue May 10 18:28:53 2005 @@ -742,14 +742,14 @@ (define-named-command (com-quit) () (loop for buffer in (buffers *application-frame*) when (and (needs-saving buffer) - (filename buffer) + (filepath buffer) (handler-case (accept 'boolean :prompt (format nil "Save buffer: ~a ?" (name buffer))) (error () (progn (beep) (display-message "Invalid answer") (return-from com-quit nil))))) do (save-buffer buffer)) - (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filename buffer))) + (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer))) (buffers *application-frame*)) (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") (error () (progn (beep)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp
by rstrandh＠common-lisp.net 09 May '05

09 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17603 Modified Files: gui.lisp pane.lisp Log Message: Patch from John Q Splittist making the behavior of points in panes more natural. Date: Mon May 9 16:47:45 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.136 climacs/gui.lisp:1.137 --- climacs/gui.lisp:1.136 Mon May 9 16:13:44 2005 +++ climacs/gui.lisp Mon May 9 16:47:45 2005 @@ -704,6 +704,7 @@ :prompt "Find File")) (buffer (make-instance 'climacs-buffer)) (pane (current-window))) + (setf (point (buffer pane)) (clone-mark (point pane))) (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance @@ -787,6 +788,7 @@ (let ((buffer (accept 'buffer :prompt "Switch to buffer")) (pane (current-window))) + (setf (point (buffer pane)) (clone-mark (point pane))) (setf (buffer pane) buffer) (full-redisplay pane))) @@ -966,7 +968,8 @@ (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) (constellation-root (parent3 current-window))) - (setf (buffer new-pane) (buffer current-window) + (setf (point (buffer current-window)) (clone-mark (point current-window)) + (buffer new-pane) (buffer current-window) (auto-fill-mode new-pane) (auto-fill-mode current-window) (auto-fill-column new-pane) (auto-fill-column current-window)) (push new-pane (windows *application-frame*)) @@ -980,7 +983,8 @@ (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) (constellation-root (parent3 current-window))) - (setf (buffer new-pane) (buffer current-window) + (setf (point (buffer current-window)) (clone-mark (point current-window)) + (buffer new-pane) (buffer current-window) (auto-fill-mode new-pane) (auto-fill-mode current-window) (auto-fill-column new-pane) (auto-fill-column current-window)) (push new-pane (windows *application-frame*)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.25 climacs/pane.lisp:1.26 --- climacs/pane.lisp:1.25 Sat May 7 00:32:28 2005 +++ climacs/pane.lisp Mon May 9 16:47:45 2005 @@ -196,6 +196,7 @@ (defclass climacs-buffer (delegating-buffer filepath-mixin name-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :accessor syntax) + (point :initform nil :initarg :point :accessor point) (indent-tabs-mode :initarg indent-tabs-mode :initform t :accessor indent-tabs-mode)) (:default-initargs @@ -204,13 +205,14 @@ (defmethod initialize-instance :after ((buffer climacs-buffer) &rest args) (declare (ignore args)) - (with-slots (syntax) buffer + (with-slots (syntax point) buffer (setf syntax (make-instance - 'basic-syntax :buffer (implementation buffer))))) + 'basic-syntax :buffer (implementation buffer)) + point (clone-mark (low-mark buffer) :right)))) (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) - (point :initform nil :initarg :point :reader point) + (point :initform nil :initarg :point :accessor point) (mark :initform nil :initarg :mark :accessor mark) (top :reader top) (bot :reader bot) @@ -240,6 +242,7 @@ (defmethod initialize-instance :after ((pane climacs-pane) &rest args) (declare (ignore args)) (with-slots (buffer point mark) pane + (setf point (clone-mark (point buffer))) (when (null point) (setf point (clone-mark (low-mark buffer) :right))) (when (null mark) @@ -256,7 +259,7 @@ (defmethod (setf buffer) :after (buffer (pane climacs-pane)) (with-slots (point mark top bot) pane - (setf point (clone-mark (low-mark buffer) :right) + (setf point (clone-mark (point buffer)) mark (clone-mark (low-mark buffer) :right) top (clone-mark (low-mark buffer) :left) bot (clone-mark (high-mark buffer) :right))))

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp climacs/gui.lisp
by rstrandh＠common-lisp.net 09 May '05

09 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14014 Modified Files: buffer.lisp gui.lisp Log Message: Patch from John Q Splittist making Climacs not ask about saving buffers without associated file names. Date: Mon May 9 16:13:45 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.29 climacs/buffer.lisp:1.30 --- climacs/buffer.lisp:1.29 Fri Feb 25 08:11:24 2005 +++ climacs/buffer.lisp Mon May 9 16:13:44 2005 @@ -1,35 +1,3 @@ -;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*- - -;;; (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) - -;;; 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 not-so-stupid implementation of the buffer protocol. This -;;; implementation serves two purposes: First, so that higher-level -;;; functionality can be built on top of a working implementation of -;;; the buffer protocol, and second, to use as a comparison for -;;; testing a new, better implementation of the buffer protocol. - -(in-package :climacs-buffer) - (defclass buffer () () (:documentation "A base class for all buffers. A buffer conceptually contains a large array of arbitrary objects. Lines of objects are separated by Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.135 climacs/gui.lisp:1.136 --- climacs/gui.lisp:1.135 Sun May 8 22:16:32 2005 +++ climacs/gui.lisp Mon May 9 16:13:44 2005 @@ -741,13 +741,14 @@ (define-named-command (com-quit) () (loop for buffer in (buffers *application-frame*) when (and (needs-saving buffer) + (filename buffer) (handler-case (accept 'boolean :prompt (format nil "Save buffer: ~a ?" (name buffer))) (error () (progn (beep) (display-message "Invalid answer") (return-from com-quit nil))))) do (save-buffer buffer)) - (when (or (notany #'needs-saving + (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filename buffer))) (buffers *application-frame*)) (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") (error () (progn (beep)

1 0

[climacs-cvs] CVS update: climacs/cl-syntax.lisp
by rstrandh＠common-lisp.net 09 May '05

09 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13872 Modified Files: cl-syntax.lisp Log Message: Improvements to CL syntax in the form of a patch from Andreas Fuchs. Date: Mon May 9 16:09:30 2005 Author: rstrandh Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.12 climacs/cl-syntax.lisp:1.13 --- climacs/cl-syntax.lisp:1.12 Fri Apr 29 22:10:32 2005 +++ climacs/cl-syntax.lisp Mon May 9 16:09:30 2005 @@ -53,6 +53,8 @@ (defclass paren-close (cl-lexeme) ()) (defclass comma (cl-lexeme) ()) (defclass quote-symbol (cl-lexeme) ()) +(defclass colon (cl-lexeme) ()) +(defclass ampersand (cl-lexeme) ()) (defclass double-quote (cl-lexeme) ()) (defclass hex (cl-lexeme) ()) (defclass pipe (cl-lexeme) ()) @@ -78,6 +80,8 @@ (#\, (fo) (make-instance 'comma)) (#\" (fo) (make-instance 'double-quote)) (#\' (fo) (make-instance 'quote-symbol)) + (#\: (fo) (make-instance 'colon)) + (#\& (fo) (make-instance 'ampersand)) (#\# (fo) (make-instance 'hex)) (#\| (fo) (make-instance 'pipe)) (#\` (fo) (make-instance 'backquote)) @@ -115,7 +119,7 @@ (defun neutralcharp (var) (and (characterp var) (not (member var '(#$ #$ #\, #\" #\' #\# #\| #\` #\@ #\; #\\ - #\/ #\. #\+ #\- #\Newline #\Space #\Tab) + #\: #\/ #\Newline #\Space #\Tab) :test #'char=)))) @@ -783,6 +787,98 @@ (display-parse-tree start syntax pane)) (display-parse-tree item syntax pane))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Qualified symbols + +;; XXX: There's a bit of duplication going on here. I'm not sure if +;; that could be reduced by clever inheritance. But then, it's only +;; OAOOM. + +(defclass qualified-symbol (cl-entry) + ((package-name :initarg :package-name) + (colon1 :initarg :colon1) + (colon2 :initarg :colon2) + (symbol-name :initarg :symbol-name))) + +(defclass qualified-exported-symbol (cl-entry) + ((package-name :initarg :package-name) + (colon :initarg :colon) + (symbol-name :initarg :symbol-name))) + +(add-cl-rule (qualified-symbol -> ((package-name default-item) + (colon1 colon (= (end-offset package-name) + (start-offset colon1))) + (colon2 colon (= (end-offset colon1) + (start-offset colon2))) + (symbol-name default-item (= (end-offset colon2) + (start-offset symbol-name)))) + :package-name package-name + :colon1 colon1 + :colon2 colon2 + :symbol-name symbol-name)) + +(add-cl-rule (qualified-exported-symbol -> ((package-name default-item) + (colon colon (= (end-offset package-name) + (start-offset colon))) + (symbol-name default-item (= (end-offset colon) + (start-offset symbol-name)))) + :package-name package-name + :colon colon + :symbol-name symbol-name)) + +(defmethod display-parse-tree ((entity qualified-symbol) (syntax cl-syntax) pane) + (with-slots (package-name colon1 colon2 symbol-name) entity + (with-drawing-options (pane :text-style (make-text-style :fix :bold nil) :ink +purple+) + (display-parse-tree package-name syntax pane) + (display-parse-tree colon1 syntax pane) + (display-parse-tree colon2 syntax pane)) + (display-parse-tree symbol-name syntax pane))) + +(defmethod display-parse-tree ((entity qualified-exported-symbol) (syntax cl-syntax) pane) + (with-slots (package-name colon symbol-name) entity + (display-parse-tree package-name syntax pane) + (with-drawing-options (pane :ink (make-rgb-color 0.0 0.0 1.0)) + (display-parse-tree colon syntax pane)) + (display-parse-tree symbol-name syntax pane))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Keyword symbols + +(defclass keyword-symbol (cl-entry) + ((start :initarg :start) + (item :initarg :item))) + +(add-cl-rule (keyword-symbol -> ((start colon) + (item identifier)) + :start start :item item)) + +(defmethod display-parse-tree ((entity keyword-symbol) (syntax cl-syntax) pane) + (with-slots (start item) entity + (with-text-face (pane :bold) + (display-parse-tree start syntax pane) + (display-parse-tree item syntax pane)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Lambda list Keywords + +(defclass lambda-list-keyword (cl-entry) + ((start :initarg :start) + (item :initarg :item))) + +(add-cl-rule (lambda-list-keyword -> ((start ampersand) + (item default-item (and + (= (end-offset start) + (start-offset item)) + (member item + '( ;; ordinary LLs + "optional" "rest" "key" "aux" "allow-other-keys" + ;; macro LLs + "body" "whole" "environment") + :test #'default-item-is)))) + :start start :item item)) + +(defmethod display-parse-tree ((entity lambda-list-keyword) (syntax cl-syntax) pane) + (with-slots (start item) entity + (with-drawing-options (pane :ink +blue+) + (display-parse-tree start syntax pane) + (display-parse-tree item syntax pane)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Backquoted expr @@ -850,6 +946,10 @@ (add-cl-rule (cl-terminal -> (balanced-comment) :item balanced-comment)) (add-cl-rule (cl-terminal -> (cl-string) :item cl-string)) (add-cl-rule (cl-terminal -> (quoted-expr) :item quoted-expr)) +(add-cl-rule (cl-terminal -> (keyword-symbol) :item keyword-symbol)) +(add-cl-rule (cl-terminal -> (lambda-list-keyword) :item lambda-list-keyword)) +(add-cl-rule (cl-terminal -> (qualified-symbol) :item qualified-symbol)) +(add-cl-rule (cl-terminal -> (qualified-exported-symbol) :item qualified-exported-symbol)) (add-cl-rule (cl-terminal -> (backquoted-expr) :item backquoted-expr)) (add-cl-rule (cl-terminal -> (char-item) :item char-item)) (add-cl-rule (cl-terminal -> (unquoted-expr) :item unquoted-expr)) @@ -925,19 +1025,21 @@ (defun handle-whitespace (pane buffer start end) (let ((space-width (space-width pane)) (tab-width (tab-width pane))) - (loop while (< start end) - do (ecase (buffer-object buffer start) - (#\Newline (terpri pane) - (setf (aref *cursor-positions* (incf *current-line*)) - (multiple-value-bind (x y) (stream-cursor-position pane) - (declare (ignore x)) - y))) - (#\Space (stream-increment-cursor-position - pane space-width 0)) - (#\Tab (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0)))) - (incf start)))) + (loop while (and (< start end) + (whitespacep (buffer-object buffer start))) + do (ecase (buffer-object buffer start) + (#\Newline (terpri pane) + (setf (aref *cursor-positions* (incf *current-line*)) + (multiple-value-bind (x y) (stream-cursor-position pane) + (declare (ignore x)) + y))) + (#\Space (stream-increment-cursor-position + pane space-width 0)) + (#\Tab (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0))) + (#\Page nil)) + (incf start)))) (defmethod display-parse-tree :around ((entity cl-parse-tree) syntax pane) (with-slots (top bot) pane

1 0

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

09 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8821 Modified Files: syntax.lisp html-syntax.lisp Log Message: Prediction is now done at the beginning of advance-parse, which means the next token is available to the predictor. Added a :predict-test to the add-rule macro making it possible to control when prediction is reasonable. Added :predict-test to a few rules of HTML syntax to speed up the parser. Date: Mon May 9 15:12:47 2005 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.48 climacs/syntax.lisp:1.49 --- climacs/syntax.lisp:1.48 Mon May 2 11:05:00 2005 +++ climacs/syntax.lisp Mon May 9 15:12:47 2005 @@ -205,6 +205,7 @@ ((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) + (predict-test :initarg :predict-test :reader predict-test) (number))) (defclass grammar () @@ -212,7 +213,7 @@ (hash :initform (make-hash-table) :accessor hash) (number-of-rules :initform 0))) -(defmacro grammar-rule ((left-hand-side arrow arglist &body body)) +(defmacro grammar-rule ((left-hand-side arrow arglist &body body) &key predict-test) (declare (ignore arrow)) (labels ((var-of (arg) (if (symbolp arg) @@ -244,7 +245,8 @@ (symbolp (car body))) `(make-instance ',left-hand-side ,@body) `(progn ,@body))) - :symbols ,(coerce (mapcar #'sym-of arglist) 'vector)))) + :symbols ,(coerce (mapcar #'sym-of arglist) 'vector) + :predict-test ,predict-test))) (defmacro grammar (&body body) @@ -308,14 +310,15 @@ (cond ((null remaining) nil) ((functionp remaining) - (handle-incomplete-item (make-instance 'incomplete-item - :orig-state (orig-state prev-item) - :predicted-from (predicted-from prev-item) - :rule (rule prev-item) - :dot-position (1+ (dot-position prev-item)) - :parse-trees (cons parse-tree (parse-trees prev-item)) - :suffix remaining) - orig-state to-state)) + (handle-incomplete-item + (make-instance 'incomplete-item + :orig-state (orig-state prev-item) + :predicted-from (predicted-from prev-item) + :rule (rule prev-item) + :dot-position (1+ (dot-position prev-item)) + :parse-trees (cons parse-tree (parse-trees prev-item)) + :suffix remaining) + orig-state to-state)) (t (let* ((parse-trees (cons parse-tree (parse-trees prev-item))) (start (find-if-not #'null parse-trees @@ -389,30 +392,45 @@ (t (push parse-tree (gethash from-state parse-trees)) (handle-parse-tree)))))) +(defun predict (item state tokens) + (dolist (rule (gethash (aref (symbols (rule item)) (dot-position item)) + (hash (parser-grammar (parser state))))) + (if (functionp (right-hand-side rule)) + (let ((predicted-rules (slot-value state 'predicted-rules)) + (rule-number (slot-value rule 'number)) + (predict-test (predict-test rule))) + (when (zerop (sbit predicted-rules rule-number)) + (setf (sbit predicted-rules rule-number) 1) + (when (or (null predict-test) + (some predict-test tokens)) + (handle-and-predict-incomplete-item + (make-instance 'incomplete-item + :orig-state state + :predicted-from item + :rule rule + :dot-position 0 + :suffix (right-hand-side rule)) + state tokens)))) + (potentially-handle-parse-tree (right-hand-side rule) state state))) + (loop for parse-tree in (gethash state (parse-trees state)) + do (derive-and-handle-item item parse-tree state state))) + (defun handle-incomplete-item (item orig-state to-state) (declare (optimize speed)) (cond ((find item (the list (gethash orig-state (incomplete-items to-state))) :test #'item-equal) nil) (t - (push item (gethash orig-state (incomplete-items to-state))) - (dolist (rule (gethash (aref (symbols (rule item)) (dot-position item)) - (hash (parser-grammar (parser to-state))))) - (if (functionp (right-hand-side rule)) - (let ((predicted-rules (slot-value to-state 'predicted-rules)) - (rule-number (slot-value rule 'number))) - (when (zerop (sbit predicted-rules rule-number)) - (setf (sbit predicted-rules rule-number) 1) - (handle-incomplete-item (make-instance 'incomplete-item - :orig-state to-state - :predicted-from item - :rule rule - :dot-position 0 - :suffix (right-hand-side rule)) - to-state to-state))) - (potentially-handle-parse-tree (right-hand-side rule) to-state to-state))) - (loop for parse-tree in (gethash to-state (parse-trees to-state)) - do (derive-and-handle-item item parse-tree to-state to-state))))) + (push item (gethash orig-state (incomplete-items to-state)))))) + +(defun handle-and-predict-incomplete-item (item state tokens) + (declare (optimize speed)) + (cond ((find item (the list (gethash state (incomplete-items state))) + :test #'item-equal) + nil) + (t + (push item (gethash state (incomplete-items state))) + (predict item state tokens)))) (defmethod initialize-instance :after ((parser parser) &rest args) (declare (ignore args)) @@ -424,13 +442,14 @@ (or (subtypep (target parser) sym) (subtypep sym (target parser)))) (if (functionp (right-hand-side rule)) - (handle-incomplete-item (make-instance 'incomplete-item - :orig-state initial-state - :predicted-from nil - :rule rule - :dot-position 0 - :suffix (right-hand-side rule)) - initial-state initial-state) + (handle-incomplete-item + (make-instance 'incomplete-item + :orig-state initial-state + :predicted-from nil + :rule rule + :dot-position 0 + :suffix (right-hand-side rule)) + initial-state initial-state) (potentially-handle-parse-tree (right-hand-side rule) initial-state initial-state)))))) @@ -442,6 +461,11 @@ do (return parse-tree))) (defun advance-parse (parser tokens state) + (maphash (lambda (from-state items) + (declare (ignore from-state)) + (dolist (item items) + (predict item state tokens))) + (incomplete-items state)) (let ((new-state (make-instance 'parser-state :parser parser))) (loop for token in tokens do (potentially-handle-parse-tree token state new-state)) Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.29 climacs/html-syntax.lisp:1.30 --- climacs/html-syntax.lisp:1.29 Mon Apr 11 08:27:13 2005 +++ climacs/html-syntax.lisp Mon May 9 15:12:47 2005 @@ -22,6 +22,11 @@ (in-package :climacs-html-syntax) +(define-syntax html-syntax ("HTML" (basic-syntax)) + ((lexer :reader lexer) + (valid-parse :initform 1) + (parser))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; grammar classes @@ -40,6 +45,31 @@ (defclass html-tag (html-token) ()) +(defclass html-start-tag (html-tag) + ((start :initarg :start) + (name :initarg :name) + (attributes :initform nil :initarg :attributes) + (end :initarg :end))) + +(defmethod display-parse-tree ((entity html-start-tag) (syntax html-syntax) pane) + (with-slots (start name attributes end) entity + (display-parse-tree start syntax pane) + (display-parse-tree name syntax pane) + (unless (null attributes) + (display-parse-tree attributes syntax pane)) + (display-parse-tree end syntax pane))) + +(defclass html-end-tag (html-tag) + ((start :initarg :start) + (name :initarg :name) + (end :initarg :end))) + +(defmethod display-parse-tree ((entity html-end-tag) (syntax html-syntax) pane) + (with-slots (start name attributes end) entity + (display-parse-tree start syntax pane) + (display-parse-tree name syntax pane) + (display-parse-tree end syntax pane))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer @@ -74,19 +104,15 @@ (t (fo) (make-instance 'delimiter)))))))) -(define-syntax html-syntax ("HTML" (basic-syntax)) - ((lexer :reader lexer) - (valid-parse :initform 1) - (parser))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; parser (defparameter *html-grammar* (grammar)) -(defmacro add-html-rule (rule) - `(add-rule (grammar-rule ,rule) *html-grammar*)) +(defmacro add-html-rule (rule &key predict-test) + `(add-rule (grammar-rule ,rule :predict-test ,predict-test) + *html-grammar*)) (defun word-is (word string) (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string) @@ -94,23 +120,27 @@ (defmacro define-start-tag (name string) `(progn - (defclass ,name (html-tag) ()) + (defclass ,name (html-start-tag) ()) (add-html-rule (,name -> (start-tag-start (word (and (= (end-offset start-tag-start) (start-offset word)) (word-is word ,string))) - (tag-end (= (end-offset word) (start-offset tag-end)))))))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start start-tag-start :name word :end tag-end)))) (defmacro define-end-tag (name string) `(progn - (defclass ,name (html-tag) ()) + (defclass ,name (html-end-tag) ()) (add-html-rule (,name -> (end-tag-start (word (and (= (end-offset end-tag-start) (start-offset word)) (word-is word ,string))) - (tag-end (= (end-offset word) (start-offset tag-end)))))))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start end-tag-start :name word :end tag-end) + :predict-test (lambda (token) + (typep token 'end-tag-start))))) (defmacro define-tag-pair (start-name end-name string) `(progn (define-start-tag ,start-name ,string) @@ -310,7 +340,9 @@ (defclass $inline (html-nonterminal) ((contents :initarg :contents))) -(add-html-rule ($inline -> (inline-element) :contents inline-element)) +(add-html-rule ($inline -> (inline-element) :contents inline-element) + :predict-test (lambda (token) + (typep token 'start-tag-start))) (add-html-rule ($inline -> (word) :contents word)) (add-html-rule ($inline -> (delimiter) :contents delimiter)) @@ -326,7 +358,9 @@ ((contents :initarg :contents))) (add-html-rule ($flow -> ($inline) :contents $inline)) -(add-html-rule ($flow -> (block-level-element) :contents block-level-element)) +(add-html-rule ($flow -> (block-level-element) :contents block-level-element) + :predict-test (lambda (token) + (typep token 'start-tag-start))) (defmethod display-parse-tree ((entity $flow) (syntax html-syntax) pane) (with-slots (contents) entity @@ -379,11 +413,7 @@ (define-list <a>-attributes <a>-attribute) -(defclass <a> (html-tag) - ((start :initarg :start) - (name :initarg :name) - (attributes :initarg :attributes) - (end :initarg :end))) +(defclass <a> (html-start-tag) ()) (add-html-rule (<a> -> (start-tag-start (word (and (= (end-offset start-tag-start) (start-offset word)) @@ -392,13 +422,6 @@ tag-end) :start start-tag-start :name word :attributes <a>-attributes :end tag-end)) -(defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane) - (with-slots (start name attributes end) entity - (display-parse-tree start syntax pane) - (display-parse-tree name syntax pane) - (display-parse-tree attributes syntax pane) - (display-parse-tree end syntax pane))) - (define-end-tag </a> "a") (defclass a-element (inline-element) @@ -431,11 +454,7 @@ ;;;;;;;;;;;;;;; p element -(defclass (html-tag) - ((start :initarg :start) - (name :initarg :name) - (attributes :initarg :attributes) - (end :initarg :end))) +(defclass (html-start-tag) ()) (add-html-rule ( -> (start-tag-start (word (and (= (end-offset start-tag-start) (start-offset word)) @@ -444,13 +463,6 @@ tag-end) :start start-tag-start :name word :attributes common-attributes :end tag-end)) -(defmethod display-parse-tree ((entity ) (syntax html-syntax) pane) - (with-slots (start name attributes end) entity - (display-parse-tree start syntax pane) - (display-parse-tree name syntax pane) - (display-parse-tree attributes syntax pane) - (display-parse-tree end syntax pane))) - (define-end-tag "p") (defclass p-element (block-level-element) @@ -469,11 +481,7 @@ ;;;;;;;;;;;;;;; li element -(defclass <li> (html-tag) - ((start :initarg :start) - (name :initarg :name) - (attributes :initarg :attributes) - (end :initarg :end))) +(defclass <li> (html-start-tag) ()) (add-html-rule (<li> -> (start-tag-start (word (and (= (end-offset start-tag-start) (start-offset word)) @@ -485,13 +493,6 @@ :attributes common-attributes :end tag-end)) -(defmethod display-parse-tree ((entity <li>) (syntax html-syntax) pane) - (with-slots (start name attributes end) entity - (display-parse-tree start syntax pane) - (display-parse-tree name syntax pane) - (display-parse-tree attributes syntax pane) - (display-parse-tree end syntax pane))) - (define-end-tag </li> "li") (defclass li-element (html-nonterminal) @@ -513,11 +514,7 @@ ;;;;;;;;;;;;;;; ul element -(defclass <ul> (html-tag) - ((start :initarg :start) - (name :initarg :name) - (attributes :initarg :attributes) - (end :initarg :end))) +(defclass <ul> (html-start-tag) ()) (add-html-rule (<ul> -> (start-tag-start (word (and (= (end-offset start-tag-start) (start-offset word)) @@ -529,13 +526,6 @@ :attributes common-attributes :end tag-end)) -(defmethod display-parse-tree ((entity <ul>) (syntax html-syntax) pane) - (with-slots (start name attributes end) entity - (display-parse-tree start syntax pane) - (display-parse-tree name syntax pane) - (display-parse-tree attributes syntax pane) - (display-parse-tree end syntax pane))) - (define-end-tag </ul> "ul") (define-nonempty-list li-elements li-element) @@ -624,11 +614,7 @@ (define-list <html>-attributes <html>-attribute) -(defclass <html> (html-tag) - ((start :initarg :start) - (name :initarg :name) - (attributes :initarg :attributes) - (end :initarg :end))) +(defclass <html> (html-start-tag) ()) (add-html-rule (<html> -> (start-tag-start (word (and (= (end-offset start-tag-start) (start-offset word)) @@ -637,13 +623,6 @@ tag-end) :start start-tag-start :name word :attributes <html>-attributes :end tag-end)) -(defmethod display-parse-tree ((entity <html>) (syntax html-syntax) pane) - (with-slots (start name attributes end) entity - (display-parse-tree start syntax pane) - (display-parse-tree name syntax pane) - (display-parse-tree attributes syntax pane) - (display-parse-tree end syntax pane))) - (define-end-tag </html> "html") (defclass html (html-nonterminal) @@ -736,13 +715,14 @@ (when (and (end-offset entity) (mark> (end-offset entity) top)) (call-next-method)))) -(defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane) +(defmethod display-parse-tree ((entity html-lexeme) (syntax html-syntax) pane) (flet ((cache-test (t1 t2) - (and (eq t1 t2) - (eq (slot-value t1 'ink) - (medium-ink (sheet-medium pane))) - (eq (slot-value t1 'face) - (text-style-face (medium-text-style (sheet-medium pane))))))) + (let ((result (and (eq t1 t2) + (eq (slot-value t1 'ink) + (medium-ink (sheet-medium pane))) + (eq (slot-value t1 'face) + (text-style-face (medium-text-style (sheet-medium pane))))))) + result))) (updating-output (pane :unique-id entity :id-test #'eq :cache-value entity @@ -761,7 +741,7 @@ (with-drawing-options (pane :ink +green4+) (call-next-method))) -(defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane) +(defmethod display-parse-tree :before ((entity html-lexeme) (syntax html-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity)) (setf *white-space-start* (end-offset entity)))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by abakic＠common-lisp.net 08 May '05

08 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21151 Modified Files: gui.lisp Log Message: Contribution by John Q Splittist: Feedback and default replacements for Query Replace. Date: Sun May 8 22:16:33 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.134 climacs/gui.lisp:1.135 --- climacs/gui.lisp:1.134 Sat May 7 00:32:28 2005 +++ climacs/gui.lisp Sun May 8 22:16:32 2005 @@ -1185,54 +1185,79 @@ (/= (offset mark) offset-before)))) (define-named-command com-query-replace () - (let* ((string1 (handler-case (accept 'string :prompt "Query replace") + (let* ((pane (current-window)) + (old-state (query-replace-state pane)) + (old-string1 (when old-state (string1 old-state))) + (old-string2 (when old-state (string2 old-state))) + (string1 (handler-case + (if old-string1 + (accept 'string + :prompt "Query Replace" + :default old-string1 + :default-type 'string) + (accept 'string :prompt "Query Replace")) (error () (progn (beep) (display-message "Empty string") (return-from com-query-replace nil))))) - (string2 (handler-case (accept 'string - :prompt (format nil "Query replace ~A with" - string1)) + (string2 (handler-case + (if old-string2 + (accept 'string + :prompt (format nil "Query Replace ~A with" + string1) + :default old-string2 + :default-type 'string) + (accept 'string + :prompt (format nil "Query Replace ~A with" string1))) (error () (progn (beep) (display-message "Empty string") (return-from com-query-replace nil))))) - (pane (current-window)) - (point (point pane))) + (point (point pane)) + (occurrences 0)) + (declare (special string1 string2 occurrences)) (when (query-replace-find-next-match point string1) (setf (query-replace-state pane) (make-instance 'query-replace-state :string1 string1 :string2 string2) (query-replace-mode pane) t) + (display-message "Query Replace ~A with ~A:" + string1 string2) (simple-command-loop 'query-replace-climacs-table - (query-replace-mode pane) - ((setf (query-replace-mode pane) nil)))))) + (query-replace-mode pane) + ((setf (query-replace-mode pane) nil)))) + (display-message "Replaced ~A occurrence~:P" occurrences))) (define-named-command com-query-replace-replace () + (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) (point (point pane)) (buffer (buffer pane)) - (state (query-replace-state pane)) - (string1-length (length (string1 state)))) + (string1-length (length string1))) (backward-object point string1-length) (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)))) + (insert-sequence point string2) + (setf offset2 (+ offset1 (length string2))) (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)))) + (incf occurrences) + (if (query-replace-find-next-match point string1) + (display-message "Query Replace ~A with ~A:" + string1 string2) + (setf (query-replace-mode pane) nil)))) (define-named-command com-query-replace-skip () + (declare (special string1 string2)) (let* ((pane (current-window)) - (point (point pane)) - (state (query-replace-state pane))) - (unless (query-replace-find-next-match point (string1 state)) - (setf (query-replace-mode pane) nil)))) + (point (point pane))) + (if (query-replace-find-next-match point string1) + (display-message "Query Replace ~A with ~A:" + string1 string2) + (setf (query-replace-mode pane) nil)))) (define-named-command com-query-replace-exit () (setf (query-replace-mode (current-window)) nil))

1 0

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 07 May '05

07 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14244 Modified Files: prolog-syntax.lisp Log Message: Improve the Prolog tokenizer. We now recognize * binary constants: 0b... * octal constants: 0o... * hexadecimal constants: 0x... * char-code constants: 0'<quoted-char> * escaped characters in quoted strings: ** meta escapes such as \" ** control escapes such as \a ** numeric escapes such as \0177\ and \xabcd\ ** "" (within a char-code-string) and '' (within a quoted-atom) Date: Sat May 7 18:41:03 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.17 climacs/prolog-syntax.lisp:1.18 --- climacs/prolog-syntax.lisp:1.17 Sun Apr 17 17:44:39 2005 +++ climacs/prolog-syntax.lisp Sat May 7 18:41:03 2005 @@ -111,7 +111,8 @@ (def (name t) identifier graphic quoted semicolon cut) (def (variable t) anonymous named) - (def (integer t)) + (def (integer t) integer-constant character-code-constant binary-constant + octal-constant hexadecimal-constant) (def (float-number t)) (def (char-code-list t)) (def (open-ct)) @@ -157,6 +158,58 @@ (bo () (vector-pop string) (backward-object scan))) + (macrolet ((read-quoted-char (char) + `(block read-quoted-char + (let ((o (object-after scan))) + (tagbody + START + (cond + ((eql o #\\) (fo) (go ESCAPE)) + ((eql o ,char) (fo) (go QUOTE)) + (t (fo) (return-from read-quoted-char t))) + QUOTE + (if (end-of-buffer-p scan) + (return-from read-quoted-char nil) + (let ((o (object-after scan))) + (cond + ((eql o ,char) (fo) (return-from read-quoted-char t)) + (t (return-from read-quoted-char nil))))) + ESCAPE + (if (end-of-buffer-p scan) + (return (make-instance 'error-lexeme)) + (let ((o (object-after scan))) + (cond + ;; meta (6.5.5) + ((position o "\\'\"`") (fo) (return-from read-quoted-char t)) + ;; symbolic (6.4.2.1) + ((position o "abfnrtv") (fo) (return-from read-quoted-char t)) + ;; octal + ((digit-char-p o 8) (fo) + (tagbody + LOOP + (when (end-of-buffer-p scan) + (return (make-instance 'error-lexeme))) + (let ((o (object-after scan))) + (cond + ((eql o #\\) (fo) (return-from read-quoted-char t)) + ((digit-char-p o 8) (fo) (go LOOP)) + (t (return (make-instance 'error-lexeme))))))) + ((eql o #\x) (fo) + (if (or (end-of-buffer-p scan) + (not (digit-char-p (object-after scan) 16))) + (return (make-instance 'error-lexeme)) + (progn + (fo) + (tagbody + LOOP + (when (end-of-buffer-p scan) + (return (make-instance 'error-lexeme))) + (let ((o (object-after scan))) + (cond + ((eql o #\\) (fo) (return-from read-quoted-char t)) + ((digit-char-p o 16) (fo) (go LOOP)) + (t (return (make-instance 'error-lexeme))))))))) + (t (return (make-instance 'error-lexeme))))))))))) (let ((object (object-after scan))) (block nil (tagbody @@ -173,6 +226,7 @@ (fo) (return (make-instance 'cut-lexeme))) ((eql object #\_) (fo) (go VARIABLE)) ((upper-case-p object) (fo) (go NAMED-VARIABLE)) + ((eql object #\0) (fo) (go NUMBER-OR-INTEGER)) ((digit-char-p object) (fo) (go NUMBER)) ((eql object #\") (fo) (go CHAR-CODE-LIST)) ((eql object #\() @@ -243,14 +297,10 @@ (return (make-instance 'end-lexeme))) (t (return (make-instance 'graphic-lexeme)))))) QUOTED-TOKEN - (loop until (end-of-buffer-p scan) - ;; FIXME - until (eql (object-after scan) #\') - do (fo)) - (if (end-of-buffer-p scan) - (return (make-instance 'error-lexeme)) - (progn (fo) - (return (make-instance 'quoted-lexeme)))) + (loop named #:mu + until (end-of-buffer-p scan) + while (read-quoted-char #\')) + (return (make-instance 'quoted-lexeme)) VARIABLE (if (or (end-of-buffer-p scan) (let ((object (object-after scan))) @@ -265,20 +315,47 @@ (eql object #\_))) do (fo)) (return (make-instance 'named-lexeme)) + NUMBER-OR-INTEGER + (if (end-of-buffer-p scan) + (return (make-instance 'integer-lexeme)) + (let ((object (object-after scan))) + (cond + ((eql object #\') (fo) (go CHARACTER-CODE-CONSTANT)) + ((eql object #\b) (fo) (go BINARY-CONSTANT)) + ((eql object #\o) (fo) (go OCTAL-CONSTANT)) + ((eql object #\x) (fo) (go HEXADECIMAL-CONSTANT)) + ((digit-char-p object) (fo) (go NUMBER)) + ;; FIXME: floats + (t (return (make-instance 'integer-lexeme)))))) + CHARACTER-CODE-CONSTANT + (if (read-quoted-char #\') + (return (make-instance 'character-code-constant-lexeme)) + (return (make-instance 'error-lexeme))) + BINARY-CONSTANT + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan) 2) + do (fo)) + (return (make-instance 'binary-constant-lexeme)) + OCTAL-CONSTANT + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan) 8) + do (fo)) + (return (make-instance 'octal-constant-lexeme)) + HEXADECIMAL-CONSTANT + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan) 16) + do (fo)) + (return (make-instance 'hexadecimal-constant-lexeme)) NUMBER (loop until (end-of-buffer-p scan) - while (digit-char-p (object-after scan)) - do (fo)) - (return (make-instance 'integer-lexeme)) + while (digit-char-p (object-after scan)) + do (fo)) + (return (make-instance 'integer-constant-lexeme)) CHAR-CODE-LIST - (loop until (end-of-buffer-p scan) - ;; FIXME - until (eql (object-after scan) #\") - do (fo)) - (if (end-of-buffer-p scan) - (return (make-instance 'error-lexeme)) - (progn (fo) - (return (make-instance 'char-code-list-lexeme)))))))))) + (loop named #:mu + until (end-of-buffer-p scan) + while (read-quoted-char #\")) + (return (make-instance 'char-code-list-lexeme))))))))) ;;; parser

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
by abakic＠common-lisp.net 07 May '05

07 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21864 Modified Files: gui.lisp packages.lisp pane.lisp Log Message: Contribution by John Q Splittist: Renamed occurrences of `filename' (actually referring to pathnames) to `filepath'. Date: Sat May 7 00:32:28 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.133 climacs/gui.lisp:1.134 --- climacs/gui.lisp:1.133 Fri May 6 18:56:32 2005 +++ climacs/gui.lisp Sat May 7 00:32:28 2005 @@ -693,14 +693,14 @@ (declare (ignore success)) (or pathname string))) -(defun pathname-filename (pathname) +(defun filepath-filename (pathname) (if (null (pathname-type pathname)) (pathname-name pathname) (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) (define-named-command com-find-file () - (let ((filename (accept 'completable-pathname + (let ((filepath (accept 'completable-pathname :prompt "Find File")) (buffer (make-instance 'climacs-buffer)) (pane (current-window))) @@ -709,11 +709,11 @@ (setf (syntax buffer) (make-instance 'basic-syntax :buffer (buffer (point pane)))) ;; Don't want to create the file if it doesn't exist. - (when (probe-file filename) - (with-open-file (stream filename :direction :input) + (when (probe-file filepath) + (with-open-file (stream filepath :direction :input) (input-from-stream stream buffer 0))) - (setf (filename buffer) filename - (name buffer) (pathname-filename filename) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) (beginning-of-buffer (point pane)) ;; this one is needed so that the buffer modification protocol @@ -721,19 +721,19 @@ (redisplay-frame-panes *application-frame*))) (defun save-buffer (buffer) - (let ((filename (or (filename buffer) + (let ((filepath (or (filepath buffer) (accept 'completable-pathname :prompt "Save Buffer to File")))) - (with-open-file (stream filename :direction :output :if-exists :supersede) + (with-open-file (stream filepath :direction :output :if-exists :supersede) (output-to-stream stream buffer 0 (size buffer))) - (setf (filename buffer) filename - (name buffer) (pathname-filename filename)) - (display-message "Wrote: ~a" (filename buffer)) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) (setf (needs-saving buffer) nil))) (define-named-command com-save-buffer () (let ((buffer (buffer (current-window)))) - (if (or (null (filename buffer)) + (if (or (null (filepath buffer)) (needs-saving buffer)) (save-buffer buffer) (display-message "No changes need to be saved from ~a" (name buffer))))) @@ -756,15 +756,15 @@ (frame-exit *application-frame*))) (define-named-command com-write-buffer () - (let ((filename (accept 'completable-pathname + (let ((filepath (accept 'completable-pathname :prompt "Write Buffer to File")) (buffer (buffer (current-window)))) - (with-open-file (stream filename :direction :output :if-exists :supersede) + (with-open-file (stream filepath :direction :output :if-exists :supersede) (output-to-stream stream buffer 0 (size buffer))) - (setf (filename buffer) filename - (name buffer) (pathname-filename filename) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) - (display-message "Wrote: ~a" (filename buffer)))) + (display-message "Wrote: ~a" (filepath buffer)))) (define-presentation-method accept ((type buffer) stream (view textual-view) &key) @@ -809,9 +809,9 @@ (full-redisplay (current-window))) (define-named-command com-load-file () - (let ((filename (accept 'completable-pathname + (let ((filepath (accept 'completable-pathname :prompt "Load File"))) - (load filename))) + (load filepath))) (define-named-command com-beginning-of-buffer () (beginning-of-buffer (point (current-window)))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.61 climacs/packages.lisp:1.62 --- climacs/packages.lisp:1.61 Fri Apr 22 10:19:11 2005 +++ climacs/packages.lisp Sat May 7 00:32:28 2005 @@ -123,7 +123,7 @@ (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :flexichain :undo) - (:export #:climacs-buffer #:needs-saving #:filename + (:export #:climacs-buffer #:needs-saving #:filepath #:climacs-pane #:point #:mark #:redisplay-pane #:full-redisplay #:page-down #:page-up Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.24 climacs/pane.lisp:1.25 --- climacs/pane.lisp:1.24 Wed Apr 6 07:31:53 2005 +++ climacs/pane.lisp Sat May 7 00:32:28 2005 @@ -182,8 +182,8 @@ (defclass climacs-textual-view (textual-view tabify-mixin) ()) -(defclass filename-mixin () - ((filename :initform nil :accessor filename))) +(defclass filepath-mixin () + ((filepath :initform nil :accessor filepath))) ;(defgeneric indent-tabs-mode (climacs-buffer)) @@ -193,7 +193,7 @@ (defclass extended-binseq2-buffer (binseq2-buffer p-undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks.")) -(defclass climacs-buffer (delegating-buffer filename-mixin name-mixin) +(defclass climacs-buffer (delegating-buffer filepath-mixin name-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by crhodes＠common-lisp.net 06 May '05

06 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25021 Modified Files: gui.lisp Log Message: rearrange the toplevel loop a little Date: Fri May 6 18:56:33 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.132 climacs/gui.lisp:1.133 --- climacs/gui.lisp:1.132 Fri May 6 01:00:23 2005 +++ climacs/gui.lisp Fri May 6 18:56:32 2005 @@ -282,39 +282,46 @@ (when (null (remaining-keys *application-frame*)) (setf (executingp *application-frame*) nil) (redisplay-frame-panes frame)))) - (loop + (flet ((process-gestures () + (loop + for gestures = '() + do (multiple-value-bind (numarg numargp) + (read-numeric-argument :stream *standard-input*) + (loop + (setf *current-gesture* (climacs-read-gesture)) + (setf gestures + (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond + ((not item) + (beep) (return)) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (setf command (substitute-numeric-argument-p command numargp)) + (do-command command) + (return))) + (t nil))))) + do (update-climacs)))) + (loop for maybe-error = t - do (with-simple-restart (return-to-climacs "Return to Climacs") - (handler-case - (with-input-context ('(command - :command-table 'global-climacs-table)) - (object) - (loop - for gestures = '() - do (multiple-value-bind (numarg numargp) - (read-numeric-argument :stream *standard-input*) - (loop (setf *current-gesture* (climacs-read-gesture)) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (return)) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (setf command (substitute-numeric-argument-p command numargp)) - (do-command command) - (return))) - (t nil))))) - (update-climacs)) - (t - (do-command object) - (setq maybe-error nil))) - (abort-gesture () (display-message "Quit")))) - (when maybe-error - (beep)) - (update-climacs)))))) + do (restart-case + (progn + (handler-case + (with-input-context + ('(command :command-table 'global-climacs-table)) + (object) + (process-gestures) + (t + (do-command object) + (setq maybe-error nil))) + (abort-gesture () (display-message "Quit"))) + (when maybe-error + (beep)) + (update-climacs)) + (return-to-climacs () nil)))))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by abakic＠common-lisp.net 06 May '05

06 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31112 Modified Files: gui.lisp Log Message: Contribution by John Q Splittist: Removed syntax and point reset from com-switch-to-buffer. Date: Fri May 6 01:00:23 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.131 climacs/gui.lisp:1.132 --- climacs/gui.lisp:1.131 Thu May 5 12:59:42 2005 +++ climacs/gui.lisp Fri May 6 01:00:23 2005 @@ -780,9 +780,6 @@ :prompt "Switch to buffer")) (pane (current-window))) (setf (buffer pane) buffer) - (setf (syntax buffer) (make-instance - 'basic-syntax :buffer (buffer (point pane)))) - (beginning-of-buffer (point pane)) (full-redisplay pane))) (define-named-command com-kill-buffer ()

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs May 2005