May 2006 - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28282 Modified Files: lisp-syntax.lisp Log Message: Removed call to Clouseau (oops again). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:38:31 1.72 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 21:36:29 1.73 @@ -2058,7 +2058,7 @@ &key no-error (case (readtable-case *readtable*))) (declare (ignore no-error)) - (clouseau:inspector (parse-symbol (token-string syntax token) :case case))) + (parse-symbol (token-string syntax token) :case case)) (defmethod token-to-object (syntax (token number-lexeme) &rest args) (declare (ignore args))

1 0

[climacs-cvs] CVS climacs
by dmurray 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24606 Modified Files: search-commands.lisp Log Message: Preliminary addition of some extra options for isearch: C-j (appends a #\Newline to the search string) C-w (appends the word after point) C-y (appends the remainder of the line after point) M-y (appends the most recent kill) Still work to be done, but useful even now. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/14 20:35:44 1.3 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/16 21:08:08 1.4 @@ -28,6 +28,13 @@ (in-package :climacs-gui) +(defun display-string (string) + (with-output-to-string (result) + (loop for char across string + do (cond ((graphic-char-p char) (princ char result)) + ((char= char #\Space) (princ char result)) + (t (prin1 char result)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; String search @@ -107,7 +114,7 @@ (- (offset mark2) (length string)) (+ (offset mark2) (length string))))) (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" - success forwardp string) + success forwardp (display-string string)) (push (make-instance 'isearch-state :search-string string :search-mark mark @@ -133,18 +140,60 @@ 'search-table '((#\r :control))) -(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) () +(defun isearch-append-char (char) (let* ((pane (current-window)) (states (isearch-states pane)) (string (concatenate 'string (search-string (first states)) - (string *current-gesture*))) + (string char))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) (unless forwardp (incf (offset mark))) (isearch-from-mark pane mark string forwardp))) +(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) () + (isearch-append-char *current-gesture*)) + +(define-command (com-isearch-append-newline :name t :command-table isearch-climacs-table) () + (isearch-append-char #\Newline)) + +(defun isearch-append-text (movement-function) + (let* ((pane (current-window)) + (states (isearch-states pane)) + (buffer (buffer pane)) + (point (point pane)) + (start (clone-mark point)) + (mark (clone-mark (search-mark (first states)))) + (forwardp (search-forward-p (first states)))) + (funcall movement-function point) + (let ((string (concatenate 'string + (search-string (first states)) + (buffer-substring buffer + (offset start) + (offset point))))) + (unless forwardp + (incf (offset mark))) + (isearch-from-mark pane mark string forwardp)))) + +(define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) () + (isearch-append-text #'forward-word)) + +(define-command (com-isearch-append-line :name t :command-table isearch-climacs-table) () + (isearch-append-text #'end-of-line)) + +(define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) () + (let* ((pane (current-window)) + (states (isearch-states pane)) + (string (concatenate 'string + (search-string (first states)) + (kill-ring-yank *kill-ring*))) + (mark (clone-mark (search-mark (first states)))) + (forwardp (search-forward-p (first states)))) + (unless forwardp + (incf (offset mark))) + (isearch-from-mark pane mark string forwardp))) + (define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) () (let* ((pane (current-window))) (cond ((null (second (isearch-states pane))) @@ -164,7 +213,7 @@ (length (search-string state))))) (display-message "Isearch~:[ backward~;~]: ~A" (search-forward-p state) - (search-string state))))))) + (display-string (search-string state)))))))) (define-command (com-isearch-search-forward :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) @@ -200,6 +249,10 @@ (isearch-set-key '(#\Backspace) 'com-isearch-delete-char) (isearch-set-key '(#\s :control) 'com-isearch-search-forward) (isearch-set-key '(#\r :control) 'com-isearch-search-backward) +(isearch-set-key '(#\j :control) 'com-isearch-append-newline) +(isearch-set-key '(#\w :control) 'com-isearch-append-word) +(isearch-set-key '(#\y :control) 'com-isearch-append-line) +(isearch-set-key '(#\y :meta) 'com-isearch-append-kill) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22841 Modified Files: misc-commands.lisp Log Message: Changed all commands in file to use proper command arguments instead of calling `accept' explicitly. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/14 07:14:17 1.12 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/16 20:59:16 1.13 @@ -817,7 +817,7 @@ (loop until (end-of-line-p mark) while (whitespacep (object-after mark)) repeat count do (forward-object mark) - finally (setf offset (offset mark))) + finally (setf offset (offset mark))) (loop until (end-of-line-p mark) while (whitespacep (object-after mark)) do (forward-object mark)) @@ -838,14 +838,12 @@ (defun goto-position (mark pos) (setf (offset mark) pos)) -(define-command (com-goto-position :name t :command-table movement-table) () +(define-command (com-goto-position :name t :command-table movement-table) + ((position 'integer :prompt "Goto Position")) "Prompts for an integer, and sets the offset of point to that integer." (goto-position (point (current-window)) - (handler-case (accept 'integer :prompt "Goto Position") - (error () (progn (beep) - (display-message "Not a valid position") - (return-from com-goto-position nil)))))) + position)) (defun goto-line (mark line-number) (loop with m = (clone-mark (low-mark (buffer mark)) @@ -859,24 +857,22 @@ finally (beginning-of-line m) (setf (offset mark) (offset m)))) -(define-command (com-goto-line :name t :command-table movement-table) () +(define-command (com-goto-line :name t :command-table movement-table) + ((line-number 'integer :prompt "Goto Line")) "Prompts for a line number, and sets point to the beginning of that line. The first line of the buffer is 1. Giving a number <1 leaves point at the beginning of the buffer. Giving a line number larger than the number of the last line in the buffer leaves point at the beginning of the last line of the buffer." - (goto-line (point (current-window)) - (handler-case (accept 'integer :prompt "Goto Line") - (error () (progn (beep) - (display-message "Not a valid line number") - (return-from com-goto-line nil)))))) - -(define-command (com-browse-url :name t :command-table base-table) () - (let ((url (accept 'url :prompt "Browse URL"))) - #+ (and sbcl darwin) - (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil) - #+ (and openmcl darwin) - (ccl:run-program "/usr/bin/open" `(,url) :wait nil))) + (goto-line (point (current-window)) line-number)) + +(define-command (com-browse-url :name t :command-table base-table) + ((url 'url :prompt "Browse URL")) + (declare (ignorable url)) + #+ (and sbcl darwin) + (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil) + #+ (and openmcl darwin) + (ccl:run-program "/usr/bin/open" `(,url) :wait nil)) (define-command (com-set-mark :name t :command-table marking-table) () "Set mark to the current position of point." @@ -915,15 +911,12 @@ (beep) (display-message "No such syntax: ~A." syntax))))) -(define-command (com-set-syntax :name t :command-table buffer-table) () +(define-command (com-set-syntax :name t :command-table buffer-table) + ((syntax 'syntax + :prompt "Name of syntax")) "Prompts for a syntax to set for the current buffer. -Setting a syntax will cause the buffer to be reparsed using the new syntax." - (let* ((pane (current-window)) - (buffer (buffer pane))) - (handler-case (set-syntax buffer (accept 'syntax :prompt "Set Syntax")) - (input-not-of-required-type - (message) - (display-message "Invalid syntax: ~A." message))))) + Setting a syntax will cause the buffer to be reparsed using the new syntax." + (set-syntax (current-buffer) syntax)) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -979,14 +972,11 @@ 'editing-table '((#\y :meta))) -(define-command (com-resize-kill-ring :name t :command-table editing-table) () +(define-command (com-resize-kill-ring :name t :command-table editing-table) + ((size 'integer :prompt "New kill ring size")) "Prompt for a new size for the kill ring. The default is 5. A number less than 5 will be replaced by 5." - (let ((size (handler-case (accept 'integer :prompt "New kill ring size") - (error () (progn (beep) - (display-message "Not a valid kill ring size") - (return-from com-resize-kill-ring nil)))))) - (setf (kill-ring-max-size *kill-ring*) size))) + (setf (kill-ring-max-size *kill-ring*) size)) (define-command (com-append-next-kill :name t :command-table editing-table) () "Set the kill ring to append the next kill to the previous one." @@ -1336,17 +1326,14 @@ '((#\x :control) (#\=))) (define-command (com-eval-expression :name t :command-table base-table) - ((insertp 'boolean :prompt "Insert?")) + ((exp 'expression :prompt "Eval") + (insertp 'boolean :prompt "Insert?")) "Prompt for and evaluate a lisp expression. With a numeric argument inserts the result at point as a string; otherwise prints the result." (let* ((*package* (find-package :climacs-gui)) - (string (handler-case (accept 'string :prompt "Eval") - (error () (progn (beep) - (display-message "Empty string") - (return-from com-eval-expression nil))))) - (values (multiple-value-list - (handler-case (eval (read-from-string string)) + (values (multiple-value-list + (handler-case (eval exp) (error (condition) (progn (beep) (display-message "~a" condition) (return-from com-eval-expression nil)))))) @@ -1355,7 +1342,7 @@ (insert-sequence (point (current-window)) result) (display-message result)))) -(set-key `(com-eval-expression ,*numeric-argument-p*) +(set-key `(com-eval-expression ,*unsupplied-argument-marker* ,*numeric-argument-p*) 'base-table '((#\: :shift :meta)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20950 Modified Files: lisp-syntax.lisp Log Message: Use colors that are more visible on a white background and resembles out-of-the-box GNU Emacs. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:13:17 1.71 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:38:31 1.72 @@ -1372,10 +1372,10 @@ (defparameter *standard-faces* `((:error ,+red+ nil) - (:string ,+coral+ ,(make-text-style nil :italic nil)) - (:keyword ,+dark-violet+ nil) - (:macro ,+cyan+) - (:special-form ,+cyan+) + (:string ,+rosy-brown+ ,(make-text-style nil :italic nil)) + (:keyword ,+orchid+ nil) + (:macro ,+purple+ nil) + (:special-form ,+purple+ nil) (:lambda-list-keyword ,+dark-green+ nil) (:comment ,+maroon+ nil) (:reader-conditional ,+gray50+ nil)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17472 Modified Files: lisp-syntax.lisp Log Message: Made the quote-characters use the same face as the rest of the string when displaying string lexemes. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:00:50 1.70 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:13:17 1.71 @@ -1521,13 +1521,14 @@ (end-offset (car (last children 2)))))) (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) - (display-parse-tree (pop children) syntax pane) (with-face (:string) + (display-parse-tree (pop children) syntax pane) (loop until (null (cdr children)) - do (display-parse-tree (pop children) syntax pane))) - (display-parse-tree (pop children) syntax pane))) - (progn (display-parse-tree (pop children) syntax pane) - (display-parse-tree (pop children) syntax pane))))) + do (display-parse-tree (pop children) syntax pane)) + (display-parse-tree (pop children) syntax pane)))) + (with-face (:string) + (progn (display-parse-tree (pop children) syntax pane) + (display-parse-tree (pop children) syntax pane)))))) (defmethod display-parse-tree ((parse-symbol incomplete-string-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) @@ -1537,11 +1538,12 @@ (end-offset (car (last children)))))) (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) - (display-parse-tree (pop children) syntax pane) (with-face (:string) + (display-parse-tree (pop children) syntax pane) (loop until (null children) do (display-parse-tree (pop children) syntax pane))))) - (display-parse-tree (pop children) syntax pane)))) + (with-face (:string) + (display-parse-tree (pop children) syntax pane))))) (defmethod display-parse-tree ((parse-symbol line-comment-form) (syntax lisp-syntax) pane) (with-face (:comment)

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16994 Modified Files: lisp-syntax.lisp Log Message: Added ":no-error t" arguments to calls to `token-to-object'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:48:52 1.69 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:00:50 1.70 @@ -1172,7 +1172,8 @@ (when (typep x 'complete-list-form) (let ((candidate (first-form (children x)))) (and (typep candidate 'token-mixin) - (eq (token-to-object syntax candidate) + (eq (token-to-object syntax candidate + :no-error t) 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) @@ -1466,7 +1467,7 @@ (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) (let ((string (token-string syntax parse-symbol))) (multiple-value-bind (symbol status) - (token-to-object syntax parse-symbol) + (token-to-object syntax parse-symbol :no-error t) (with-output-as-presentation (pane (if status symbol string) (if status 'symbol 'unknown-symbol) :single-box :highlighting)

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv15202 Modified Files: lisp-syntax.lisp Log Message: Expanded, improved and fixed the `token-to-object' generic function and its methods. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:38:49 1.68 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:48:52 1.69 @@ -2007,15 +2007,15 @@ :case case :no-error t)) -(defgeneric token-to-object (syntax token &key no-error &allow-other-keys) +(defgeneric token-to-object (syntax token &rest args &key no-error package quote &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax token &key no-error package) + (:method :around (syntax token &rest args &key no-error package quote) ;; Ensure that every symbol that is READ will be looked up - ;; in the correct package. + ;; in the correct package. Also handle quoting. (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) (slot-value syntax 'package) (typep (slot-value syntax 'package) 'package)) @@ -2025,8 +2025,13 @@ package (find-package package))) (find-package :common-lisp))))) - (call-next-method)) + (if quote + (progn + (setf (getf args :quote) nil) + `',(call-next-method)) + (call-next-method))) (t () + ;; Needs more usable error. (unless no-error (error "Cannot convert token to Lisp object: ~A" token))))) (:method (syntax (token t) &key no-error) @@ -2034,7 +2039,7 @@ ;; We ignore `no-error' as it is truly a bug in Climacs if no ;; handler method is specialized on this form. (error "Cannot convert token to Lisp object: ~A" - token)) + token)) (:method (syntax (token incomplete-form-mixin) &key no-error) (unless no-error (error "Cannot convert incomplete form to Lisp object: ~A" @@ -2046,30 +2051,31 @@ (declare (ignore no-error)) (parse-symbol (token-string syntax token) :case case)) -(defmethod token-to-object (syntax (token number-lexeme) &key no-error) +(defmethod token-to-object (syntax (token complete-token-form) + &key no-error + (case (readtable-case *readtable*))) (declare (ignore no-error)) + (clouseau:inspector (parse-symbol (token-string syntax token) :case case))) + +(defmethod token-to-object (syntax (token number-lexeme) &rest args) + (declare (ignore args)) (let ((*read-base* (base syntax))) (read-from-string (token-string syntax token)))) -(defmethod token-to-object (syntax (token list-form) &key no-error) - (declare (ignore no-error)) - (mapcar #'(lambda (form) - (token-to-object syntax form)) - (remove-if-not #'(lambda (form) - (typep form 'form)) - (children token)))) +(defmethod token-to-object (syntax (token list-form) &rest args) + (loop for child in (children token) + if (typep child 'comma-at-form) + ;; How should we handle this? + collect (apply #'token-to-object syntax child args) + else if (typep child 'form) + collect (apply #'token-to-object syntax child args))) -(defmethod token-to-object (syntax (token simple-vector-form) &key no-error) - (declare (ignore no-error)) +(defmethod token-to-object (syntax (token simple-vector-form) &key) (apply #'vector - (mapcar #'(lambda (form) - (token-to-object syntax form)) - (remove-if-not #'(lambda (form) - (typep form 'form)) - (children token))))) + (call-next-method))) -(defmethod token-to-object (syntax (token incomplete-string-form) &key no-error) - (declare (ignore no-error)) +(defmethod token-to-object (syntax (token incomplete-string-form) &rest args) + (declare (ignore args)) (read-from-string (concatenate 'string (token-string syntax token) "\""))) @@ -2078,9 +2084,61 @@ (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token quote-form) &key no-error) - (list 'cl:quote - (token-to-object syntax (second (children token)) :no-error no-error))) +(defmethod token-to-object (syntax (token quote-form) &rest args) + (apply #'token-to-object syntax (second (children token)) :quote t args)) + +;; I'm not sure backquotes are handled correctly, but then again, +;; `token-to-object' is not meant to be a perfect Lisp reader, only a +;; convenience function. +(defmethod token-to-object (syntax (token backquote-form) &rest args) + (let ((backquoted-form (first-form (children token)))) + (if (typep backquoted-form 'list-form) + `'(,@(apply #'token-to-object syntax backquoted-form args)) + `',(apply #'token-to-object syntax backquoted-form args)))) + +(defmethod token-to-object (syntax (token comma-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) args)) + +(defmethod token-to-object (syntax (token comma-at-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) args)) + +(defmethod token-to-object (syntax (token function-form) &rest args) + (list 'cl:function (apply #'token-to-object syntax (second (children token)) + args))) + +(defmethod token-to-object (syntax (token character-lexeme) &key) + (read-from-string (token-string syntax token))) + +(defmethod token-to-object (syntax (token cons-cell-form) &key) + (let ((components (remove-if #'(lambda (token) + (not (typep token 'form))) + (children token)))) + (if (<= (length components) 2) + (cons (token-to-object syntax (first components)) + (token-to-object syntax (second components))) + (loop for (head . tail) on components + if (rest tail) + collect (token-to-object syntax head) + else if (not (null tail)) + append (cons (token-to-object syntax head) + (token-to-object syntax (first tail))))))) + +;; Perhaps just returning NIL for conditionals whose condition +;; evaluates to NIL isn't such a good idea? I don't think it's very +;; Intuitive. +(defmethod token-to-object (syntax (token reader-conditional-positive-form) &key) + (let ((conditional (second-noncomment (children token)))) + (when (eval-feature-conditional conditional syntax) + (token-to-object syntax (third-noncomment (children token)))))) + +(defmethod token-to-object (syntax (token reader-conditional-negative-form) &key) + (let ((conditional (second-noncomment (children token)))) + (when (not (eval-feature-conditional conditional syntax)) + (token-to-object syntax (third-noncomment (children token)))))) + +(defmethod token-to-object (syntax (token undefined-reader-macro-form) &key) + ;; ??? + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13589 Modified Files: lisp-syntax.lisp Log Message: Oops. Added defclass for dot-lexeme. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:33:41 1.67 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:38:49 1.68 @@ -208,6 +208,7 @@ (defclass comma-lexeme (lisp-lexeme) ()) (defclass comma-at-lexeme (lisp-lexeme) ()) (defclass comma-dot-lexeme (lisp-lexeme) ()) +(defclass dot-lexeme (lisp-lexeme) ()) (defclass form-lexeme (form lisp-lexeme) ()) (defclass incomplete-character-lexeme (form-lexeme incomplete-form-mixin) ()) (defclass character-lexeme (form-lexeme) ())

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13303 Modified Files: lisp-syntax.lisp Log Message: Added syntactical recognition of literal cons cells. May need more work on error-detection. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/06 19:51:04 1.66 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:33:41 1.67 @@ -450,11 +450,13 @@ ;; May need more work. Can recognize symbols and numbers. (flet ((fo () (forward-object scan))) (let ((could-be-number t) - sign-seen dot-seen slash-seen) + sign-seen dot-seen slash-seen nondot-seen) (flet ((return-token-or-number-lexeme () (return-from lex-token (if could-be-number - (make-instance 'number-lexeme) + (if nondot-seen + (make-instance 'number-lexeme) + (make-instance 'dot-lexeme)) (make-instance 'complete-token-lexeme)))) (this-object () (object-after scan))) @@ -463,6 +465,8 @@ (when (end-of-buffer-p scan) (return-token-or-number-lexeme)) (when (constituentp (object-after scan)) + (when (not (eql (this-object) #\.)) + (setf nondot-seen t)) (cond ((or (eql (this-object) #\+) (eql (this-object) #\-)) (when sign-seen @@ -681,6 +685,42 @@ (define-lisp-action (|( form* | (eql nil)) (reduce-until-type incomplete-list-form left-parenthesis-lexeme)) +;;;;;;;;;;;;;;;; Cons cell +;; Also (foo bar baz . quux) constructs. +;; (foo bar . baz quux) flagged as an error (too aggressively?). + +;;; parse trees +(defclass cons-cell-form (form) ()) +(defclass complete-cons-cell-form (cons-cell-form complete-list-form) ()) +(defclass incomplete-cons-cell-form (cons-cell-form incomplete-list-form) ()) + +(define-parser-state |( form* dot-lexeme | + (lexer-list-state form-may-follow) ()) +(define-parser-state |( form* dot-lexeme form | + (lexer-list-state form-may-follow) ()) +(define-parser-state |( form* dot-lexeme form ) | + (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (|( form* | dot-lexeme) + |( form* dot-lexeme |) +(define-new-lisp-state (|( form* dot-lexeme | form) + |( form* dot-lexeme form |) +(define-new-lisp-state (|( form* dot-lexeme | comment) + |( form* dot-lexeme |) +(define-new-lisp-state (|( form* dot-lexeme form | right-parenthesis-lexeme) + |( form* dot-lexeme form ) |) +(define-new-lisp-state (|( form* dot-lexeme form | comment) + |( form* dot-lexeme form |) + +(define-lisp-action (|( form* dot-lexeme form ) | t) + (reduce-until-type complete-cons-cell-form left-parenthesis-lexeme)) + +;;; Reduce at end of buffer. +(define-lisp-action (|( form* dot-lexeme | (eql nil)) + (reduce-until-type incomplete-cons-cell-form left-parenthesis-lexeme)) +(define-lisp-action (|( form* dot-lexeme form | (eql nil)) + (reduce-until-type incomplete-cons-cell-form left-parenthesis-lexeme)) + ;;;;;;;;;;;;;;;; Simple Vector ;;; parse trees

1 0

[climacs-cvs] CVS esa
by thenriksen 16 May '06

16 May '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv518 Modified Files: esa-command-parser.lisp Log Message: Fixed handling of *unsupplied-argument-marker* for commands with >1 arguments. Previously, every argument would be treated as if it was *unsupplied-argument-marker* if just a single one was. Was this on purpose? It looked like a slight oversight regarding the behavior of DO. --- /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/10 09:52:05 1.1 +++ /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/16 14:45:58 1.2 @@ -108,11 +108,13 @@ (let (result) ;; only required args for now. (do ((required-args required-args (cdr required-args)) - (arg (car required-args) (car required-args)) + (arg (car required-args) (cadr required-args)) (command-args command-args (cdr command-args)) - (command-arg (car command-args) (car command-args))) + (command-arg (car command-args) (cadr command-args))) ((null required-args) (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg - (push (esa-parse-one-arg stream name ptype args command-arg) + (push (if (eq command-arg *unsupplied-argument-marker*) + (esa-parse-one-arg stream name ptype args command-arg) + command-arg) result) (maybe-clear-input)))))))))

1 0