From crhodes at common-lisp.net Mon May 2 09:05:01 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 2 May 2005 11:05:01 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp Message-ID: <20050502090501.08B0188717@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13557 Modified Files: syntax.lisp Log Message: Use sbit rather than aref, mostly for self-documentation (because it doesn't actually speed things up much; it's just a constant-factor optimization) Date: Mon May 2 11:05:01 2005 Author: crhodes Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.47 climacs/syntax.lisp:1.48 --- climacs/syntax.lisp:1.47 Sat Apr 16 07:20:29 2005 +++ climacs/syntax.lisp Mon May 2 11:05:00 2005 @@ -401,8 +401,8 @@ (if (functionp (right-hand-side rule)) (let ((predicted-rules (slot-value to-state 'predicted-rules)) (rule-number (slot-value rule 'number))) - (when (zerop (aref predicted-rules rule-number)) - (setf (aref predicted-rules rule-number) 1) + (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 From abakic at common-lisp.net Tue May 3 20:45:21 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Tue, 3 May 2005 22:45:21 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050503204521.E1B948871F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29990 Modified Files: gui.lisp Log Message: Contribution by John Q. Splittist: Made Find File more portable by copying some code from cl-fad. Date: Tue May 3 22:45:17 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.128 climacs/gui.lisp:1.129 --- climacs/gui.lisp:1.128 Sat Mar 19 23:08:31 2005 +++ climacs/gui.lisp Tue May 3 22:45:17 2005 @@ -621,12 +621,18 @@ (full-so-far (concatenate 'string directory-prefix so-far)) (pathnames (loop with length = (length full-so-far) - for path in (directory (concatenate 'string - (remove-trail so-far) - "*.*")) - when (let ((mismatch (mismatch (namestring path) full-so-far))) - (or (null mismatch) (= mismatch length))) - collect path)) + and wildcard = (concatenate 'string (remove-trail so-far) "*.*") + for path in + #+(or sbcl cmu lispworks) (directory wildcard) + #+openmcl (directory wildcard :directories t) + #+allegro (directory wildcard :directories-are-files nil) + #+cormanlisp (nconc (directory wildcard) + (cl::directory-subdirs dirname)) + #-(or sbcl cmu lispworks openmcl allegro cormanlisp) + (directory wildcard) + when (let ((mismatch (mismatch (namestring path) full-so-far))) + (or (null mismatch) (= mismatch length))) + collect path)) (strings (mapcar #'namestring pathnames)) (first-string (car strings)) (length-common-prefix nil) From abakic at common-lisp.net Wed May 4 22:51:22 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Thu, 5 May 2005 00:51:22 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050504225122.1953588720@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2401 Modified Files: gui.lisp Log Message: Contribution by John Q. Splittist: Minibuffer feedback for the Isearch fns. Date: Thu May 5 00:51:20 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.129 climacs/gui.lisp:1.130 --- climacs/gui.lisp:1.129 Tue May 3 22:45:17 2005 +++ climacs/gui.lisp Thu May 5 00:51:19 2005 @@ -1092,6 +1092,8 @@ (offset mark) (if forwardp (- (offset mark2) (length string)) (+ (offset mark2) (length string))))) + (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" + success forwardp string) (push (make-instance 'isearch-state :search-string string :search-mark mark @@ -1102,9 +1104,11 @@ (beep))))) (define-named-command com-isearch-mode-forward () + (display-message "Isearch: ") (isearch-command-loop (current-window) t)) (define-named-command com-isearch-mode-backward () + (display-message "Isearch backward: ") (isearch-command-loop (current-window) nil)) (define-named-command com-isearch-append-char () @@ -1122,6 +1126,7 @@ (define-named-command com-isearch-delete-char () (let* ((pane (current-window))) (cond ((null (second (isearch-states pane))) + (display-message "Isearch: ") (beep)) (t (pop (isearch-states pane)) @@ -1134,7 +1139,10 @@ (+ (offset (search-mark state)) (length (search-string state))) (- (offset (search-mark state)) - (length (search-string state)))))))))) + (length (search-string state))))) + (display-message "Isearch~:[ backward~;~]: ~A" + (search-forward-p state) + (search-string state))))))) (define-named-command com-isearch-forward () (let* ((pane (current-window)) From crhodes at common-lisp.net Thu May 5 10:59:43 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Thu, 5 May 2005 12:59:43 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050505105943.EF4D28871F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv893 Modified Files: gui.lisp Log Message: Provide a "comfort" restart, allowing recovery from unhandled lisp errors in the dynamic extent of the climacs command loop Date: Thu May 5 12:59:43 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.130 climacs/gui.lisp:1.131 --- climacs/gui.lisp:1.130 Thu May 5 00:51:19 2005 +++ climacs/gui.lisp Thu May 5 12:59:42 2005 @@ -284,11 +284,12 @@ (redisplay-frame-panes frame)))) (loop for maybe-error = t - do (handler-case - (with-input-context ('(command - :command-table 'global-climacs-table)) - (object) - (loop + 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*) @@ -306,15 +307,14 @@ (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)))))) + (update-climacs)) + (t + (do-command object) + (setq maybe-error nil))) + (abort-gesture () (display-message "Quit")))) + (when maybe-error + (beep)) + (update-climacs)))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym)) From abakic at common-lisp.net Thu May 5 23:00:24 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Fri, 6 May 2005 01:00:24 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050505230024.8B517880E0@common-lisp.net> 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 () From crhodes at common-lisp.net Fri May 6 16:56:33 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Fri, 6 May 2005 18:56:33 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050506165633.C887B88729@common-lisp.net> 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)) From abakic at common-lisp.net Fri May 6 22:32:31 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sat, 7 May 2005 00:32:31 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050506223231.E15D6880A4@common-lisp.net> 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 From crhodes at common-lisp.net Sat May 7 16:41:04 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sat, 7 May 2005 18:41:04 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050507164104.2D73B88704@common-lisp.net> 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' * 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 From abakic at common-lisp.net Sun May 8 20:16:34 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 8 May 2005 22:16:34 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050508201634.48C53880A4@common-lisp.net> 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)) From rstrandh at common-lisp.net Mon May 9 13:12:50 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 9 May 2005 15:12:50 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp climacs/html-syntax.lisp Message-ID: <20050509131250.12B5988704@common-lisp.net> 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 , at body) `(progn , at 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 -attributes -attribute) -(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)) @@ -392,13 +422,6 @@ tag-end) :start start-tag-start :name word :attributes -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 "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
  • (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)) @@ -485,13 +493,6 @@ :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
  • "li") (defclass li-element (html-nonterminal) @@ -513,11 +514,7 @@ ;;;;;;;;;;;;;;; ul element -(defclass