mcclim-cvs February 2007

mcclim-cvs@common-lisp.net

6 participants
56 discussions

[mcclim-cvs] CVS mcclim/ESA
by crhodes 21 Feb '07

21 Feb '07

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24730/ESA Modified Files: esa.lisp Log Message: Fix M-digit handling (now does more than two digits!) --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/02/07 12:44:21 1.5 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/02/21 12:35:36 1.6 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Emacs-Style Appication +;;; Emacs-Style Application (in-package :esa) @@ -621,6 +621,7 @@ do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) (pop gestures) + finally (return (values (if (and (= sign -1) (= numarg 0)) -1 (* sign numarg))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 19 Feb '07

19 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15305 Modified Files: lisp-syntax.lisp Log Message: Made Lisp and Fundamental syntax handle case where the tab width is zero (hello Null backend!) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/17 17:54:06 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/19 00:13:05 1.25 @@ -1796,9 +1796,10 @@ pane (first (aref cursor-positions 0)) 0)) ((#\Page #\Return #\Space) (stream-increment-cursor-position pane space-width 0)) - (#\Tab (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0)))) + (#\Tab (when (plusp tab-width) + (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0))))) (incf start)))))) (defgeneric display-parse-tree (parse-symbol stream drei syntax)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 19 Feb '07

19 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15239 Modified Files: input-editor.lisp fundamental-syntax.lisp Log Message: Made Lisp and Fundamental syntax handle case where the tab width is zero (hello Null backend!) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/01/13 21:09:51 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/02/19 00:12:22 1.17 @@ -164,7 +164,7 @@ ;; position properly (ie. after the prompt). (loop with buffer = (buffer (drei-instance stream)) - until (= (stream-scan-pointer stream) (size buffer)) + until (>= (stream-scan-pointer stream) (size buffer)) while (typep (buffer-object buffer (stream-scan-pointer stream)) 'noise-string) do (incf (stream-scan-pointer stream))) --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2007/02/06 09:10:51 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2007/02/19 00:12:22 1.5 @@ -111,9 +111,10 @@ pane (first (aref cursor-positions 0)) 0)) ((#\Page #\Return #\Space) (stream-increment-cursor-position pane space-width 0)) - (#\Tab (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0)))) + (#\Tab (when (plusp tab-width) + (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0))))) (incf start)))))) (defmethod display-line ((stream clim-stream-pane) (drei drei) mark)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 17 Feb '07

17 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13162 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-swank.lisp Log Message: Tightened the nuts and bolts of Lisp syntax and added a bunch of tests to make relatively sure there are no regressions. No tests for Swine yet, but "it seems to work". Also fixes very major performance issue with redisplay of literal objects in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 10:03:16 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/17 17:54:06 1.24 @@ -387,7 +387,7 @@ (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) -(defclass number-lexeme (form-lexeme complete-form-mixin) ()) +(defclass number-lexeme (complete-token-lexeme) ()) (defclass token-mixin () ()) (defclass literal-object-form (form-lexeme complete-form-mixin) ()) (defclass complete-token-lexeme (token-mixin form-lexeme complete-form-mixin) ()) @@ -1011,15 +1011,19 @@ (define-parser-state |' | (form-may-follow) ()) (define-parser-state |' form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |' incomplete-form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow quote-lexeme) |' |) (define-new-lisp-state (|' | complete-form-mixin) |' form |) +(define-new-lisp-state (|' | incomplete-form-mixin) |' incomplete-form |) (define-new-lisp-state (|' | comment) |' |) (define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) (reduce-until-type complete-quote-form quote-lexeme)) +(define-lisp-action (|' incomplete-form | t) + (reduce-until-type incomplete-quote-form quote-lexeme)) (define-lisp-action (|' | right-parenthesis-lexeme) (reduce-until-type incomplete-quote-form quote-lexeme)) @@ -1090,8 +1094,8 @@ ;;; parse trees (defclass function-form (form) ()) -(defclass complete-function-form (form complete-form-mixin) ()) -(defclass incomplete-function-form (form incomplete-form-mixin) ()) +(defclass complete-function-form (function-form complete-form-mixin) ()) +(defclass incomplete-function-form (function-form incomplete-form-mixin) ()) (define-parser-state |#' | (form-may-follow) ()) (define-parser-state |#' form | (lexer-toplevel-state parser-state) ()) @@ -1142,7 +1146,7 @@ ;;;;;;;;;;;;;;;; uninterned symbol ;;; parse trees -(defclass uninterned-symbol-form (form complete-form-mixin) ()) +(defclass uninterned-symbol-form (complete-token-form) ()) (define-parser-state |#: | (form-may-follow) ()) (define-parser-state |#: form | (lexer-toplevel-state parser-state) ()) @@ -1237,14 +1241,18 @@ (define-parser-state |#P | (form-may-follow) ()) (define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |#P incomplete-form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow pathname-start-lexeme) |#P |) (define-new-lisp-state (|#P | complete-form-mixin) |#P form |) +(define-new-lisp-state (|#P | incomplete-form-mixin) |#P incomplete-form |) (define-new-lisp-state (|#P | comment) |#P |) ;;; reduce according to the rule form -> #P form (define-lisp-action (|#P form | t) (reduce-until-type complete-pathname-form pathname-start-lexeme)) +(define-lisp-action (|#P incomplete-form | t) + (reduce-until-type incomplete-pathname-form pathname-start-lexeme)) (define-lisp-action (|#P | (eql nil)) (reduce-until-type incomplete-pathname-form pathname-start-lexeme)) @@ -1593,21 +1601,21 @@ (defmethod form-operands (syntax (form list-form)) (remove-if-not #'formp (rest-forms (children form)))) -(defun form-toplevel (form syntax) +(defun form-toplevel (syntax form) "Return the top-level form of `form'." (if (null (parent (parent form))) form - (form-toplevel (parent form) syntax))) + (form-toplevel syntax (parent form)))) -(defgeneric form-operator-p (token syntax) - (:documentation "Return true if `token' is the operator of its form. Otherwise, - return nil.") - (:method (token syntax) +(defgeneric form-operator-p (syntax token) + (:documentation "Return true if `token' is the operator of its + form. Otherwise, return nil.") + (:method ((syntax lisp-syntax) (token lisp-lexeme)) (with-accessors ((pre-token preceding-parse-tree)) token (cond ((typep pre-token 'left-parenthesis-lexeme) t) ((comment-p pre-token) - (form-operator-p pre-token syntax)) + (form-operator-p syntax pre-token)) (t nil))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1615,15 +1623,20 @@ ;;; Useful functions for selecting forms based on the mark. (defun expression-at-mark (syntax mark-or-offset) - "Return the form at `mark-or-offset'. If `mark-or-offset' is just after, -or inside, a top-level-form, or if there are no forms after -`mark-or-offset', the form preceding `mark-or-offset' is -returned. Otherwise, the form following `mark-or-offset' is -returned." + "Return the form closest to `mark-or-offset'." (as-offsets ((offset mark-or-offset)) - (or (form-around syntax offset) - (form-after syntax offset) - (form-before syntax offset)))) + (flet ((distance (form) + (max (abs (- (start-offset form) mark-or-offset)) + (abs (- (end-offset form) mark-or-offset))))) + (reduce #'(lambda (form1 form2) + (cond ((null form1) form2) + ((null form2) form1) + ((> (distance form1) (distance form2)) + form2) + (t form1))) + (list (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset)))))) (defun definition-at-mark (syntax mark-or-offset) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, @@ -1631,7 +1644,7 @@ `mark-or-offset', the top-level-form preceding `mark-or-offset' is returned. Otherwise, the top-level-form following `mark-or-offset' is returned." - (form-toplevel (expression-at-mark mark-or-offset syntax) syntax)) + (form-toplevel syntax (expression-at-mark syntax mark-or-offset))) (defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) @@ -1641,12 +1654,10 @@ must be a function with the same signature as `expression-at-mark', and will be used to retrieve the initial form at `mark'." (as-offsets (mark-or-offset) - (labels ((unwrap-form (form) - (cond ((form-quoted-p form) - (unwrap-form (first-form (children form)))) - ((form-token-p form) - form)))) - (unwrap-form (funcall form-fetcher syntax mark-or-offset))))) + (let ((unwrapped-form (fully-unquoted-form + (funcall form-fetcher syntax mark-or-offset)))) + (when (form-token-p unwrapped-form) + unwrapped-form)))) (defun fully-quoted-form (token) "Return the top token object for `token', return `token' or the @@ -1673,29 +1684,6 @@ (or (form-around syntax offset) (form-before syntax offset)))) -(defun preceding-form (syntax mark-or-offset) - "Return a form at `mark-or-offset'." - (as-offsets ((offset mark-or-offset)) - (or (form-before syntax offset) - (form-around syntax offset)))) - -(defun text-of-definition-at-mark (syntax mark) - "Return the text of the definition at mark." - (let ((definition (definition-at-mark mark syntax))) - (buffer-substring (buffer mark) - (start-offset definition) - (end-offset definition)))) - -(defun text-of-expression-at-mark (syntax mark-or-offset) - "Return the text of the expression at `mark-or-offset'." - (let ((expression (expression-at-mark mark-or-offset syntax))) - (form-string syntax expression))) - -(defun symbol-name-at-mark (syntax mark-or-offset) - "Return the text of the symbol at `mark-or-offset'." - (let ((token (symbol-at-mark syntax mark-or-offset))) - (when token (form-string syntax token)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Querying forms for data @@ -1744,8 +1732,8 @@ (defmethod replace-symbol-at-mark ((syntax lisp-syntax) (mark mark) (string string)) - (let ((token (symbol-at-mark syntax mark #'form-around))) - (when (and token (form-token-p token)) + (let ((token (symbol-at-mark syntax mark))) + (when token (setf (offset mark) (start-offset token)) (forward-delete-expression mark syntax)) (insert-sequence mark string))) @@ -1873,12 +1861,14 @@ ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) (with-face (:lambda-list-keyword) (call-next-method))) - ((and (macro-function symbol) - (form-operator-p parse-symbol syntax)) + ((and (symbolp symbol) + (macro-function symbol) + (form-operator-p syntax parse-symbol)) (with-face (:macro) (call-next-method))) - ((and (special-operator-p symbol) - (form-operator-p parse-symbol syntax)) + ((and (symbolp symbol) + (special-operator-p symbol) + (form-operator-p syntax parse-symbol)) (with-face (:special-form) (call-next-method))) (t (call-next-method))))) @@ -2095,6 +2085,10 @@ (t nil)))) (defun form-before (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (<= offset (start-offset stack-top))) @@ -2120,6 +2114,10 @@ (t nil)))) (defun form-after (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (>= offset (end-offset stack-top))) @@ -2133,16 +2131,18 @@ (= offset (end-offset child)) (= offset (start-offset child))) (return (if (null (first-form (children child))) - (when (formp child) - child) + child (or (form-around-in-children (children child) offset) - (when (formp child) - child))))) + child)))) ((< offset (start-offset child)) (return nil)) (t nil)))) (defun form-around (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) @@ -2151,16 +2151,14 @@ (form-around-in-children (children stack-top) offset)))) (defun find-list-parent-offset (form fn) - "Find a list parent of `token' and return `fn' -applied to this parent token. `Fn' should be a function -that returns an offset when applied to a -token (eg. `start-offset' or `end-offset'). If a list -parent cannot be found, return `fn' applied to `form'." + "Find a list parent of `form' and return `fn' applied to this +parent token. `Fn' should be a function that returns an offset +when applied to a token (eg. `start-offset' or `end-offset'). If +a list parent cannot be found, return nil" (let ((parent (parent form))) (typecase parent - (form* (funcall fn form)) (list-form (funcall fn form)) - (null (funcall fn form)) + ((or form* null) nil) (t (find-list-parent-offset parent fn))))) (defun find-list-child-offset (form fn &optional (min-offset 0)) @@ -2196,8 +2194,7 @@ (setf (offset mark) (end-offset potential-form))))) (defgeneric forward-one-list (mark syntax) - (:documentation - "Move `mark' forward by one list. + (:documentation "Move `mark' forward by one list. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-list (mark (syntax lisp-syntax)) @@ -2214,9 +2211,8 @@ (return t))) (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.")) + (:documentation "Move `mark' backward by one list. Return T if +successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-list (mark (syntax lisp-syntax)) (loop for start = (offset mark) @@ -2233,103 +2229,91 @@ (drei-motion:define-motion-fns list) -(defun down-list-by-fn (mark syntax fn) - (let* ((offset (offset mark)) - (potential-form (form-after syntax offset))) - (let ((new-offset (typecase potential-form - (list-form (start-offset potential-form)) - (null nil) - (t (find-list-child-offset - (parent potential-form) - fn - offset))))) +(defun down-list (mark syntax selector next-offset-fn target-offset-fn) + (labels ((find-offset (potential-form) + (typecase potential-form + (list-form (funcall target-offset-fn potential-form)) + (null nil) + (t (find-offset (funcall selector syntax + (funcall next-offset-fn potential-form))))))) + (let ((new-offset (find-offset (funcall selector syntax (offset mark))))) (when new-offset - (progn (setf (offset mark) (1+ new-offset)) t))))) + (setf (offset mark) new-offset) + t)))) -(defmethod forward-one-down (mark (syntax lisp-syntax)) - (down-list-by-fn mark syntax #'start-offset)) +(defmethod forward-one-down ((mark mark) (syntax lisp-syntax)) + (when (down-list mark syntax #'form-after #'end-offset #'start-offset) + (forward-object mark))) + +(defmethod backward-one-down ((mark mark) (syntax lisp-syntax)) + (when (down-list mark syntax #'form-before #'start-offset #'end-offset) + (backward-object mark))) -(defmethod backward-one-down (mark (syntax lisp-syntax)) - (down-list-by-fn mark syntax #'end-offset) - (backward-object mark syntax)) - -(defun up-list-by-fn (mark syntax fn) - (let ((form (or (form-before syntax (offset mark)) - (form-after syntax (offset mark)) - (form-around syntax (offset mark))))) +(defun up-list (mark syntax fn) + (let ((form (form-around syntax (offset mark)))) (when form - (let ((parent (parent form))) - (when (not (null parent)) - (let ((new-offset (find-list-parent-offset parent fn))) - (when new-offset - (setf (offset mark) new-offset)))))))) + (let ((new-offset (find-list-parent-offset form fn))) + (when new-offset + (setf (offset mark) new-offset) + t))))) (defmethod backward-one-up (mark (syntax lisp-syntax)) - (up-list-by-fn mark syntax #'start-offset)) + (up-list mark syntax #'start-offset)) (defmethod forward-one-up (mark (syntax lisp-syntax)) - (up-list-by-fn mark syntax #'end-offset)) + (up-list mark syntax #'end-offset)) -(defmethod eval-defun (mark (syntax lisp-syntax)) +(defmethod backward-one-definition ((mark mark) (syntax lisp-syntax)) (with-slots (stack-top) syntax - (loop for form in (children stack-top) - when (and (mark<= (start-offset form) mark) - (mark<= mark (end-offset form))) - do (return (eval-form-for-drei - (get-usable-image syntax) - (form-to-object syntax form :read t)))))) + ;; FIXME? This conses! I'm over it already. I don't think it + ;; matters much, but if someone is bored, please profile it. + (loop for form in (reverse (children stack-top)) + when (and (formp form) + (mark> mark (start-offset form))) + do (setf (offset mark) (start-offset form)) + and do (return t)))) -(defmethod backward-one-definition (mark (syntax lisp-syntax)) +(defmethod forward-one-definition ((mark mark) (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) - with last-toplevel-list = nil - when (and (formp form) - (mark< mark (end-offset form))) - do (if (mark< (start-offset form) mark) - (setf (offset mark) (start-offset form)) - (when last-toplevel-list form - (setf (offset mark) (start-offset last-toplevel-list)))) - (return t) - when (formp form) - do (setf last-toplevel-list form) [325 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/02/06 09:25:08 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/02/17 17:54:06 1.6 @@ -328,7 +328,8 @@ provided-args))) (defun cleanup-arglist (arglist) - "Remove elements of `arglist' that we are not interested in." + "Remove elements of `arglist' that we are not interested in, +including implementation-specific lambda list keywords." (loop for arg in arglist with in-&aux ; If non-NIL, we are in the @@ -349,6 +350,11 @@ else collect arg)) +(defun canonicalize-arglist (arglist) + "Convert `arglist' to the Grand Unified Arglist Format used by +Drei, and signal errors if the arglist is found to be invalid." + arglist) + (defun find-argument-indices-for-operand (syntax operand-form operator-form) "Return a list of argument indices for `argument-form' relative to `operator-form'. These lists take the form of (n m p), which @@ -783,7 +789,7 @@ `(let* ((,form-sym ;; Find a form with a valid (fboundp) operator. (let ((immediate-form - (preceding-form ,syntax ,mark-or-offset))) + (this-form ,syntax ,mark-or-offset))) (unless (null immediate-form) (or (find-applicable-form ,syntax immediate-form) ;; If nothing else can be found, and `arg-form' --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/01/07 19:48:16 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/02/17 17:54:06 1.3 @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX; -*- -;;; (c) copyright 2005-2006 by +;;; (c) copyright 2005-2007 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; David Murray (splittist(a)yahoo.com) ;;; Troels Henriksen (athas(a)sigkill.dk)

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 17 Feb '07

17 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv13162/Tests Modified Files: testing.lisp motion-tests.lisp lisp-syntax-tests.lisp Log Message: Tightened the nuts and bolts of Lisp syntax and added a bunch of tests to make relatively sure there are no regressions. No tests for Swine yet, but "it seems to work". Also fixes very major performance issue with redisplay of literal objects in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/01/15 11:35:53 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/02/17 17:54:06 1.4 @@ -76,8 +76,7 @@ (begin-offset 0) (end-offset (size buffer))) "Check (using FiveAM) whether `buffer' contains `string' in the subsequence delimited by `begin-offset' and `end-offset'." - (is (string= (buffer-substring buffer begin-offset end-offset) - string))) + (is (string= string (buffer-substring buffer begin-offset end-offset)))) (defclass test-drei (drei) () --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/02/17 17:54:06 1.2 @@ -1,8 +1,7 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -;;; (c) copyright 2005 by +;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) -;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -94,18 +93,18 @@ backward-end-offset (offset goal-forward-offset goal-backward-offset) initial-contents - &key (syntax ''drei-fundamental-syntax:fundamental-syntax))) - (check-type forward-begin-offset integer) - (check-type backward-end-offset integer) + &key (syntax 'drei-fundamental-syntax:fundamental-syntax))) + (check-type forward-begin-offset (or integer null)) + (check-type backward-end-offset (or integer null)) (check-type offset integer) (check-type goal-forward-offset integer) (check-type goal-backward-offset integer) (let ((forward (intern (format nil "FORWARD-ONE-~S" unit))) (backward (intern (format nil "BACKWARD-ONE-~S" unit)))) `(progn - (test ,forward + (test ,(intern (format nil "~A-~A" syntax forward)) (with-buffer (buffer :initial-contents ,initial-contents - :syntax ,syntax) + :syntax ',syntax) (let ((syntax (syntax buffer)) (m0l (clone-mark (low-mark buffer) :left)) (m0r (clone-mark (low-mark buffer) :right)) @@ -119,21 +118,25 @@ (offset m1r) ,offset (offset m2l) (size buffer) (offset m2r) (size buffer)) - (is-true (,forward m0l syntax)) - (is (= (offset m0l) ,forward-begin-offset)) - (is-true (,forward m0r syntax)) - (is (= (offset m0r) ,forward-begin-offset)) + ,(when forward-begin-offset + `(progn + (is-true (,forward m0l syntax)) + (is (= ,forward-begin-offset (offset m0l))))) + ,(when backward-end-offset + `(progn + (is-true (,forward m0r syntax)) + (is (= ,forward-begin-offset (offset m0r))))) (is-true (,forward m1l syntax)) - (is (= (offset m1l) ,goal-forward-offset)) + (is (= ,goal-forward-offset (offset m1l))) (is-true (,forward m1r syntax)) - (is (= (offset m1r) ,goal-forward-offset)) + (is (= ,goal-forward-offset (offset m1r))) (is-false (,forward m2l syntax)) - (is (= (offset m2l) (size buffer))) + (is (= (size buffer) (offset m2l))) (is-false (,forward m2r syntax)) - (is (= (offset m2r) (size buffer)))))) - (test ,backward + (is (= (size buffer) (offset m2r)))))) + (test ,(intern (format nil "~A-~A" syntax backward)) (with-buffer (buffer :initial-contents ,initial-contents - :syntax ,syntax) + :syntax ',syntax) (let ((syntax (syntax buffer)) (m0l (clone-mark (low-mark buffer) :left)) (m0r (clone-mark (low-mark buffer) :right)) @@ -148,17 +151,21 @@ (offset m2l) (size buffer) (offset m2r) (size buffer)) (is-false (,backward m0l syntax)) - (is (= (offset m0l) 0)) + (is (= 0 (offset m0l))) (is-false (,backward m0r syntax)) - (is (= (offset m0r) 0)) + (is (= 0 (offset m0r))) (is-true (,backward m1l syntax)) - (is (= (offset m1l) ,goal-backward-offset)) + (is (= ,goal-backward-offset (offset m1l))) (is-true (,backward m1r syntax)) - (is (= (offset m1r) ,goal-backward-offset)) - (is-true (,backward m2l syntax)) - (is (= (offset m2l) ,backward-end-offset)) - (is-true (,backward m2r syntax)) - (is (= (offset m2r) ,backward-end-offset)))))))) + (is (= ,goal-backward-offset (offset m1r))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2l syntax)) + (is (= ,backward-end-offset (offset m2l))))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2r syntax)) + (is (= ,backward-end-offset (offset m2r))))))))))) (motion-fun-one-test word (9 10 (5 9 2) " climacs --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/01/31 14:31:59 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/02/17 17:54:06 1.4 @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -;;; (c) copyright 2006 by +;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -21,7 +21,11 @@ (cl:in-package :drei-tests) (def-suite lisp-syntax-tests :description "The test suite for -tests related to the Lisp syntax module.") +tests related to the Lisp syntax module. The parser is not +explicitly tested. Instead, it is hoped that any defects will be +caught by other test cases, all of which depend on correct +parsing. Also, redisplay is not tested, because no-one has any +idea how to do it.") (in-suite lisp-syntax-tests) @@ -32,16 +36,22 @@ parser result and re-run the test suite (except for this self-compilation test, of course).") -(defmacro testing-lisp-syntax ((buffer-contents) &body body) - `(with-buffer (buffer :initial-contents ,buffer-contents - :syntax 'lisp-syntax) - (flet ((get-object (&rest args) - (apply #'form-to-object (syntax buffer) - (first (drei-lisp-syntax::children - (slot-value (syntax buffer) - 'drei-lisp-syntax::stack-top))) - args))) - ,@body))) +(defmacro testing-lisp-syntax ((buffer-contents &rest options) &body body) + (assert (evenp (length options))) + (with-gensyms (buffer drei) + `(with-buffer (,buffer :initial-contents ,buffer-contents :syntax 'lisp-syntax) + ,@(loop for (option value) on options by #'cddr + collecting `(eval-option (syntax ,buffer) ,option ,value)) + (let ((,drei (make-instance 'test-drei :buffer ,buffer))) + (with-bound-drei-special-variables (,drei :minibuffer nil) + (labels ((get-form () + (first (drei-lisp-syntax::children + (slot-value *current-syntax* + 'drei-lisp-syntax::stack-top)))) + (get-object (&rest args) + (apply #'form-to-object *current-syntax* + (get-form) args))) + ,@body)))))) (defmacro testing-symbol ((sym-sym &rest args) &body body) `(let ((,sym-sym (get-object ,@args))) @@ -55,171 +65,285 @@ (defmacro testing-lisp-syntax-symbol ((buffer-contents sym-sym &rest args) &body body) - `(with-buffer (buffer :initial-contents ,buffer-contents - :syntax 'lisp-syntax) + `(testing-lisp-syntax (,buffer-contents) (flet ((get-object (&rest args) - (apply #'form-to-object (syntax buffer) + (apply #'form-to-object *current-syntax* (first (drei-lisp-syntax::children - (slot-value (syntax buffer) + (slot-value *current-syntax* 'drei-lisp-syntax::stack-top))) args))) (testing-symbol (,sym-sym ,@args) ,@body)))) +(test lisp-syntax-test-base + "Test the Base syntax attribute for Lisp syntax." + (testing-lisp-syntax ("") + (is (= *read-base* (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "2") + (is (= 2 (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "36") + (is (= 36 (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "1") ; Should be ignored. + (is (= *read-base* (drei-lisp-syntax::base *current-syntax*)))) + (testing-lisp-syntax ("" :base "37") ; Should be ignored. + (is (= *read-base* (drei-lisp-syntax::base *current-syntax*))))) + +(test lisp-syntax-test-package + "Test the Package syntax attribute for Lisp syntax." + (testing-lisp-syntax ("") + (is (eq nil (drei-lisp-syntax::option-specified-package *current-syntax*)))) + (testing-lisp-syntax ("" :package "COMMON-LISP") + (is (eq (find-package :cl) + (drei-lisp-syntax::option-specified-package *current-syntax*)))) + (testing-lisp-syntax ("" :package "CL") + (is (eq (find-package :cl) + (drei-lisp-syntax::option-specified-package *current-syntax*)))) + (testing-lisp-syntax ("" :package "common-lisp") + (is (string= "common-lisp" + (drei-lisp-syntax::option-specified-package *current-syntax*))))) + +(test lisp-syntax-test-attributes + "Test that the syntax attributes of Lisp syntax are returned +properly." + (testing-lisp-syntax ("") + (is-true (assoc :package (current-attributes-for-syntax *current-syntax*))) + (is-true (assoc :base (current-attributes-for-syntax *current-syntax*))))) + +(test lisp-syntax-package-at-mark + "Test that Lisp syntax' handling of (in-package) forms is +correct." + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (eq *package* + (drei-lisp-syntax::package-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) " :package "DREI-LISP-SYNTAX") + (is (eq (find-package :drei-lisp-syntax) + (drei-lisp-syntax::package-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"CL-USER\") ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"cl-user\") ") + (is (eq *package* + (drei-lisp-syntax::package-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :clim) ") + (is (eq (find-package :clim) + (drei-lisp-syntax::package-at-mark *current-syntax* 43)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :iDoNotExist) ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 43))))) + +(test lisp-syntax-provided-package-name-at-mark + "Test that Lisp syntax' handling of (in-package) forms is +correct, even counting packages that cannot be found." + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (string= "CLIM-USER" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) " :package "DREI-LISP-SYNTAX") + (is (string= "DREI-LISP-SYNTAX" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 10)))) + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (string= "CL-USER" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"CL-USER\") ") + (is (string= "CL-USER" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package \"cl-user\") ") + (is (string= "cl-user" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 23)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :clim) ") + (is (string= "CLIM" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 43)))) + (testing-lisp-syntax ("(in-package :cl-user)(in-package :iDoNotExist) ") + (is (string= "IDONOTEXIST" + (drei-lisp-syntax::provided-package-name-at-mark *current-syntax* 48))))) + +(test lisp-syntax-need-to-update-package-list-p + "Test that Lisp syntax can properly handle it when (in-package) + forms change." + (testing-lisp-syntax ("(in-package :cl-user) ") + (is (eq (find-package :cl-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 23))) + (delete-buffer-range *current-buffer* 0 (size *current-buffer*)) + (insert-buffer-sequence *current-buffer* 0 "(in-package :cl-userr) ") + (update-syntax *current-buffer* *current-syntax*) + (is (eq *package* + (drei-lisp-syntax::package-at-mark *current-syntax* 24))) + (insert-buffer-sequence *current-buffer* 24 "(in-package :drei-lisp-syntax) ") + (update-syntax *current-buffer* *current-syntax*) + (is (eq (find-package :drei-lisp-syntax) + (drei-lisp-syntax::package-at-mark *current-syntax* 54))) + (delete-buffer-range *current-buffer* 0 23) + (insert-buffer-sequence *current-buffer* 0 "(in-package :clim-user)") + (update-syntax *current-buffer* *current-syntax*) + (is (eq (find-package :clim-user) + (drei-lisp-syntax::package-at-mark *current-syntax* 26))))) + (test form-to-object-1 + "Test that we can parse and recognize T in Lisp syntax." (testing-lisp-syntax ("T") - (is (eq (get-object) t))) + (is (eq t (get-object)))) (testing-lisp-syntax ("t") - (is (eq (get-object) t)))) + (is (eq t (get-object))))) (test form-to-object-2 + "Test that casing is properly done for NIL." (testing-lisp-syntax ("nil") - (is (eq (get-object) nil))) + (is (eq nil (get-object)))) (testing-lisp-syntax ("NIL") - (is (eq (get-object) nil))) + (is (eq nil (get-object)))) (testing-lisp-syntax ("NIl") - (is (eq (get-object) nil))) + (is (eq nil (get-object)))) (testing-lisp-syntax ("NIl") - (is-false (eq (get-object :case :preserve) nil)))) + (is-false (eq nil (get-object :case :preserve))))) (test form-to-object-3 + "Test case-conversion for tokens." (testing-lisp-syntax ("iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist"))) + (is (string= "iDoNotExist" + (symbol-name sym)))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-symbol (sym :read t :case :upcase) (is-true (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))) (testing-symbol (sym :read t :case :preserve) (is-true (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist"))) + (is (string= "iDoNotExist" + (symbol-name sym)))) (testing-symbol (sym :read t :case :downcase) (is-true (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist")))) + (is (string= "iDoNotExist" + (symbol-name sym))))) (testing-lisp-syntax-symbol ("IDONOTEXIST" sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-lisp-syntax-symbol ("idonotexist" sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST")))) + (is (string= "IDONOTEXIST" + (symbol-name sym))))) (test form-to-object-4 + "Test case-conversion for uninterned tokens." (testing-lisp-syntax ("#:iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist"))) + (is (string= "iDoNotExist" + (symbol-name sym)))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist"))) + (is (string= "idonotexist" + (symbol-name sym)))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "iDoNotExist")))) + (is (string= "iDoNotExist" + (symbol-name sym))))) (testing-lisp-syntax ("#:IDONOTEXIST") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "idonotexist")))) + (is (string= "idonotexist" + (symbol-name sym))))) (testing-lisp-syntax ("#:idonotexist") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) - (is (string= (symbol-name sym) - "IDONOTEXIST"))))) + (is (string= "IDONOTEXIST" + (symbol-name sym)))))) (test form-to-object-5 + "Test handling of escaped symbols." (testing-lisp-syntax-symbol ("|123|" sym :read t) - (is (string= (symbol-name sym) "123"))) + (is (string= "123" (symbol-name sym)))) (testing-lisp-syntax-symbol ("|LIST|" sym :read t :case :downcase) - (is (string= (symbol-name sym) "LIST"))) + (is (string= "LIST" (symbol-name sym)))) (testing-lisp-syntax-symbol ("| |" sym :read t) - (is (string= (symbol-name sym) " "))) + (is (string= " " (symbol-name sym)))) (testing-lisp-syntax-symbol ("|foo|bar|abbabz|" sym :read t) - (is (string= (symbol-name sym) - "fooBARabbabz"))) + (is (string= "fooBARabbabz" (symbol-name sym)))) (testing-lisp-syntax-symbol ("||" sym :read t) - (is (string= (symbol-name sym) ""))) + (is (string= "" (symbol-name sym)))) (testing-lisp-syntax-symbol ("||||" sym :read t) - (is (string= (symbol-name sym) "")))) + (is (string= "" (symbol-name sym))))) (test form-to-object-6 + "Test keyword symbols." (testing-lisp-syntax-symbol (":foo" sym :read t) - (is (string= (symbol-name sym) "FOO")) - (is (eq (symbol-package sym) - (find-package :keyword))))) + (is (string= "FOO" (symbol-name sym))) + (is (eq (find-package :keyword) + (symbol-package sym))))) (test form-to-object-7 + "Test that numbers are recognized and handled properly by the +Lisp syntax." (testing-lisp-syntax ("123") - (is (= (get-object) 123))) + (is (= 123 (get-object)))) (testing-lisp-syntax ("-123") - (is (= (get-object) -123))) + (is (= -123 (get-object)))) (testing-lisp-syntax (".123") - (is (= (get-object) .123))) + (is (= .123 (get-object)))) (testing-lisp-syntax ("-.123") - (is (= (get-object) -.123))) + (is (= -.123 (get-object)))) (testing-lisp-syntax ("1.234") - (is (= (get-object) 1.234))) + (is (= 1.234 (get-object)))) (testing-lisp-syntax ("-1.234") - (is (= (get-object) -1.234))) + (is (= -1.234 (get-object)))) (testing-lisp-syntax ("1e7") - (is (= (get-object) 1e7))) + (is (= 1e7 (get-object)))) (testing-lisp-syntax ("1E7") - (is (= (get-object) 1e7))) + (is (= 1e7 (get-object)))) (testing-lisp-syntax ("1.123E7") - (is (= (get-object) 1.123e7))) + (is (= 1.123e7 (get-object)))) (testing-lisp-syntax ("-1.123E7") - (is (= (get-object) -1.123e7))) + (is (= -1.123e7 (get-object)))) (testing-lisp-syntax (".123E7") - (is (= (get-object) .123e7))) + (is (= .123e7 (get-object)))) (testing-lisp-syntax ("-.123E7") - (is (= (get-object) -.123e7))) + (is (= -.123e7 (get-object)))) (testing-lisp-syntax ("1.34e-7") - (is (= (get-object) 1.34e-7)))) + (is (= 1.34e-7 (get-object))))) (test form-to-object-8 + "Test that the standard reader macros for numbers are +recognized and handled." (testing-lisp-syntax ("#b0000") - (is (= (get-object) 0))) + (is (= 0 (get-object)))) (testing-lisp-syntax ("#b10") - (is (= (get-object) 2))) + (is (= 2 (get-object)))) (testing-lisp-syntax ("#b-10") - (is (= (get-object) -2))) + (is (= -2 (get-object)))) (testing-lisp-syntax ("#x00") - (is (= (get-object) 0))) + (is (= 0 (get-object)))) (testing-lisp-syntax ("#xFE") - (is (= (get-object) 254))) + (is (= 254 (get-object)))) (testing-lisp-syntax ("#x-FE") - (is (= (get-object) -254))) + (is (= -254 (get-object)))) (testing-lisp-syntax ("#o00") [804 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 13 Feb '07

13 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv26101/Tests Modified Files: core-tests.lisp base-tests.lisp Log Message: Fixed `delete-indentation', added `join-line' and exported some more symbols from DREI-LISP-SYNTAX. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/12 19:32:57 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/13 12:14:11 1.3 @@ -383,7 +383,54 @@ (delete-indentation *current-syntax* *current-point*) (buffer-is " Foo Bar - Baz"))) + Baz")) + (with-drei-environment (:initial-contents " +foo bar") + (let ((start (clone-mark (point *current-window*))) + (end (clone-mark (point *current-window*))) + (orig-contents (buffer-contents))) + (beginning-of-buffer start) + (end-of-buffer end) + (do-buffer-region-lines (line start end) + (delete-indentation *current-syntax* line)) + (buffer-is orig-contents)))) + +(test join-line + (with-drei-environment (:initial-contents " + climacs ") + (let ((m (clone-mark *current-point* :left))) + (setf (offset m) 3) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is "climacs "))) + (with-drei-environment (:initial-contents " + climacs ") + (let ((m (clone-mark *current-point* :right))) + (setf (offset m) 7) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is "climacs "))) + (with-drei-environment (:initial-contents " climacs ") + (let ((m (clone-mark *current-point* :left))) + (setf (offset m) 7) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is " climacs "))) + (with-drei-environment (:initial-contents "climacs + climacs ") + (let ((m (clone-mark *current-point* :right))) + (setf (offset m) 12) + (join-line *current-syntax* m) + (is (= (offset m) 8)) + (buffer-is "climacs climacs "))) + (with-drei-environment (:initial-contents " + + climacs ") + (let ((m (clone-mark *current-point* :right))) + (setf (offset m) 12) + (join-line *current-syntax* m) + (is (= (offset m) 0)) + (buffer-is "climacs ")))) (test set-syntax (dolist (syntax-designator `("Lisp" drei-lisp-syntax::lisp-syntax --- /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2007/02/13 12:14:11 1.2 @@ -607,53 +607,6 @@ (is (string= (buffer-contents buffer) #.(format nil "~A climacs " #\Tab)))))) -(buffer-test delete-indentation - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " - climacs ") - (let ((m (clone-mark (low-mark buffer) :left))) - (setf (offset m) 3) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - "climacs "))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " - climacs ") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 7) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - "climacs ")))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (clone-mark (low-mark buffer) :left))) - (setf (offset m) 7) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - " climacs ")))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "climacs - climacs ") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 12) - (delete-indentation m) - (is (= (offset m) 8)) - (is (string= (buffer-contents buffer) - "climacs climacs ")))) - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " - - climacs ") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 12) - (delete-indentation m) - (is (= (offset m) 0)) - (is (string= (buffer-contents buffer) - "climacs ")))))) - (buffer-test buffer-looking-at (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ")

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 13 Feb '07

13 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26101 Modified Files: packages.lisp core.lisp Log Message: Fixed `delete-indentation', added `join-line' and exported some more symbols from DREI-LISP-SYNTAX. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/01/15 11:35:54 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/02/13 12:14:12 1.13 @@ -410,6 +410,7 @@ #:indent-region #:fill-line #:fill-region #:indent-line #:delete-indentation + #:join-line #:set-syntax #:*killed-rectangle* @@ -445,7 +446,8 @@ #:edit-definition #:form #:form-to-object - #:form-conversion-error) + #:form-conversion-error + #:forward-one-list #:backward-one-list #:forward-list #:backward-list) (:shadow clim:form) (:documentation "Implementation of the syntax module used for editing Common Lisp code.")) --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/02/12 19:32:58 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/02/13 12:14:12 1.5 @@ -294,11 +294,33 @@ (let ((working-mark (clone-mark mark))) (beginning-of-line working-mark) (let ((end-offset (loop for offset from (offset working-mark) below (size *current-buffer*) - unless (whitespacep syntax (buffer-object *current-buffer* offset)) + for buffer-object = (buffer-object *current-buffer* offset) + until (char= buffer-object #\Newline) + unless (whitespacep syntax buffer-object) return offset))) (when end-offset (delete-region working-mark end-offset))))) +(defgeneric join-line (syntax mark) + (:documentation "Join the line that `mark' is in to the +previous line, and remove whitespace objects at the join +point. `Syntax' is used for judging what a whitespace character +is.")) + +(defmethod join-line ((syntax syntax) (mark mark)) + (beginning-of-line mark) + (unless (beginning-of-buffer-p mark) + (delete-range mark -1) + (loop until (end-of-buffer-p mark) + while (whitespacep syntax (object-after mark)) + do (delete-range mark 1)) + (loop until (beginning-of-buffer-p mark) + while (whitespacep syntax (object-before mark)) + do (delete-range mark -1)) + (when (and (not (beginning-of-buffer-p mark)) + (constituentp (object-before mark))) + (insert-object mark #\Space)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax handling

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 12 Feb '07

12 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27220 Modified Files: core.lisp core-commands.lisp Log Message: Improved `delete-indentation', now does the intuitive thing. --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/01/14 17:57:01 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/02/12 19:32:58 1.4 @@ -285,19 +285,19 @@ (defmethod indent-line ((mark right-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width nil)) -(defun delete-indentation (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (buffer-whitespacep (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (buffer-whitespacep (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) +(defgeneric delete-indentation (syntax mark) + (:documentation "Delete all indentation in the line of `mark' +with the whitespace rules of `syntax'. The default method just +removes leading whitespace characters.")) + +(defmethod delete-indentation ((syntax syntax) (mark mark)) + (let ((working-mark (clone-mark mark))) + (beginning-of-line working-mark) + (let ((end-offset (loop for offset from (offset working-mark) below (size *current-buffer*) + unless (whitespacep syntax (buffer-object *current-buffer* offset)) + return offset))) + (when end-offset + (delete-region working-mark end-offset))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/14 10:31:37 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/02/12 19:32:58 1.4 @@ -257,7 +257,7 @@ the current line, and point after that space. If there is no previous non-blank line, deletes all whitespace at the beginning of the buffer at leaves point there." - (delete-indentation *current-point*)) + (delete-indentation *current-syntax* *current-point*)) (set-key 'com-delete-indentation 'indent-table

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 12 Feb '07

12 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv27220/Tests Modified Files: core-tests.lisp Log Message: Improved `delete-indentation', now does the intuitive thing. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/12 19:32:57 1.2 @@ -363,6 +363,28 @@ (buffer-is #. (format nil "~A~A~A~A~A I am to be indented" #\Tab #\Tab #\Tab #\Tab #\Tab))))) +(test delete-indentation + (with-drei-environment (:initial-contents "") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "")) + (with-drei-environment (:initial-contents "Foo") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "Foo")) + (with-drei-environment (:initial-contents " Foo") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "Foo")) + (with-drei-environment (:initial-contents " Foo ") + (delete-indentation *current-syntax* *current-point*) + (buffer-is "Foo ")) + (with-drei-environment (:initial-contents " Foo + Bar + Baz") + (forward-line *current-point* *current-syntax*) + (delete-indentation *current-syntax* *current-point*) + (buffer-is " Foo +Bar + Baz"))) + (test set-syntax (dolist (syntax-designator `("Lisp" drei-lisp-syntax::lisp-syntax ,(find-class 'drei-lisp-syntax::lisp-syntax)))

1 0

[mcclim-cvs] CVS mcclim/Doc
by thenriksen 10 Feb '07

10 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv15654/Doc Modified Files: ex3.lisp Log Message: Made the `string' present method respect the :accept keyword argument, updated an example program to exploit this. --- /project/mcclim/cvsroot/mcclim/Doc/ex3.lisp 2004/07/22 12:05:24 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/ex3.lisp 2007/02/10 21:32:21 1.2 @@ -21,9 +21,11 @@ (define-superapp-command (com-quit :name t) () (frame-exit *application-frame*)) -(define-presentation-type name-of-month ()) +(define-presentation-type name-of-month () + :inherit-from 'string) -(define-presentation-type day-of-month ()) +(define-presentation-type day-of-month () + :inherit-from 'integer) (define-superapp-command (com-out :name t) () (with-output-as-presentation (t "The third month" 'name-of-month)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs February 2007