[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Wed Dec 6 11:31:12 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv26314
Modified Files:
lisp-syntax.lisp
Log Message:
Somewhat-fixed `token-to-object's handling of backquote forms. Has
been tested by repeatedly using `token-to-object' to convert
lisp-syntax.lisp into lists and feeding them to `eval' (this calls out
for a test case that recompiles Drei using code extracted with this
method!)
--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 19:20:47 1.10
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/06 11:31:12 1.11
@@ -1050,9 +1050,9 @@
;;;;;;;;;;;;;;;; Comma
;;; parse trees
-(defclass comma-form (form) ())
-(defclass comma-at-form (form) ())
-(defclass comma-dot-form (form) ())
+(defclass comma-form (form complete-form-mixin) ())
+(defclass comma-at-form (form complete-form-mixin) ())
+(defclass comma-dot-form (form complete-form-mixin) ())
(define-parser-state |, | (form-may-follow) ())
(define-parser-state |, form | (lexer-toplevel-state parser-state) ())
@@ -2477,25 +2477,21 @@
:case case
:no-error t))
-(defgeneric token-to-object (syntax token &key no-error package quote read &allow-other-keys)
+(defgeneric token-to-object (syntax token &key no-error package read backquoted &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 t) &rest args &key
- package quote no-error &allow-other-keys)
+ (:method :around (syntax (token t) &key package no-error &allow-other-keys)
;; Ensure that every symbol that is READ will be looked up
;; in the correct package. Also handle quoting.
(flet ((act ()
(let ((*package* (or package
(package-at-mark
- syntax (start-offset token)))))
- (cond (quote
- (setf (getf args :quote) nil)
- `',(call-next-method))
- (t
- (call-next-method))))))
+ syntax (start-offset token)))))
+
+ (call-next-method))))
(if no-error
(ignore-errors (act))
(act))))
@@ -2510,6 +2506,57 @@
(error "Cannot convert incomplete form to Lisp object: ~A"
token))))
+;;; The complicated primary structure forms.
+
+;; The problem is that we can't portably create in-memory backquote
+;; forms, so we have to rewrite them to calls to `nconc'. I think this
+;; is valid, because the CLHS doesn't specify the in-memory
+;; representation of backquoted forms, and thus the user can't assume
+;; that it isn't just a whole bunch of calls to `nconc' anyway.
+(defmethod token-to-object (syntax (token list-form) &rest args &key backquoted)
+ (if backquoted
+ `(nconc ,@(loop for child in (children token)
+ if (typep child 'comma-at-form)
+ collect (apply #'token-to-object syntax child :backquoted nil args)
+ else if (typep child 'comma-form)
+ collect `(list ,(apply #'token-to-object syntax child :backquoted nil args))
+ else if (form-token-p child)
+ collect `(list ,`',(apply #'token-to-object syntax child args))
+ else if (formp child)
+ collect `(list ,(apply #'token-to-object syntax child args))))
+ (mapcar #'(lambda (child)
+ (apply #'token-to-object syntax child args))
+ (remove-if-not #'formp (children token)))))
+
+(defmethod token-to-object (syntax (token complete-quote-form) &rest args &key backquoted)
+ (if backquoted
+ (let ((quoted-form (first-form (children token))))
+ (if (form-token-p quoted-form)
+ `(list 'quote (quote ,(apply #'token-to-object syntax (second (children token)) args)))
+ `(list 'quote ,(apply #'token-to-object syntax (second (children token)) args))))
+ `',(apply #'token-to-object syntax (second (children token)) args)))
+
+(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args)
+ (declare (ignore args))
+ ;; Utterly arbitrary, but reasonable in my opinion.
+ '(quote))
+
+;; I'm not sure backquotes are handled correctly, but they should be,
+;; at least when :read t is specified.
+(defmethod token-to-object (syntax (token backquote-form) &rest args)
+ (let ((backquoted-form (first-form (children token))))
+ (if (form-token-p backquoted-form)
+ `',(apply #'token-to-object syntax backquoted-form args)
+ (apply #'token-to-object syntax backquoted-form :backquoted t args))))
+
+(defmethod token-to-object (syntax (token comma-form) &rest args)
+ (apply #'token-to-object syntax (first-form (children token)) :backquoted nil args))
+
+(defmethod token-to-object (syntax (token comma-at-form) &rest args)
+ (apply #'token-to-object syntax (first-form (children token)) :backquoted nil args))
+
+;;; The atom(-ish) forms.
+
(defmethod token-to-object (syntax (token complete-token-lexeme)
&key no-error read (case (readtable-case *readtable*))
&allow-other-keys)
@@ -2531,13 +2578,6 @@
(let ((*read-base* (base syntax)))
(read-from-string (token-string syntax token))))
-(defmethod token-to-object (syntax (token list-form) &rest args)
- (loop for child in (children token)
- if (typep child 'comma-at-form)
- nconc (listed (apply #'token-to-object syntax child args))
- else if (formp child)
- collect (apply #'token-to-object syntax child args)))
-
(defmethod token-to-object (syntax (token simple-vector-form) &key &allow-other-keys)
(apply #'vector (call-next-method)))
@@ -2551,34 +2591,6 @@
(declare (ignore no-error))
(read-from-string (token-string syntax token)))
-(defmethod token-to-object (syntax (token complete-quote-form) &rest args)
- (apply #'token-to-object syntax (second (children token)) :quote t args))
-
-(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args)
- (declare (ignore args))
- ;; Utterly arbitrary, but reasonable in my opinion.
- '(quote))
-
-;; I'm not sure backquotes are handled correctly, but they should be,
-;; at least when :read t is specified.
-(defmethod token-to-object (syntax (token backquote-form) &rest args)
- (let ((backquoted-form (first-form (children token))))
- (if (form-list-p backquoted-form)
- `(list ,@(loop for element in (children backquoted-form)
- if (form-comma-p element)
- collect (apply #'token-to-object syntax element args)
- else if (form-comma-at-p element)
- nconc (listed (apply #'token-to-object syntax element args))
- else if (formp element)
- collect (apply #'token-to-object syntax element :quote t 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)))
More information about the Mcclim-cvs
mailing list