Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10692

Modified Files: lisp-syntax.lisp Log Message: Many improvements to Lisp syntax. (thanks to John Q Splittist)

Date: Sun Jul 24 10:06:50 2005 Author: rstrandh

Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.14 climacs/lisp-syntax.lisp:1.15 --- climacs/lisp-syntax.lisp:1.14 Wed Jul 20 09:16:37 2005 +++ climacs/lisp-syntax.lisp Sun Jul 24 10:06:50 2005 @@ -94,10 +94,10 @@ (:documentation "In this state, the lexer is working inside a long comment delimited by #| and |#."))

-(define-lexer-state lexer-symbol-state () +(define-lexer-state lexer-escaped-token-state () () - (:documentation "In this state, the lexer is working inside a symbol - delimited by | and |.")) + (: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 @@ -164,17 +164,15 @@

(defclass error-lexeme (lisp-lexeme) ()) (defclass left-parenthesis-lexeme (lisp-lexeme) ()) +(defclass simple-vector-start-lexeme (lisp-lexeme) ()) (defclass right-parenthesis-lexeme (lisp-lexeme) ()) (defclass quote-lexeme (lisp-lexeme) ()) (defclass backquote-lexeme (lisp-lexeme) ()) (defclass comma-lexeme (lisp-lexeme) ()) (defclass form-lexeme (form lisp-lexeme) ()) -(defclass token-lexeme (form-lexeme) ()) (defclass character-lexeme (form-lexeme) ()) (defclass function-lexeme (lisp-lexeme) ()) (defclass line-comment-start-lexeme (lisp-lexeme) ()) -(defclass symbol-start-lexeme (lisp-lexeme) ()) -(defclass symbol-end-lexeme (lisp-lexeme) ()) (defclass long-comment-start-lexeme (lisp-lexeme) ()) (defclass comment-end-lexeme (lisp-lexeme) ()) (defclass string-start-lexeme (lisp-lexeme) ()) @@ -182,9 +180,21 @@ (defclass word-lexeme (lisp-lexeme) ()) (defclass delimiter-lexeme (lisp-lexeme) ()) (defclass text-lexeme (lisp-lexeme) ()) +(defclass sharpsign-equals-lexeme (lisp-lexeme) ()) +(defclass sharpsign-sharpsign-lexeme (form-lexeme) ()) (defclass reader-conditional-positive-lexeme (lisp-lexeme) ()) (defclass reader-conditional-negative-lexeme (lisp-lexeme) ()) (defclass uninterned-symbol-lexeme (lisp-lexeme) ()) +(defclass readtime-evaluation-lexeme (lisp-lexeme) ()) +(defclass array-start-lexeme (lisp-lexeme) ()) +(defclass structure-start-lexeme (lisp-lexeme) ()) +(defclass pathname-start-lexeme (lisp-lexeme) ()) +(defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) +(defclass bit-vector-lexeme (form-lexeme) ()) +(defclass token-mixin () ()) +(defclass complete-token-lexeme (token-mixin form-lexeme) ()) +(defclass multiple-escape-start-lexeme (lisp-lexeme) ()) +(defclass multiple-escape-end-lexeme (lisp-lexeme) ())

(defmethod skip-inter ((syntax lisp-syntax) state scan) (macrolet ((fo () `(forward-object scan))) @@ -210,46 +220,89 @@ (let ((object (object-after scan))) (case object (#( (fo) (make-instance 'left-parenthesis-lexeme)) + ;#) is an error (#' (fo) (make-instance 'quote-lexeme)) - (#` (fo) (make-instance 'backquote-lexeme)) - (#, (fo) (make-instance 'comma-lexeme)) - (#" (fo) (make-instance 'string-start-lexeme)) (#; (fo) (loop until (or (end-of-buffer-p scan) (end-of-line-p scan) (not (eql (object-after scan) #;))) do (fo)) (make-instance 'line-comment-start-lexeme)) - (#| (fo) (make-instance 'symbol-start-lexeme)) + (#" (fo) (make-instance 'string-start-lexeme)) + (#` (fo) (make-instance 'backquote-lexeme)) + (#, (fo) (make-instance 'comma-lexeme)) (## (fo) - ( if (end-of-buffer-p scan) - (make-instance 'error-lexeme) - (case (object-after scan) - (#\ (fo) - (cond ((end-of-buffer-p scan) - (make-instance 'error-lexeme)) - ((not (constituentp (object-after scan))) - (fo) (make-instance 'character-lexeme)) - (t (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-instance 'character-lexeme)))) - (#' (fo) - (make-instance 'function-lexeme)) - (#| (fo) - (make-instance 'long-comment-start-lexeme)) - (#+ (fo) - (make-instance 'reader-conditional-positive-lexeme)) - (#- (fo) - (make-instance 'reader-conditional-negative-lexeme)) - (#: (fo) - (make-instance 'uninterned-symbol-lexeme)) - (t (fo) (make-instance 'error-lexeme))))) - (t (cond ((constituentp object) - (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-instance 'token-lexeme)) + (cond ((end-of-buffer-p scan) + (make-instance 'error-lexeme)) + (t + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan)) + do (fo)) + (if (end-of-buffer-p scan) + (make-instance 'error-lexeme) + (case (object-after scan) + ((#\Backspace #\Tab #\Newline #\Linefeed + #\Page #\Return #\Space #)) + (fo) + (make-instance 'error-lexeme)) + (#\ (fo) + (cond ((end-of-buffer-p scan) + (make-instance 'error-lexeme)) + ((not (constituentp (object-after scan))) + (fo) (make-instance 'character-lexeme)) + (t (loop until (end-of-buffer-p scan) + while (constituentp (object-after scan)) + do (fo)) + (make-instance 'character-lexeme)))) + (#' (fo) + (make-instance 'function-lexeme)) + (#( (fo) + (make-instance 'simple-vector-start-lexeme)) + (#* (fo) + (loop until (end-of-buffer-p scan) + while (or (eql (object-after scan) #\1) + (eql (object-after scan) #\0)) + do (fo)) + (if (and (not (end-of-buffer-p scan)) + (constituentp (object-after scan))) + (make-instance 'error-lexeme) + (make-instance 'bit-vector-lexeme))) + (#: (fo) + (make-instance 'uninterned-symbol-lexeme)) + (#. (fo) + (make-instance 'readtime-evaluation-lexeme)) + ;((#\B #\b) ) + ;((#\O #\o) ) + ;((#\X #\x) ) + ;((#\R #\r) ) + ;((#\C #\c) ) + ((#\A #\a) (fo) + (make-instance 'array-start-lexeme)) + ((#\S #\s) (fo) + (cond ((and (not (end-of-buffer-p scan)) + (eql (object-after scan) #()) + (fo) + (make-instance 'structure-start-lexeme)) + (t (make-instance 'error-lexeme)))) + ((#\P #\p) (fo) + (make-instance 'pathname-start-lexeme)) + (#= (fo) + (make-instance 'sharpsign-equals-lexeme)) + (## (fo) + (make-instance 'sharpsign-sharpsign-lexeme)) + (#+ (fo) + (make-instance 'reader-conditional-positive-lexeme)) + (#- (fo) + (make-instance 'reader-conditional-negative-lexeme)) + (#| (fo) + (make-instance 'long-comment-start-lexeme)) + (#< (fo) + (make-instance 'error-lexeme)) + (t (fo) (make-instance 'undefined-reader-macro-lexeme))))))) + (#| (fo) (make-instance 'multiple-escape-start-lexeme)) + (t (cond ((or (constituentp object) + (eql object #\)) + (lex-token scan)) (t (fo) (make-instance 'error-lexeme))))))))

(defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) @@ -315,27 +368,50 @@ (make-instance 'word-lexeme)) (t (fo) (make-instance 'delimiter-lexeme)))))

-(defmethod skip-inter ((syntax lisp-syntax) (state lexer-symbol-state) scan) +(defun lex-token (scan) (macrolet ((fo () `(forward-object scan))) - (loop while (and (end-of-line-p scan) - (not (end-of-buffer-p scan))) - do (fo))) - (not (end-of-buffer-p scan))) - -(defmethod lex ((syntax lisp-syntax) (state lexer-symbol-state) scan) - (macrolet ((fo () `(forward-object scan))) - (cond ((eql (object-after scan) #|) + (tagbody + start + (when (end-of-buffer-p scan) + (return-from lex-token (make-instance 'complete-token-lexeme))) + (when (constituentp (object-after scan)) + (fo) + (go start)) + (when (eql (object-after scan) #\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex-token (make-instance 'error-lexeme))) + (fo) + (go start)) + (when (eql (object-after scan) #|) + (fo) + (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) + (return-from lex-token (make-instance 'complete-token-lexeme))))) + +(defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) + (let ((bars-seen 0)) + (macrolet ((fo () `(forward-object scan))) + (tagbody + start + (when (end-of-buffer-p scan) + (return-from lex (make-instance 'error-lexeme))) + (when (eql (object-after scan) #\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex (make-instance 'error-lexeme))) (fo) - (make-instance 'symbol-end-lexeme)) - (t (loop do (cond ((or (end-of-line-p scan) - (eql (object-after scan) #|)) - (return (make-instance 'text-lexeme))) - ((eql (object-after scan) #\) - (fo) - (if (end-of-line-p scan) - (return (make-instance 'text-lexeme)) - (fo))) - (t (fo)))))))) + (go start)) + (when (eql (object-after scan) #|) + (incf bars-seen) + (fo) + (go start)) + (unless (whitespacep (object-after scan)) + (fo) + (go start)) + (return-from lex + (if (oddp bars-seen) + (make-instance 'multiple-escape-end-lexeme) + (make-instance 'text-lexeme)))))))

(defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -490,6 +566,28 @@ (define-lisp-action (|( form* | (eql nil)) (reduce-until-type incomplete-list-form left-parenthesis-lexeme))

+;;;;;;;;;;;;;;;; Simple Vector + +;;; parse trees +(defclass simple-vector-form (list-form) ()) +(defclass complete-simple-vector-form (complete-list-form) ()) +(defclass incomplete-simple-vector-form (incomplete-list-form) ()) + +(define-parser-state |#( form* | (lexer-list-state form-may-follow) ()) +(define-parser-state |#( form* ) | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow simple-vector-start-lexeme) |#( form* |) +(define-new-lisp-state (|#( form* | form) |#( form* |) +(define-new-lisp-state (|#( form* | right-parenthesis-lexeme) |#( form* ) |) + +;;; reduce according to the rule form -> #( form* ) +(define-lisp-action (|#( form* ) | t) + (reduce-until-type complete-simple-vector-form simple-vector-start-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|#( form* | (eql nil)) + (reduce-until-type incomplete-simple-vector-form simple-vector-start-lexeme)) + ;;;;;;;;;;;;;;;; String

;;; parse trees @@ -532,8 +630,6 @@

;;;;;;;;;;;;;;;; Long comment

-;; FIXME this does not work for nested comments - ;;; parse trees (defclass long-comment-form (form) ()) (defclass complete-long-comment-form (long-comment-form) ()) @@ -557,27 +653,27 @@ (define-lisp-action (|#| word* | (eql nil)) (reduce-until-type incomplete-long-comment-form long-comment-start-lexeme))

-;;;;;;;;;;;;;;;; Symbol name surrounded with vertical bars +;;;;;;;;;;;;;;;; Token (number or symbol)

;;; parse trees -(defclass symbol-form (form) ()) -(defclass complete-symbol-form (symbol-form) ()) -(defclass incomplete-symbol-form (symbol-form incomplete-form-mixin) ()) - -(define-parser-state || text* | (lexer-symbol-state parser-state) ()) -(define-parser-state || text* | | (lexer-toplevel-state parser-state) ()) - -(define-new-lisp-state (form-may-follow symbol-start-lexeme) || text* |) -(define-new-lisp-state (|| text* | text-lexeme) || text* |) -(define-new-lisp-state (|| text* | symbol-end-lexeme) || text* | |) - -;;; reduce according to the rule form -> | text* | -(define-lisp-action (|| text* | | t) - (reduce-until-type complete-symbol-form symbol-start-lexeme)) +(defclass token-form (form token-mixin) ()) +(defclass complete-token-form (token-form) ()) +(defclass incomplete-token-form (token-form) ()) + +(define-parser-state | m-e-start text* | (lexer-escaped-token-state parser-state) ()) +(define-parser-state | m-e-start text* m-e-end | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow multiple-escape-start-lexeme) | m-e-start text* |) +(define-new-lisp-state (| m-e-start text* | text-lexeme) | m-e-start text* |) +(define-new-lisp-state (| m-e-start text* | multiple-escape-end-lexeme) | m-e-start text* m-e-end |) + +;;; reduce according to the rule form -> m-e-start text* m-e-end +(define-lisp-action (| m-e-start text* m-e-end | t) + (reduce-until-type complete-token-form multiple-escape-start-lexeme))

;;; reduce at the end of the buffer -(define-lisp-action (|| text* | (eql nil)) - (reduce-until-type incomplete-symbol-form symbol-start-lexeme)) +(define-lisp-action (| m-e-start text* | (eql nil)) + (reduce-until-type incomplete-token-form multiple-escape-start-lexeme))

;;;;;;;;;;;;;;;; Quote

@@ -680,6 +776,106 @@ (define-lisp-action (|#: form | t) (reduce-fixed-number uninterned-symbol-form 2))

+;;;;;;;;;;;;;;;; readtime evaluation + +;;; parse trees +(defclass readtime-evaluation-form (form) ()) + +(define-parser-state |#. | (form-may-follow) ()) +(define-parser-state |#. form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow readtime-evaluation-lexeme) |' |) +(define-new-lisp-state (|#. | form) |#. form |) + +;;; reduce according to the rule form -> #. form +(define-lisp-action (|#. form | t) + (reduce-fixed-number readtime-evaluation-form 2)) + +;;;;;;;;;;;;;;;; sharpsign equals + +;;; parse trees +(defclass sharpsign-equals-form (form) ()) + +(define-parser-state |#= | (form-may-follow) ()) +(define-parser-state |#= form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow sharpsign-equals-lexeme) |' |) +(define-new-lisp-state (|#= | form) |#= form |) + +;;; reduce according to the rule form -> #= form +(define-lisp-action (|#= form | t) + (reduce-fixed-number sharpsign-equals-form 2)) + +;;;;;;;;;;;;;;;; array + +;;; parse trees +(defclass array-form (form) ()) + +(define-parser-state |#A | (form-may-follow) ()) +(define-parser-state |#A form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow array-start-lexeme) |' |) +(define-new-lisp-state (|#A | form) |#A form |) + +;;; reduce according to the rule form -> #A form +(define-lisp-action (|#A form | t) + (reduce-fixed-number array-start-form 2)) + +;;;;;;;;;;;;;;;; structure + +;;; parse trees +(defclass structure-form (list-form) ()) +(defclass complete-structure-form (complete-list-form) ()) +(defclass incomplete-structure-form (incomplete-list-form) ()) + +(define-parser-state |#S( form* | (lexer-list-state form-may-follow) ()) +(define-parser-state |#S( form* ) | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow structure-start-lexeme) |#S( form* |) +(define-new-lisp-state (|#S( form* | form) |#S( form* |) +(define-new-lisp-state (|#S( form* | right-parenthesis-lexeme) |#S( form* ) |) + +;;; reduce according to the rule form -> #S( form* ) +(define-lisp-action (|#S( form* ) | t) + (reduce-until-type complete-structure-form structure-start-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|#S( form* | (eql nil)) + (reduce-until-type incomplete-structure-form structure-start-lexeme)) + + +;;;;;;;;;;;;;;;; pathname + +;;; FIXME: #P _must_ be followed by a string + +;;; parse trees +(defclass pathname-form (form) ()) + +(define-parser-state |#P | (form-may-follow) ()) +(define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow pathname-start-lexeme) |' |) +(define-new-lisp-state (|#P | form) |#P form |) + +;;; reduce according to the rule form -> #P form +(define-lisp-action (|#P form | t) + (reduce-fixed-number pathname-start-form 2)) + +;;;;;;;;;;;;;;;; undefined reader macro + +;;; parse trees +(defclass undefined-reader-macro-form (form) ()) + +(define-parser-state |#<other> | (form-may-follow) ()) +(define-parser-state |#<other> form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow undefined-reader-macro-lexeme) |' |) +(define-new-lisp-state (|#<other> | form) |#<other> form |) + +;;; reduce according to the rule form -> #: form +(define-lisp-action (|#: form | t) + (reduce-fixed-number uninterned-symbol-form 2)) +

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -888,11 +1084,15 @@ (with-drawing-options (pane :ink +red+) (call-next-method)))

-(defmethod display-parse-tree ((parse-symbol token-lexeme) (syntax lisp-syntax) pane) - (if (and (> (end-offset parse-symbol) (start-offset parse-symbol)) - (eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #:)) - (with-drawing-options (pane :ink +dark-violet+) - (call-next-method)) +(defmethod display-parse-tree ((parse-symbol token-mixin) (syntax lisp-syntax) pane) + (if (> (end-offset parse-symbol) (start-offset parse-symbol)) + (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #:) + (with-drawing-options (pane :ink +dark-violet+) + (call-next-method))) + ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #&) + (with-drawing-options (pane :ink +dark-green+) + (call-next-method))) + (t (call-next-method))) (call-next-method)))

(defmethod display-parse-tree ((parser-symbol lisp-lexeme) (syntax lisp-syntax) pane) @@ -957,9 +1157,6 @@ (loop for child in (cdr children) do (display-parse-tree child syntax pane))))

-(defmethod display-parse-tree ((parse-symbol symbol-form) (syntax lisp-syntax) pane) - (call-next-method)) - (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax lisp-syntax) current-p) (declare (ignore current-p)) (with-slots (top bot) pane @@ -971,7 +1168,10 @@ (display-parse-tree stack-top syntax pane)) (with-slots (top) pane (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) + (style (medium-text-style pane)) + (ascent (text-style-ascent style pane)) + (descent (text-style-descent style pane)) + (height (+ ascent descent)) (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) (cursor-column (buffer-display-column @@ -980,8 +1180,8 @@ (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) (updating-output (pane :unique-id -1) (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) + (1- cursor-x) cursor-y + (+ cursor-x 2) (+ cursor-y ascent descent) :ink (if current-p +red+ +blue+))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1079,46 +1279,141 @@ (defconstant keyword-package (find-package :keyword) "The KEYWORD package.")

-;; FIXME: deal with #| etc. hard to do portably. -(defun tokenize-symbol (string) - (let ((package (let ((pos (position #: string))) - (if pos (subseq string 0 pos) nil))) - (symbol (let ((pos (position #: string :from-end t))) - (if pos (subseq string (1+ pos)) string))) - (internp (search "::" string))) - (values symbol package internp))) - -(defun determine-case (string) - "Return two booleans LOWER and UPPER indicating whether STRING -contains lower or upper case characters." - (values (some #'lower-case-p string) - (some #'upper-case-p string))) - -;; FIXME: Escape chars are ignored -(defun casify (string) - "Convert string accoring to readtable-case." - (ecase (readtable-case *readtable*) - (:preserve string) - (:upcase (string-upcase string)) - (:downcase (string-downcase string)) - (:invert (multiple-value-bind (lower upper) (determine-case string) - (cond ((and lower upper) string) - (lower (string-upcase string)) - (upper (string-downcase string)) - (t string)))))) +;;; shamelessly replacing SWANK code +;; We first work through the string removing the characters and noting +;; which ones are escaped. We then replace each character with the +;; appropriate case version, according to the readtable. +;; Finally, we extract the package and symbol names. +;; Being in an editor, we are waaay more lenient than the reader. + +(defun parse-escapes (string) + "Return a string and a list of escaped character positions. +Uses part of the READ algorithm in CLTL2 22.1.1." + (let ((length (length string)) + (index 0) + irreplaceables chars) + (tagbody + step-8 + (unless (< index length) (go end)) + (cond + ((char/= (char string index) #\ #|) + (push (char string index) chars) + (incf index) + (go step-8)) + ((char= (char string index) #\) + (push (length chars) irreplaceables) + (incf index) + (unless (< index length) (go end)) + (push (char string index) chars) + (incf index) + (go step-8)) + ((char= (char string index) #|) + (incf index) + (go step-9))) + step-9 + (unless (< index length) (go end)) + (cond + ((char/= (char string index) #\ #|) + (push (length chars) irreplaceables) + (push (char string index) chars) + (incf index) + (go step-9)) + ((char= (char string index) #\) + (push (length chars) irreplaceables) + (incf index) + (unless (< index length) (go end)) + (push (char string index) chars) + (incf index) + (go step-9)) + ((char= (char string index) #|) + (incf index) + (go step-8))) + end + (return-from parse-escapes + (values (coerce (nreverse chars) 'string) + (nreverse irreplaceables)))))) + +(defun invert-cases (string &optional (irreplaceables nil)) + "Returns two flags: unescaped upper-case and lower-case chars in STRING." + (loop for index below (length string) + with upper = nil + with lower = nil + when (not (member index irreplaceables)) + if (upper-case-p (char string index)) + do (setf upper t) end + if (lower-case-p (char string index)) + do (setf lower t) end + finally (return (values upper lower)))) + +(defun replace-case (string &optional (case (readtable-case *readtable*)) + (irreplaceables nil)) + "Convert string according to readtable-case." + (multiple-value-bind (upper lower) (invert-cases string irreplaceables) + (loop for index below (length string) + as char = (char string index) then (char string index) + if (member index irreplaceables) + collect char into chars + else + collect (ecase case + (:preserve char) + (:upcase (char-upcase char)) + (:downcase (char-downcase char)) + (:invert (cond ((and lower upper) char) + (lower (char-upcase char)) + (upper (char-downcase char)) + (t char)))) into chars + finally (return (coerce chars 'string))))) + +(defun parse-token (string &optional (case (readtable-case *readtable*))) + "Extracts the symbol-name and package name from STRING +and whether the symbol-name was separated from the package by a double colon." + (multiple-value-bind (string irreplaceables) (parse-escapes string) + (let ((string (replace-case string case irreplaceables)) + package-name symbol-name internalp) + (loop for index below (length string) + with symbol-start = 0 + when (and (char= (char string index) #:) + (not (member index irreplaceables))) + do (setf package-name (subseq string 0 index)) + (if (and (< (incf index) (length string)) + (char= (char string index) #:) + (not (member index irreplaceables))) + (setf symbol-start (1+ index) + internalp t) + (setf symbol-start index)) + (loop-finish) + finally (setf symbol-name (subseq string symbol-start))) + (values symbol-name package-name internalp)))) + +#| +;;; Compare CLHS 23.1.2.1 + (defun test-parse-token () + (let ((*readtable* (copy-readtable nil))) + (format t "READTABLE-CASE Input Symbol-name Token-name~ + ~%------------------------------------------------------~ + ~%") + (dolist (readtable-case '(:upcase :downcase :preserve :invert)) + (dolist (input '("ZEBRA" "Zebra" "zebra" "\zebra" "\Zebra" "z|ebr|a" + "|ZE\bRA|" "ze\|bra")) + (format t "~&:~A~16T~A~30T~A~44T~A" + (string-upcase readtable-case) + input + (progn (setf (readtable-case *readtable*) readtable-case) + (symbol-name (read-from-string input))) + (parse-token input readtable-case)))))) +|#

(defun parse-symbol (string &optional (package *package*)) "Find the symbol named STRING. -Return the symbol and a flag indicating whether the symbols was found." - (multiple-value-bind (sname pname) (tokenize-symbol string) - (let ((package (cond ((string= pname "") keyword-package) - (pname (find-package (casify pname))) - (t package)))) +Return the symbol and a flag indicating whether the symbol was found." + (multiple-value-bind (symbol-name package-name) (parse-token string) + (let ((package (cond ((string= package-name "") keyword-package) + (package-name (find-package package-name)) + (t package)))) (if package - (find-symbol (casify sname) package) + (find-symbol symbol-name package) (values nil nil)))))

- (defun token-to-symbol (syntax token) (let ((package (or (slot-value syntax 'package) (find-package :common-lisp))) @@ -1145,7 +1440,7 @@ ;; before first element (values tree 1) (let ((first-child (elt (children tree) 1))) - (cond ((and (typep first-child 'token-lexeme) + (cond ((and (typep first-child 'token-mixin) (token-to-symbol syntax first-child)) (compute-list-indentation syntax (token-to-symbol syntax first-child) tree path)) ((null (cdr path))