[climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
Robert Strandh
rstrandh at common-lisp.net
Wed Feb 2 07:59:43 UTC 2005
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))
More information about the Climacs-cvs
mailing list