[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Tue May 2 14:33:33 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv5927
Modified Files:
lisp-syntax.lisp
Log Message:
Fixed the form-to-object methods and the form-to-symbol
function. Converted all calls to `form-to-symbol' to `form-to-object'.
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:29:44 1.59
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:33:33 1.60
@@ -1131,7 +1131,7 @@
(when (typep x 'complete-list-form)
(let ((candidate (first-form (children x))))
(and (typep candidate 'token-mixin)
- (eq (token-to-symbol syntax candidate)
+ (eq (token-to-object syntax candidate)
'cl:in-package))))))
(with-slots (stack-top) syntax
(let ((form (find-if #'test (children stack-top))))
@@ -1285,7 +1285,7 @@
;; operands and return nil.
(mapcar #'(lambda (operand)
(if (typep operand 'form)
- (token-to-object syntax operand t)))
+ (token-to-object syntax operand :no-error t)))
(rest-forms (children form))))
(defun form-toplevel (form syntax)
@@ -1557,7 +1557,7 @@
(start-offset conditional)
(end-offset conditional))
'string))
- (symbol (parse-symbol string +keyword-package+)))
+ (symbol (parse-symbol string :package +keyword-package+)))
(member symbol *features*)))
(defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax))
@@ -1576,7 +1576,7 @@
(start-offset type)
(end-offset type))
'string))
- (type-symbol (parse-symbol type-string +keyword-package+)))
+ (type-symbol (parse-symbol type-string :package +keyword-package+)))
(case type-symbol
(:and (funcall #'every #'eval-fc conditionals))
(:or (funcall #'some #'eval-fc conditionals))
@@ -1843,7 +1843,7 @@
(defmethod form-operator ((form list-form) syntax)
(let* ((operator-token (first-noncomment (rest (children form))))
(operator-symbol (when operator-token
- (token-to-symbol syntax operator-token))))
+ (token-to-object syntax operator-token))))
operator-symbol))
;;; shamelessly replacing SWANK code
@@ -1978,12 +1978,13 @@
(end-offset token))
'string))
-(defun parse-symbol (string &optional (package *package*))
+(defun parse-symbol (string &key (package *package*) (case (readtable-case *readtable*)))
"Find the symbol named STRING.
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)
+ (multiple-value-bind (symbol-name package-name)
+ (parse-token string case)
(let ((package (cond ((string= package-name "") +keyword-package+)
(package-name (find-package package-name))
(t package))))
@@ -1994,56 +1995,58 @@
(values symbol status)
(values (make-symbol symbol-name) nil))))))
-(defun token-to-symbol (syntax token)
- "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."
- (token-to-object syntax token t))
-
-;; 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)
+(defun token-to-symbol (syntax token &optional (case (readtable-case *readtable*)))
+ "Return the symbol `token' represents. If the symbol cannot be
+found in a package, an uninterned symbol will be returned."
+ (token-to-object syntax token
+ :case case
+ :no-error t))
+
+(defgeneric token-to-object (syntax token &key no-error &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 &optional no-error)
+ (:method :around (syntax token &key no-error package)
;; 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))))
+ (or (when package
+ (if (packagep package)
+ package
+ (find-package 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)
+ (:method (syntax (token t) &key 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)
+ (:method (syntax (token incomplete-form-mixin) &key 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)
+(defmethod token-to-object (syntax (token complete-token-lexeme)
+ &key no-error
+ (case (readtable-case *readtable*)))
(declare (ignore no-error))
- (parse-symbol (token-string syntax token)))
+ (parse-symbol (token-string syntax token) :case case))
-(defmethod token-to-object (syntax (token number-lexeme) &optional no-error)
+(defmethod token-to-object (syntax (token number-lexeme) &key 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)
+(defmethod token-to-object (syntax (token list-form) &key no-error)
(declare (ignore no-error))
(mapcar #'(lambda (form)
(token-to-object syntax form))
@@ -2051,7 +2054,7 @@
(typep form 'form))
(children token))))
-(defmethod token-to-object (syntax (token simple-vector-form) &optional no-error)
+(defmethod token-to-object (syntax (token simple-vector-form) &key no-error)
(declare (ignore no-error))
(apply #'vector
(mapcar #'(lambda (form)
@@ -2060,19 +2063,19 @@
(typep form 'form))
(children token)))))
-(defmethod token-to-object (syntax (token incomplete-string-form) &optional no-error)
+(defmethod token-to-object (syntax (token incomplete-string-form) &key 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)
+(defmethod token-to-object (syntax (token complete-string-form) &key no-error)
(declare (ignore no-error))
(read-from-string (token-string syntax token)))
-(defmethod token-to-object (syntax (token quote-form) &optional no-error)
+(defmethod token-to-object (syntax (token quote-form) &key no-error)
(list 'cl:quote
- (token-to-object syntax (second (children token)) no-error)))
+ (token-to-object syntax (second (children token)) :no-error no-error)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -2111,8 +2114,8 @@
(values tree 1)
(let ((first-child (elt-noncomment (children tree) 1)))
(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))
+ (token-to-object syntax first-child))
+ (compute-list-indentation syntax (token-to-object syntax first-child) tree path))
((null (cdr path))
;; top level
(if (= (car path) 2)
More information about the Climacs-cvs
mailing list