From dlichteblau at common-lisp.net Sun Apr 1 17:23:23 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 1 Apr 2007 13:23:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070401172323.1395F4818B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24118 Modified Files: medium.lisp Log Message: Fixed typo in rgb-image code. * Backends/CLX/medium.lisp (medium-draw-image-design*): s/height/width/ --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/01/07 19:32:28 1.79 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/04/01 17:23:22 1.80 @@ -1159,7 +1159,7 @@ ((medium clx-medium) (design climi::rgb-image-design) x y) (let* ((da (sheet-direct-mirror (medium-sheet medium))) (image (slot-value design 'climi::image)) - (width (climi::image-height image)) + (width (climi::image-width image)) (height (climi::image-height image))) (destructuring-bind (&optional pixmap mask) (slot-value design 'climi::medium-data) From dlichteblau at common-lisp.net Sun Apr 1 17:24:04 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 1 Apr 2007 13:24:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070401172404.722E34B028@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24182/Backends/CLX Modified Files: clim-extensions.lisp Log Message: Added an extension function SHEET-RGB-IMAGE, which "screenshots" a sheet into an RGB-IMAGE; basically the opposite of MEDIUM-DRAW-RGB-IMAGE. Implemented only for CLIM-CLX and only for true color visuals. * Backends/CLX/clim-extensions.lisp (ZIMAGE-TO-RGB): New helper function. (SHEET-RGB-DATA): New method. * Extensions/rgb-image.lisp (SHEET-RGB-IMAGE): New extension function. (SHEET-RGB-DATA): New backend protocol function. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/clim-extensions.lisp 2003/11/11 03:24:56 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/clim-extensions.lisp 2007/04/01 17:24:04 1.9 @@ -400,3 +400,43 @@ :clipping-region (sheet-region pane) :transformation (make-translation-transformation tx ty))))) ||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; retrieve image + +(defun zimage-to-rgb (zimage) + (unless (eql (xlib:image-depth zimage) 24) + (error "sorry, only true color images supported in zimage-to-rgb")) + (let* ((data (xlib:image-z-pixarray zimage)) + (w (xlib:image-width zimage)) + (h (xlib:image-height zimage)) + (rbyte (mask->byte (xlib:image-red-mask zimage))) + (gbyte (mask->byte (xlib:image-green-mask zimage))) + (bbyte (mask->byte (xlib:image-blue-mask zimage))) + (result (make-array (list h w) + :element-type '(unsigned-byte 32)))) + (dotimes (y h) + (dotimes (x w) + (setf (aref result y x) + (let ((pixel (aref data y x))) + (dpb (the (unsigned-byte 8) (ldb rbyte pixel)) + (byte 8 0) + (dpb (the (unsigned-byte 8) (ldb gbyte pixel)) + (byte 8 8) + (dpb (the (unsigned-byte 8) (ldb bbyte pixel)) + (byte 8 16) + 0))))))) + result)) + +(defmethod climi::sheet-rgb-data ((port clx-port) sheet &key x y width height) + (let ((window (port-lookup-mirror port sheet))) + (values + (zimage-to-rgb + (xlib:get-image window + :format :z-pixmap + :x (or x 0) + :y (or y 0) + :width (or width (xlib:drawable-width window)) + :height (or height (xlib:drawable-height window)))) + nil))) From dlichteblau at common-lisp.net Sun Apr 1 17:24:04 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 1 Apr 2007 13:24:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20070401172404.D7C264E01A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv24182/Extensions Modified Files: rgb-image.lisp Log Message: Added an extension function SHEET-RGB-IMAGE, which "screenshots" a sheet into an RGB-IMAGE; basically the opposite of MEDIUM-DRAW-RGB-IMAGE. Implemented only for CLIM-CLX and only for true color visuals. * Backends/CLX/clim-extensions.lisp (ZIMAGE-TO-RGB): New helper function. (SHEET-RGB-DATA): New method. * Extensions/rgb-image.lisp (SHEET-RGB-IMAGE): New extension function. (SHEET-RGB-DATA): New backend protocol function. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/01/07 19:32:29 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/04/01 17:24:04 1.2 @@ -67,3 +67,24 @@ (defmethod medium-draw-image-design* :before (medium design x y) (assert (eq medium (slot-value design 'medium)))) + + +;;; Fetching protocol + +(defun sheet-rgb-image (sheet &key x y width height) + (multiple-value-bind (data alphap) + (sheet-rgb-data (port sheet) + sheet + :x x + :y y + :width width + :height height) + (destructuring-bind (height width) + (array-dimensions data) + (make-instance 'rgb-image + :width width + :height height + :data data + :alphap alphap)))) + +(defgeneric sheet-rgb-data (port sheet &key x y width height)) From thenriksen at common-lisp.net Fri Apr 6 23:54:49 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 6 Apr 2007 19:54:49 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070406235449.422DB4B006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26975 Modified Files: base.lisp Log Message: Extended our `constituentp' function to also accept #\#. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/02/06 09:25:43 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/04/06 23:54:48 1.6 @@ -332,7 +332,7 @@ (or (alphanumericp obj) (member obj '(#\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\: #\< #\= #\> #\? #\@ #\^ #\~ #\_ - #\{ #\} #\[ #\] ))))) + #\{ #\} #\[ #\] #\#))))) (defun buffer-whitespacep (obj) "Return T if `obj' is a basic whitespace character. This From thenriksen at common-lisp.net Mon Apr 9 22:59:28 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 9 Apr 2007 18:59:28 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070409225928.D12DA3144@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11562 Modified Files: lisp-syntax.lisp Log Message: Fixed issue about deleting parts of (in-package) forms at end of buffer. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/19 00:13:05 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 22:59:28 1.26 @@ -1461,8 +1461,8 @@ do (return t)) (loop for (offset . nil) in (package-list syntax) - unless (let ((form (form-around syntax offset))) - (form-list-p form)) + unless (and (>= (size buffer) offset) + (form-list-p (form-around syntax offset))) do (return t))))))) (defun update-package-list (buffer syntax) From thenriksen at common-lisp.net Mon Apr 9 23:06:55 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 9 Apr 2007 19:06:55 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070409230655.9CEDC3D019@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13770 Modified Files: lisp-syntax.lisp Log Message: Fixed issue in `expression-at-mark' that made it select the wrong form (often). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 22:59:28 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 23:06:55 1.27 @@ -1626,7 +1626,7 @@ "Return the form closest to `mark-or-offset'." (as-offsets ((offset mark-or-offset)) (flet ((distance (form) - (max (abs (- (start-offset form) mark-or-offset)) + (min (abs (- (start-offset form) mark-or-offset)) (abs (- (end-offset form) mark-or-offset))))) (reduce #'(lambda (form1 form2) (cond ((null form1) form2) From thenriksen at common-lisp.net Fri Apr 27 21:37:14 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 27 Apr 2007 17:37:14 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070427213714.76FEE3308F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19364 Modified Files: mcclim.asd Log Message: Merged splittist's work on splitting the general parts of the Lisp syntax's LR parser into an abstract syntax type. Also some supporting (mostly package) fixes needed to make it all still roll. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/03/14 23:33:24 1.55 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/04/27 21:37:14 1.56 @@ -311,7 +311,8 @@ (:file "misc-commands" :depends-on ("basic-commands")) (:file "unicode-commands" :depends-on ("core" "drei-clim")) (:file "search-commands" :depends-on ("core" "drei-clim")) - (:file "lisp-syntax" :depends-on ("motion" "fundamental-syntax" "core")) + (:file "lr-syntax" :depends-on ("fundamental-syntax" "core")) + (:file "lisp-syntax" :depends-on ("lr-syntax" "motion" "core")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) #+#.(mcclim.system::ifswank) (:file "lisp-syntax-swank" :depends-on ("lisp-syntax")))))) @@ -341,7 +342,7 @@ (:file "buffer-streams-tests" :depends-on ("testing")) (:file "rectangle-tests" :depends-on ("testing")) (:file "undo-tests" :depends-on ("testing")) - (:file "lisp-syntax-tests" :depends-on ("testing")))))) + (:file "lisp-syntax-tests" :depends-on ("testing" "motion-tests")))))) (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) From thenriksen at common-lisp.net Fri Apr 27 21:37:15 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 27 Apr 2007 17:37:15 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070427213715.63AFB360A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19364/Drei Modified Files: editing.lisp lisp-syntax.lisp motion.lisp packages.lisp Added Files: lr-syntax.lisp Log Message: Merged splittist's work on splitting the general parts of the Lisp syntax's LR parser into an abstract syntax type. Also some supporting (mostly package) fixes needed to make it all still roll. --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/29 09:59:00 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/04/27 21:37:14 1.5 @@ -364,3 +364,9 @@ (define-edit-fns expression) (define-edit-fns definition) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; List editing + +(define-edit-fns list) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 23:06:55 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/27 21:37:14 1.28 @@ -49,14 +49,8 @@ ;;; ;;; the syntax object -(define-syntax lisp-syntax (fundamental-syntax) - ((stack-top :initform nil) - (potentially-valid-trees) - (lookahead-lexeme :initform nil :accessor lookahead-lexeme) - (current-state) - (current-start-mark) - (current-size) - (package-list :accessor package-list +(define-syntax lisp-syntax (lr-syntax-mixin fundamental-syntax) + ((package-list :accessor package-list :documentation "An alist mapping the end offset of (in-package) forms to a string of the package designator in the form. The list is sorted with the earliest (in-package) forms @@ -79,7 +73,8 @@ syntax should be run.")) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") - (:command-table lisp-table)) + (:command-table lisp-table) + (:default-initargs :initial-state |initial-state |)) (defgeneric base (syntax) (:documentation "Get the base `syntax' should interpret numbers @@ -112,11 +107,6 @@ 0))))) (cons :base (format nil "~A" (base syntax))))) -(defmethod initialize-instance :after ((syntax lisp-syntax) &rest args) - (declare (ignore args)) - (with-slots (buffer scan) syntax - (setf scan (clone-mark (low-mark buffer) :left)))) - (defmethod name-for-info-pane ((syntax lisp-syntax) &key pane) (format nil "Lisp~@[:~(~A~)~]" (provided-package-name-at-mark syntax (point pane)))) @@ -232,36 +222,7 @@ (:method (image symbol-name default-package &optional limit) (declare (ignore image symbol-name default-package limit)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; lexer - -(defgeneric skip-inter (syntax state scan) - (:documentation "advance scan until the beginning of a new - lexeme. Return T if one can be found and NIL otherwise.")) - -(defgeneric lex (syntax state scan) - (:documentation "Return the next lexeme starting at scan.")) - -(defclass lexer-state () - () - (:documentation "These states are used to determine how the lexer - should behave.")) - -(defmacro define-lexer-state (name superclasses &body body) - `(defclass ,name (, at superclasses lexer-state) - , at body)) - -(define-lexer-state lexer-error-state () - () - (:documentation "In this state, the lexer returns error lexemes - consisting of entire lines of text")) - -(define-lexer-state lexer-toplevel-state () - () - (:documentation "In this state, the lexer assumes it can skip - whitespace and should recognize ordinary lexemes of the language - except for the right parenthesis")) +;;; Lexing (define-lexer-state lexer-list-state (lexer-toplevel-state) () @@ -288,61 +249,6 @@ (:documentation "In this state, the lexer is accumulating a token and an odd number of multiple escapes have been seen.")) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; this should go in syntax.lisp or lr-syntax.lisp -;;; and should inherit from parse-tree - -(defclass parser-symbol () - ((start-mark :initform nil :initarg :start-mark :reader start-mark) - (size :initform nil :initarg :size) - (parent :initform nil :accessor parent) - (children :initform '() :initarg :children :reader children) - (preceding-parse-tree :initform nil :reader preceding-parse-tree) - (parser-state :initform nil :initarg :parser-state :reader parser-state))) - -(defmethod start-offset ((state parser-symbol)) - (let ((mark (start-mark state))) - (when mark - (offset mark)))) - -(defmethod end-offset ((state parser-symbol)) - (with-slots (start-mark size) state - (when start-mark - (+ (offset start-mark) size)))) - -(defgeneric action (syntax state lexeme)) -(defgeneric new-state (syntax state parser-symbol)) - -(defclass parser-state () ()) - -(defmacro define-parser-state (name superclasses &body body) - `(progn - (defclass ,name ,superclasses - , at body) - (defvar ,name (make-instance ',name)))) - -(defclass lexeme (parser-symbol) ()) - -(defmethod print-object ((lexeme lexeme) stream) - (print-unreadable-object (lexeme stream :type t :identity t) - (format stream "~s ~s" (start-offset lexeme) (end-offset lexeme)))) - -(defclass nonterminal (parser-symbol) ()) - -(defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args) - (declare (ignore args)) - (with-slots (children start-mark size) parser-symbol - (loop for child in children - do (setf (parent child) parser-symbol)) - (let ((start (find-if-not #'null children :key #'start-offset)) - (end (find-if-not #'null children :key #'end-offset :from-end t))) - (when start - (setf start-mark (slot-value start 'start-mark) - size (- (end-offset end) (start-offset start))))))) - -;;; until here -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (defclass lisp-nonterminal (nonterminal) ()) (defclass form (lisp-nonterminal) ()) (defclass complete-form-mixin () ()) @@ -404,17 +310,6 @@ do (fo) finally (return t)))) -(defmethod lex :around (syntax state scan) - (when (skip-inter syntax state scan) - (let* ((start-offset (offset scan)) - (lexeme (call-next-method)) - (new-size (- (offset scan) start-offset))) - (with-slots (start-mark size) lexeme - (setf (offset scan) start-offset) - (setf start-mark scan - size new-size)) - lexeme))) - (defmethod lex ((syntax lisp-syntax) (state lexer-toplevel-state) scan) (macrolet ((fo () `(forward-object scan))) (let ((object (object-after scan))) @@ -725,65 +620,6 @@ `(defmethod new-state ((syntax lisp-syntax) (state ,state) (tree ,parser-symbol)) , at body)) -(defun pop-one (syntax) - (with-slots (stack-top current-state) syntax - (with-slots (preceding-parse-tree parser-state) stack-top - (prog1 stack-top - (setf current-state parser-state - stack-top preceding-parse-tree))))) - -(defun pop-number (syntax how-many) - (loop with result = '() - repeat how-many - do (push (pop-one syntax) result) - finally (return result))) - -(defmacro reduce-fixed-number (symbol nb-children) - `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children)))) - (when (zerop ,nb-children) - (with-slots (scan) syntax - (with-slots (start-mark size) result - (setf start-mark (clone-mark scan :right) - size 0)))) - result)) - -(defun pop-until-type (syntax type) - (with-slots (stack-top) syntax - (loop with result = '() - for child = stack-top - do (push (pop-one syntax) result) - until (typep child type) - finally (return result)))) - -(defmacro reduce-until-type (symbol type) - `(let ((result (make-instance ',symbol - :children (pop-until-type syntax ',type)))) - (when (null (children result)) - (with-slots (scan) syntax - (with-slots (start-mark size) result - (setf start-mark (clone-mark scan :right) - size 0)))) - result)) - -(defun pop-all (syntax) - (with-slots (stack-top) syntax - (loop with result = '() - until (null stack-top) - do (push (pop-one syntax) result) - finally (return result)))) - -(defmacro reduce-all (symbol) - `(let ((result (make-instance ',symbol :children (pop-all syntax)))) - (when (null (children result)) - (with-slots (scan) syntax - (with-slots (start-mark size) result - (setf start-mark (clone-mark scan :right) - size 0)))) - result)) - -(define-parser-state error-state (lexer-error-state parser-state) ()) -(define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ()) - (define-lisp-action (error-reduce-state (eql nil)) (throw 'done nil)) @@ -1271,102 +1107,6 @@ (define-lisp-action (|# form | t) (reduce-fixed-number undefined-reader-macro-form 2)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; parser step - -(defgeneric parser-step (syntax)) - -(defmethod parser-step ((syntax lisp-syntax)) - (with-slots (lookahead-lexeme stack-top current-state scan) syntax - (setf lookahead-lexeme (lex syntax current-state (clone-mark scan :right))) - (let* ((new-parser-symbol (action syntax current-state lookahead-lexeme)) - (new-state (new-state syntax current-state new-parser-symbol))) - (with-slots (parser-state parser-symbol preceding-parse-tree children) new-parser-symbol - (setf parser-state current-state - current-state new-state - preceding-parse-tree stack-top - stack-top new-parser-symbol))) - (setf (offset scan) (end-offset stack-top)))) - -(defun prev-tree (tree) - (assert (not (null tree))) - (if (null (children tree)) - (preceding-parse-tree tree) - (car (last (children tree))))) - -(defun next-tree (tree) - (assert (not (null tree))) - (if (null (parent tree)) - nil - (let* ((parent (parent tree)) - (siblings (children parent))) - (cond ((null parent) nil) - ((eq tree (car (last siblings))) parent) - (t (loop with new-tree = (cadr (member tree siblings :test #'eq)) - until (null (children new-tree)) - do (setf new-tree (car (children new-tree))) - finally (return new-tree))))))) - -(defun find-last-valid-lexeme (parse-tree offset) - (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil) - ((> (start-offset parse-tree) offset) - (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) - ((not (typep parse-tree 'lexeme)) - (find-last-valid-lexeme (car (last (children parse-tree))) offset)) - ((>= (end-offset parse-tree) offset) - (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) - (t parse-tree))) - -(defun find-first-potentially-valid-lexeme (parse-trees offset) - (cond ((null parse-trees) nil) - ((or (null (start-offset (car parse-trees))) - (< (end-offset (car parse-trees)) offset)) - (find-first-potentially-valid-lexeme (cdr parse-trees) offset)) - ((not (typep (car parse-trees) 'lexeme)) - (find-first-potentially-valid-lexeme (children (car parse-trees)) offset)) - ((<= (start-offset (car parse-trees)) offset) - (loop with tree = (next-tree (car parse-trees)) - until (or (null tree) (> (start-offset tree) offset)) - do (setf tree (next-tree tree)) - finally (return tree))) - (t (car parse-trees)))) - -(defun parse-tree-equal (tree1 tree2) - (and (eq (class-of tree1) (class-of tree2)) - (eq (parser-state tree1) (parser-state tree2)) - (= (end-offset tree1) (end-offset tree2)))) - -(defmethod print-object ((mark mark) stream) - (print-unreadable-object (mark stream :type t :identity t) - (format stream "~s" (offset mark)))) - -(defun parse-patch (syntax) - (with-slots (current-state stack-top scan potentially-valid-trees) syntax - (parser-step syntax) - (finish-output *trace-output*) - (cond ((parse-tree-equal stack-top potentially-valid-trees) - (unless (or (null (parent potentially-valid-trees)) - (eq potentially-valid-trees - (car (last (children (parent potentially-valid-trees)))))) - (loop for tree = (cadr (member potentially-valid-trees - (children (parent potentially-valid-trees)) - :test #'eq)) - then (car (children tree)) - until (null tree) - do (setf (slot-value tree 'preceding-parse-tree) - stack-top)) - (setf stack-top (prev-tree (parent potentially-valid-trees)))) - (setf potentially-valid-trees (parent potentially-valid-trees)) - (setf current-state (new-state syntax (parser-state stack-top) stack-top)) - (setf (offset scan) (end-offset stack-top))) - (t (loop until (or (null potentially-valid-trees) - (>= (start-offset potentially-valid-trees) - (end-offset stack-top))) - do (setf potentially-valid-trees - (next-tree potentially-valid-trees))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax @@ -1486,27 +1226,9 @@ (extract child)) (package-list syntax)))))) -(defmethod update-syntax (buffer (syntax lisp-syntax)) - (let* ((low-mark (low-mark buffer)) - (high-mark (high-mark buffer))) - (when (mark<= low-mark high-mark) - (catch 'done - (with-slots (current-state stack-top scan potentially-valid-trees) syntax - (setf potentially-valid-trees - (if (null stack-top) - nil - (find-first-potentially-valid-lexeme (children stack-top) - (offset high-mark)))) - (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark))) - (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top)) - current-state (if (null stack-top) - |initial-state | - (new-state syntax - (parser-state stack-top) - stack-top))) - (loop do (parse-patch syntax))))) - (when (need-to-update-package-list-p buffer syntax) - (update-package-list buffer syntax)))) +(defmethod update-syntax :after (buffer (syntax lisp-syntax)) + (when (need-to-update-package-list-p buffer syntax) + (update-package-list buffer syntax))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/30 17:00:09 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/04/27 21:37:14 1.4 @@ -499,6 +499,26 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; List motion + +(defgeneric backward-one-list (mark syntax) + (:documentation + "Move MARK backward by one list. +Return T if successful, or NIL if the buffer limit was reached.") + (:method (mark syntax) + (error 'no-such-operation))) + +(defgeneric forward-one-list (mark syntax) + (:documentation + "Move MARK forward by one list. +Return T if successful, or NIL if the buffer limit was reached.") + (:method (mark syntax) + (error 'no-such-operation))) + +(define-motion-fns list) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Sentence motion (defgeneric backward-one-sentence (mark syntax) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/02/13 12:14:12 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/04/27 21:37:14 1.14 @@ -160,13 +160,9 @@ #:name-for-info-pane #:display-syntax-name #:syntax-line-indentation - #:forward-expression #:backward-expression #:eval-defun #:record-line-vertical-offset #:line-vertical-offset - #:backward-paragraph #:forward-paragraph - #:backward-sentence #:forward-sentence - #:forward-list #:backward-list #:syntax-line-comment-string #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region @@ -331,7 +327,13 @@ #:forward-one-sentence #:backward-one-sentence #:forward-sentence - #:backward-sentence) + #:backward-sentence + + ;; Lists + #:forward-one-list + #:backward-one-list + #:forward-list + #:backward-list) (:documentation "Functions and facilities for moving a mark around by syntactical elements. The functions in this package are syntax-aware, and their behavior is based on the semantics @@ -384,7 +386,12 @@ ;; Sentences #:forward-delete-sentence #:backward-delete-sentence #:forward-kill-sentence #:backward-kill-sentence - #:transpose-sentences) + #:transpose-sentences + + ;; Lists + #:forward-delete-list #:backward-delete-list + #:forward-kill-list #:backward-kill-list + #:transpose-list) (:documentation "Functions and facilities for changing the buffer contents by syntactical elements. The functions in this package are syntax-aware, and their behavior is based on the @@ -437,17 +444,33 @@ (:documentation "Implementation of the basic syntax module for editing plain text.")) +(defpackage :drei-lr-syntax + (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base + :drei-syntax :drei-fundamental-syntax) + (:export #:lr-syntax-mixin #:stack-top #:initial-state + #:skip-inter #:lex #:define-lexer-state + #:lexer-toplevel-state #:lexer-error-state + #:parser-symbol #:parent #:children + #:start-offset #:end-offset #:parser-state + #:preceding-parse-tree + #:define-parser-state + #:lexeme #:nonterminal + #:action #:new-state #:done + #:reduce-fixed-number #:reduce-until-type #:reduce-all + #:error-state #:error-reduce-state) + (:documentation "Underlying LR parsing functionality.")) + (defpackage :drei-lisp-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei-fundamental-syntax :flexichain :drei - :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io) + :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io + :drei-lr-syntax) (:export #:lisp-syntax #:lisp-string #:edit-definition #:form #:form-to-object - #:form-conversion-error - #:forward-one-list #:backward-one-list #:forward-list #:backward-list) + #:form-conversion-error) (:shadow clim:form) (:documentation "Implementation of the syntax module used for editing Common Lisp code.")) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/04/27 21:37:15 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/04/27 21:37:15 1.1 ;; -*- Mode: Lisp; Package: DREI-LR-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; (c) copyright 2007 by ;;; John Q Splittist (splittist at gmail.com) ;;; ;;; 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. ;;; Base lexing and parsing functionality of ;;; syntax modules for analysing languages (in-package :drei-lr-syntax) (defclass lr-syntax-mixin () ((stack-top :initform nil) (potentially-valid-trees) (lookahead-lexeme :initform nil :accessor lookahead-lexeme) (current-state) (initial-state :initarg :initial-state) (current-start-mark) (current-size))) (defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args) (declare (ignore args)) (with-slots (buffer scan) syntax (setf scan (clone-mark (low-mark buffer) :left)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer (defgeneric skip-inter (syntax state scan) (:documentation "advance scan until the beginning of a new lexeme. Return T if one can be found and NIL otherwise.")) (defgeneric lex (syntax state scan) (:documentation "Return the next lexeme starting at scan.")) (defmethod lex :around (syntax state scan) (when (skip-inter syntax state scan) (let* ((start-offset (offset scan)) (lexeme (call-next-method)) (new-size (- (offset scan) start-offset))) (with-slots (start-mark size) lexeme (setf (offset scan) start-offset) (setf start-mark scan size new-size)) lexeme))) (defclass lexer-state () () (:documentation "These states are used to determine how the lexer should behave.")) (defmacro define-lexer-state (name superclasses &body body) `(defclass ,name (, at superclasses lexer-state) , at body)) (define-lexer-state lexer-error-state () () (:documentation "In this state, the lexer returns error lexemes consisting of entire lines of text")) (define-lexer-state lexer-toplevel-state () () (:documentation "In this state, the lexer assumes it can skip whitespace and should recognize ordinary lexemes of the language.")) (defclass parser-symbol () ((start-mark :initform nil :initarg :start-mark :reader start-mark) (size :initform nil :initarg :size) (parent :initform nil :accessor parent) (children :initform '() :initarg :children :reader children) (preceding-parse-tree :initform nil :reader preceding-parse-tree) (parser-state :initform nil :initarg :parser-state :reader parser-state))) (defmethod start-offset ((state parser-symbol)) (let ((mark (start-mark state))) (when mark (offset mark)))) (defmethod end-offset ((state parser-symbol)) (with-slots (start-mark size) state (when start-mark (+ (offset start-mark) size)))) (defgeneric action (syntax state lexeme)) (defgeneric new-state (syntax state parser-symbol)) (defclass parser-state () ()) (defmacro define-parser-state (name superclasses &body body) `(progn (defclass ,name ,superclasses , at body) (defvar ,name (make-instance ',name)))) (defclass lexeme (parser-symbol) ()) (defmethod print-object ((lexeme lexeme) stream) (print-unreadable-object (lexeme stream :type t :identity t) (format stream "~s ~s" (start-offset lexeme) (end-offset lexeme)))) (defclass nonterminal (parser-symbol) ()) (defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args) (declare (ignore args)) (with-slots (children start-mark size) parser-symbol (loop for child in children do (setf (parent child) parser-symbol)) (let ((start (find-if-not #'null children :key #'start-offset)) (end (find-if-not #'null children :key #'end-offset :from-end t))) (when start (setf start-mark (slot-value start 'start-mark) size (- (end-offset end) (start-offset start))))))) (defun pop-one (syntax) (with-slots (stack-top current-state) syntax (with-slots (preceding-parse-tree parser-state) stack-top (prog1 stack-top (setf current-state parser-state stack-top preceding-parse-tree))))) (defun pop-number (syntax how-many) (loop with result = '() repeat how-many do (push (pop-one syntax) result) finally (return result))) (defmacro reduce-fixed-number (symbol nb-children) `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children)))) (when (zerop ,nb-children) (with-slots (scan) syntax (with-slots (start-mark size) result (setf start-mark (clone-mark scan :right) size 0)))) result)) (defun pop-until-type (syntax type) (with-slots (stack-top) syntax (loop with result = '() for child = stack-top do (push (pop-one syntax) result) until (typep child type) finally (return result)))) (defmacro reduce-until-type (symbol type) `(let ((result (make-instance ',symbol :children (pop-until-type syntax ',type)))) (when (null (children result)) (with-slots (scan) syntax (with-slots (start-mark size) result (setf start-mark (clone-mark scan :right) size 0)))) result)) (defun pop-all (syntax) (with-slots (stack-top) syntax (loop with result = '() until (null stack-top) do (push (pop-one syntax) result) finally (return result)))) (defmacro reduce-all (symbol) `(let ((result (make-instance ',symbol :children (pop-all syntax)))) (when (null (children result)) (with-slots (scan) syntax (with-slots (start-mark size) result (setf start-mark (clone-mark scan :right) size 0)))) result)) (define-parser-state error-state (lexer-error-state parser-state) ()) (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; parser step (defgeneric parser-step (syntax)) (defmethod parser-step ((syntax lr-syntax-mixin)) (with-slots (lookahead-lexeme stack-top current-state scan) syntax (setf lookahead-lexeme (lex syntax current-state (clone-mark scan :right))) (let* ((new-parser-symbol (action syntax current-state lookahead-lexeme)) (new-state (new-state syntax current-state new-parser-symbol))) (with-slots (parser-state parser-symbol preceding-parse-tree children) new-parser-symbol (setf parser-state current-state current-state new-state preceding-parse-tree stack-top stack-top new-parser-symbol))) (setf (offset scan) (end-offset stack-top)))) (defun prev-tree (tree) (assert (not (null tree))) (if (null (children tree)) (preceding-parse-tree tree) (car (last (children tree))))) (defun next-tree (tree) (assert (not (null tree))) (if (null (parent tree)) nil (let* ((parent (parent tree)) (siblings (children parent))) (cond ((null parent) nil) ((eq tree (car (last siblings))) parent) (t (loop with new-tree = (cadr (member tree siblings :test #'eq)) until (null (children new-tree)) do (setf new-tree (car (children new-tree))) finally (return new-tree))))))) (defun find-last-valid-lexeme (parse-tree offset) (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil) ((> (start-offset parse-tree) offset) (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) ((not (typep parse-tree 'lexeme)) (find-last-valid-lexeme (car (last (children parse-tree))) offset)) ((>= (end-offset parse-tree) offset) (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) (t parse-tree))) (defun find-first-potentially-valid-lexeme (parse-trees offset) (cond ((null parse-trees) nil) ((or (null (start-offset (car parse-trees))) (< (end-offset (car parse-trees)) offset)) (find-first-potentially-valid-lexeme (cdr parse-trees) offset)) ((not (typep (car parse-trees) 'lexeme)) (find-first-potentially-valid-lexeme (children (car parse-trees)) offset)) ((<= (start-offset (car parse-trees)) offset) (loop with tree = (next-tree (car parse-trees)) until (or (null tree) (> (start-offset tree) offset)) do (setf tree (next-tree tree)) finally (return tree))) (t (car parse-trees)))) (defun parse-tree-equal (tree1 tree2) (and (eq (class-of tree1) (class-of tree2)) (eq (parser-state tree1) (parser-state tree2)) (= (end-offset tree1) (end-offset tree2)))) (defmethod print-object ((mark mark) stream) (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) (defun parse-patch (syntax) (with-slots (current-state stack-top scan potentially-valid-trees) syntax (parser-step syntax) (finish-output *trace-output*) (cond ((parse-tree-equal stack-top potentially-valid-trees) (unless (or (null (parent potentially-valid-trees)) (eq potentially-valid-trees (car (last (children (parent potentially-valid-trees)))))) (loop for tree = (cadr (member potentially-valid-trees (children (parent potentially-valid-trees)) :test #'eq)) then (car (children tree)) until (null tree) do (setf (slot-value tree 'preceding-parse-tree) stack-top)) (setf stack-top (prev-tree (parent potentially-valid-trees)))) (setf potentially-valid-trees (parent potentially-valid-trees)) (setf current-state (new-state syntax (parser-state stack-top) stack-top)) (setf (offset scan) (end-offset stack-top))) (t (loop until (or (null potentially-valid-trees) (>= (start-offset potentially-valid-trees) (end-offset stack-top))) do (setf potentially-valid-trees (next-tree potentially-valid-trees))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax (defmethod update-syntax-for-display (buffer (syntax lr-syntax-mixin) top bot) nil) (defmethod update-syntax (buffer (syntax lr-syntax-mixin)) (let* ((low-mark (low-mark buffer)) (high-mark (high-mark buffer))) (when (mark<= low-mark high-mark) (catch 'done (with-slots (current-state stack-top scan potentially-valid-trees initial-state) syntax (setf potentially-valid-trees (if (null stack-top) nil (find-first-potentially-valid-lexeme (children stack-top) (offset high-mark)))) (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark))) (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top)) current-state (if (null stack-top) initial-state (new-state syntax (parser-state stack-top) stack-top))) (loop do (parse-patch syntax))))))) From thenriksen at common-lisp.net Fri Apr 27 21:37:15 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 27 Apr 2007 17:37:15 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070427213715.0C0AE360A4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv19364/Drei/Tests Modified Files: motion-tests.lisp Log Message: Merged splittist's work on splitting the general parts of the Lisp syntax's LR parser into an abstract syntax type. Also some supporting (mostly package) fixes needed to make it all still roll. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/02/17 17:54:06 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/04/27 21:37:15 1.3 @@ -102,7 +102,7 @@ (let ((forward (intern (format nil "FORWARD-ONE-~S" unit))) (backward (intern (format nil "BACKWARD-ONE-~S" unit)))) `(progn - (test ,(intern (format nil "~A-~A" syntax forward)) + (test ,(intern (format nil "~A-~A" syntax forward) #.*package*) (with-buffer (buffer :initial-contents ,initial-contents :syntax ',syntax) (let ((syntax (syntax buffer)) @@ -134,7 +134,7 @@ (is (= (size buffer) (offset m2l))) (is-false (,forward m2r syntax)) (is (= (size buffer) (offset m2r)))))) - (test ,(intern (format nil "~A-~A" syntax backward)) + (test ,(intern (format nil "~A-~A" syntax backward) #.*package*) (with-buffer (buffer :initial-contents ,initial-contents :syntax ',syntax) (let ((syntax (syntax buffer)) @@ -207,8 +207,8 @@ (check-type offset integer) (check-type goal-forward-offset integer) (check-type goal-backward-offset integer) - (let ((forward (intern (format nil "FORWARD-~S" unit))) - (backward (intern (format nil "BACKWARD-~S" unit)))) + (let ((forward (intern (format nil "FORWARD-~S" unit) #.*package*)) + (backward (intern (format nil "BACKWARD-~S" unit) #.*package*))) `(progn (test ,forward (with-buffer (buffer :initial-contents ,initial-contents