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))