[climacs-cvs] CVS climacs

[thenriksen]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv19479

Modified Files:
	lisp-syntax.lisp 
Log Message:
Added `token-to-object' function that will convert parser tokens to
Lisp objects (for example, a `complete-list-form' to a list).

Fixed a comment and some indentation.


--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp	2006/04/23 15:04:52	1.54
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp	2006/04/23 15:14:49	1.55
@@ -380,7 +380,7 @@
 	(#\| (fo) (make-instance 'multiple-escape-start-lexeme))
 	(t (cond ((or (constituentp object)
 		      (eql object #\\))
-		  (lex-token syntax scan))
+                  (lex-token syntax scan))
 		 (t (fo) (make-instance 'error-lexeme))))))))
 
 (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan)
@@ -1249,7 +1249,7 @@
                (return item))))
 
 (defun elt-form (list n)
-  "Returns the nth form in list."
+  "Returns the nth form in list or `nil'."
   (nth-form n list))
 
 (defun first-form (list)
@@ -1897,28 +1897,108 @@
 		(parse-token input readtable-case))))))
 |#
 
+(defun token-string (syntax token)
+  "Return the string that specifies `token' in the buffer of
+  `syntax'."
+  (coerce (buffer-sequence (buffer syntax)
+                           (start-offset token)
+                           (end-offset token))
+          'string))
+
 (defun parse-symbol (string &optional (package *package*))
   "Find the symbol named STRING.
-Return the symbol and a flag indicating whether the symbol was found."
+Return the symbol and a flag indicating whether the symbol was
+found in the package. Note that a symbol may be returned even if
+it was not found in a package."
   (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 symbol-name package)
-          (values nil nil)))))
+      (or (and package
+               (find-symbol symbol-name package))
+          (values (make-symbol symbol-name) nil)))))
 
 (defun token-to-symbol (syntax token)
-  (let ((package (if (and (slot-boundp syntax 'package)
-                          (slot-value syntax 'package)
-			  (typep (slot-value syntax 'package) 'package))
-		     (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)))
+  "Return the symbol `token' represents. If `token' represents
+anything else than a symbol, or it cannot be correctly converted
+to a symbol, return nil. If the symbol cannot be found in a
+package, an uninterned symbol will be returned."
+  (let ((result (token-to-object syntax token t)))
+    (when (symbolp result)
+      result)))
+
+;; FIXME? This generic function often errors on erroneous input. Since
+;; we are an editor, we might consider being a bit more lenient. Also,
+;; it will never intern symbols itself, but return NIL for uninterned
+;; symbols.
+(defgeneric token-to-object (syntax token &optional no-error)
+  (: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 &optional no-error)
+           ;; Ensure that every symbol that is READ will be looked up
+           ;; in the correct package.
+           (handler-case (let ((*package* (if (and (slot-boundp syntax 'package)
+                                                   (slot-value syntax 'package)
+                                                   (typep (slot-value syntax 'package) 'package))
+                                              (slot-value syntax 'package)
+                                              (find-package :common-lisp))))
+                           (call-next-method))
+             (t ()
+               (unless no-error
+                 (error "Cannot convert token to Lisp object: ~A" token)))))
+  (:method (syntax (token t) &optional no-error)
+    (declare (ignore no-error))
+    ;; 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))
+  (:method (syntax (token incomplete-form-mixin) &optional no-error)
+    (unless no-error
+      (error "Cannot convert incomplete form to Lisp object: ~A"
+             token))))
+
+(defmethod token-to-object (syntax (token complete-token-lexeme) &optional no-error)
+  (declare (ignore no-error))
+  (parse-symbol (token-string syntax token)))
+
+(defmethod token-to-object (syntax (token number-lexeme) &optional no-error)
+  (declare (ignore no-error))
+  (let ((*read-base* (base syntax)))
+    (read-from-string (token-string syntax token))))
+
+(defmethod token-to-object (syntax (token list-form) &optional 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 simple-vector-form) &optional no-error)
+  (declare (ignore no-error))
+  (apply #'vector
+         (mapcar #'(lambda (form)
+                     (token-to-object syntax form))
+                 (remove-if-not #'(lambda (form)
+                                    (typep form 'form))
+                                (children token)))))
+
+(defmethod token-to-object (syntax (token incomplete-string-form) &optional no-error)
+  (declare (ignore no-error))
+  (read-from-string (concatenate 'string
+                                 (token-string syntax token)
+                                 "\"")))
+
+(defmethod token-to-object (syntax (token complete-string-form) &optional no-error)
+  (declare (ignore no-error))
+  (read-from-string (token-string syntax token)))
+
+(defmethod token-to-object (syntax (token quote-form) &optional no-error)
+  (list 'cl:quote
+        (token-to-object syntax (second (children token)) no-error)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;