[climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp
Robert Strandh
rstrandh at common-lisp.net
Wed Jun 15 06:00:21 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv1314
Modified Files:
gui.lisp lisp-syntax.lisp
Log Message:
Initial steps toward more Common Lisp awareness. For now, we parse
lexemes into symbols whenever possible, and present them as such. For
experimentation, two commands com-accept-string and com-accept-symbol
exist to verify that the presentation works.
The symbols we obtain will be used to compute indentation, which is
next on the list of things to do.
Date: Wed Jun 15 08:00:13 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.143 climacs/gui.lisp:1.144
--- climacs/gui.lisp:1.143 Mon May 30 11:33:39 2005
+++ climacs/gui.lisp Wed Jun 15 08:00:12 2005
@@ -1412,6 +1412,18 @@
(syntax (syntax (buffer pane))))
(eval-defun point syntax)))
+(define-named-command com-package ()
+ (let* ((pane (current-window))
+ (syntax (syntax (buffer pane)))
+ (package (climacs-lisp-syntax::package-of syntax)))
+ (display-message (format nil "~s" package))))
+
+(define-named-command com-accept-string ()
+ (display-message (format nil "~s" (accept 'string))))
+
+(define-named-command com-accept-symbol ()
+ (display-message (format nil "~s" (accept 'symbol))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Global and dead-escape command tables
Index: climacs/lisp-syntax.lisp
diff -u climacs/lisp-syntax.lisp:1.6 climacs/lisp-syntax.lisp:1.7
--- climacs/lisp-syntax.lisp:1.6 Mon Jun 13 09:08:23 2005
+++ climacs/lisp-syntax.lisp Wed Jun 15 08:00:12 2005
@@ -33,7 +33,8 @@
(current-state)
(current-start-mark)
(current-size)
- (scan))
+ (scan)
+ (package))
(:name "Lisp")
(:pathname-types "lisp" "lsp" "cl"))
@@ -757,6 +758,30 @@
(defmethod update-syntax-for-display (buffer (syntax lisp-syntax) top bot)
nil)
+(defun package-of (syntax)
+ (let ((buffer (buffer syntax)))
+ (flet ((test (x)
+ (and (typep x 'list-form)
+ (not (null (cdr (children x))))
+ (buffer-looking-at buffer
+ (start-offset (cadr (children x)))
+ "in-package"
+ :test #'char-equal))))
+ (with-slots (stack-top) syntax
+ (let ((form (find-if #'test (children stack-top))))
+ (and form
+ (not (null (cddr (children form))))
+ (let* ((package-form (caddr (children form)))
+ (package-name (coerce (buffer-sequence
+ buffer
+ (start-offset package-form)
+ (end-offset package-form))
+ 'string))
+ (package-symbol
+ (let ((*package* (find-package :common-lisp)))
+ (read-from-string package-name nil nil))))
+ (find-package package-symbol))))))))
+
(defmethod update-syntax (buffer (syntax lisp-syntax))
(let* ((low-mark (low-mark buffer))
(high-mark (high-mark buffer)))
@@ -775,7 +800,9 @@
(new-state syntax
(parser-state stack-top)
stack-top)))
- (loop do (parse-patch syntax)))))))
+ (loop do (parse-patch syntax))))))
+ (with-slots (package) syntax
+ (setf package (package-of syntax))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -849,19 +876,24 @@
(medium-ink (sheet-medium pane)))
(eq (slot-value t1 'face)
(text-style-face (medium-text-style (sheet-medium pane)))))))
- (updating-output (pane :unique-id parser-symbol
- :id-test #'eq
- :cache-value parser-symbol
- :cache-test #'cache-test)
- (with-slots (ink face) parser-symbol
- (setf ink (medium-ink (sheet-medium pane))
- face (text-style-face (medium-text-style (sheet-medium pane))))
- (present (coerce (buffer-sequence (buffer syntax)
- (start-offset parser-symbol)
- (end-offset parser-symbol))
- 'string)
- 'string
- :stream pane)))))
+ (updating-output
+ (pane :unique-id parser-symbol
+ :id-test #'eq
+ :cache-value parser-symbol
+ :cache-test #'cache-test)
+ (with-slots (ink face) parser-symbol
+ (setf ink (medium-ink (sheet-medium pane))
+ face (text-style-face (medium-text-style (sheet-medium pane))))
+ (let ((string (coerce (buffer-sequence (buffer syntax)
+ (start-offset parser-symbol)
+ (end-offset parser-symbol))
+ 'string)))
+ (multiple-value-bind (symbol status)
+ (token-to-symbol syntax parser-symbol)
+ (declare (ignore symbol))
+ (if (and status (typep parser-symbol 'form))
+ (present string 'symbol :stream pane)
+ (present string 'string :stream pane))))))))
(defmethod display-parse-tree :before ((parse-symbol lisp-lexeme) (syntax lisp-syntax) pane)
(handle-whitespace pane (buffer pane) *white-space-start* (start-offset parse-symbol))
@@ -1007,4 +1039,52 @@
(coerce (buffer-sequence (buffer syntax)
(start-offset form)
(end-offset form))
- 'string)))))))
\ No newline at end of file
+ 'string)))))))
+
+;;; shamelessly stolen from SWANK
+
+(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)))
+
+;; 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))))))
+
+(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))))
+ (if package
+ (find-symbol (casify sname) package)
+ (values nil nil)))))
+
+
+(defun token-to-symbol (syntax token)
+ (let ((package (or (slot-value syntax 'package)
+ (find-package :common-lisp)))
+ (token-string (coerce (buffer-sequence (buffer syntax)
+ (start-offset token)
+ (end-offset token))
+ 'string)))
+ (parse-symbol token-string package)))
More information about the Climacs-cvs
mailing list