Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv6550
Modified Files:
lisp-syntax.lisp
Log Message:
Made Lisp syntax `form-to-object' handle label reader macros.
--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/10 20:54:13 1.16
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/15 22:13:16 1.17
@@ -2664,10 +2664,30 @@
(list* (car result) item (cdr result)))
(t (list op item result))))
-(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."
- (form-to-object syntax token :case case :no-error t))
+(define-condition reader-invoked (condition)
+ ((%end-mark :reader end-mark :initarg :end-mark
+ :initform (error "You must provide an ending-mark for
+the condition")
+ :documentation "The position at which the reader
+stopped reading, form-to-object conversion should be resumed
+from this point.")
+ (%object :reader object :initarg :object
+ :initform (error "You must provide the object that
+was returned by the reader")
+ :documentation "The object that was returned by the reader."))
+ (:documentation "Signal that the reader has been directly
+invoked on the buffer contents, that the object of this condition
+should be assumed as the result of the form-conversion."))
+
+(defun invoke-reader (syntax form)
+ "Use the system reader to handle `form' and signal a
+`reader-invoked' condition with the resulting data."
+ (let* ((start-mark (clone-mark (high-mark (buffer syntax)))))
+ (setf (offset start-mark) (start-offset form))
+ (let* ((stream (make-buffer-stream :buffer (buffer syntax)
+ :start-mark start-mark))
+ (object (read-preserving-whitespace stream)))
+ (signal 'reader-invoked :end-mark (point stream) :object object))))
(define-condition form-conversion-error (simple-error user-condition-mixin)
((syntax :reader syntax :initarg :syntax
@@ -2698,6 +2718,153 @@
(setf (offset (point drei))
(start-offset (form condition))))
+;;; Handling labels (#n= and #n#) takes a fair bit of machinery, most
+;;; of which is located here. We follow an approach similar to that
+;;; found in the SBCL reader, where we replace instances of #n# with a
+;;; special unique marker symbol that we replace before returning the
+;;; final object. We maintain two tables, one that maps labels to
+;;; placerholder symbols and one that maps placeholder symbols to the
+;;; concrete objects.
+
+(defvar *labels->placeholders* nil
+ "This variable holds an alist mapping labels (as integers) to a
+placeholder symbol. It is used for implementing the label reader
+macros (#n=foo #n#).")
+
+(defvar *label-placeholders->object* nil
+ "This variable holds an alist mapping placeholder symbols to
+the object. It is used for implementing the label reader
+macros (#n=foo #n#).")
+
+(defgeneric extract-label (syntax form)
+ (:documentation "Get the label of `form' as an integer."))
+
+(defmethod extract-label ((syntax lisp-syntax) (form sharpsign-equals-form))
+ (let ((string (form-string syntax (first (children form)))))
+ (parse-integer string :start 1 :end (1- (length string)) :radix 10)))
+
+(defmethod extract-label ((syntax lisp-syntax) (form sharpsign-sharpsign-lexeme))
+ (let ((string (form-string syntax form)))
+ (parse-integer string :start 1 :end (1- (length string)) :radix 10)))
+
+(defun register-form-label (syntax form &rest args)
+ "Register the label of `form' and the corresponding placeholder
+symbol. `Form' must be a sharpsign-equals form (#n=), and if the
+label has already been registered, an error of type
+`form-conversion-error' will be signalled. Args will be passed to
+`form-to-object' for the creation of the object referred to by
+the label. Returns `form' converted to an object."
+ (let* ((label (extract-label syntax form))
+ (placeholder-symbol (gensym)))
+ (when (assoc label *labels->placeholders*)
+ (form-conversion-error syntax form "multiply defined label: ~A" label))
+ (push (list label placeholder-symbol) *labels->placeholders*)
+ (let ((object (apply #'form-to-object syntax
+ (second (children form)) args)))
+ (push (list placeholder-symbol object) *label-placeholders->object*)
+ object)))
+
+(defgeneric find-and-register-label (syntax form label limit &rest args)
+ (:documentation "Find the object referred to by the integer
+value `label' in children of `form' or `form' itself. `Args' will
+be passed to `form-to-object' for the creation of the
+object. `Limit' is a buffer offset delimiting where not to search
+past."))
+
+(defmethod find-and-register-label ((syntax lisp-syntax) (form form)
+ (label integer) (limit integer) &rest args)
+ (find-if #'(lambda (child)
+ (when (and (formp child)
+ (< (start-offset form) limit))
+ (apply #'find-and-register-label syntax child label limit args)))
+ (children form)))
+
+(defmethod find-and-register-label ((syntax lisp-syntax) (form sharpsign-equals-form)
+ (label integer) (limit integer) &rest args)
+ (when (and (= (extract-label syntax form) label)
+ (< (start-offset form) limit))
+ (apply #'register-form-label syntax form args)))
+
+(defun ensure-label (syntax form label &rest args)
+ "Ensure as best as possible that `label' exist. `Form' is the
+form that needs the value of the label, limiting where to end the
+search. `Args' will be passed to `form-to-object' if it is
+necessary to create a new object for the label."
+ (unless (assoc label *labels->placeholders*)
+ (apply #'find-and-register-label syntax (form-toplevel form syntax) label (start-offset form) args)))
+
+(defun label-placeholder (syntax form label &optional search-whole-form &rest args)
+ "Get the placeholder for `label' (which must be an integer). If
+the placeholder symbol cannot be found, the label is undefined,
+and an error of type `form-conversion-error' will be
+signalled. If `search-whole-form' is true, the entire
+top-level-form will be searched for the label reference if it has
+not already been seen, upwards from `form', but not past
+`form'. `Args' will be passed as arguments to `form-to-object' to
+create the labelled object."
+ (when search-whole-form
+ (apply #'ensure-label syntax form label args))
+ (let ((pair (assoc label *labels->placeholders*)))
+ (second pair)))
+
+;;; The `circle-subst' function is cribbed from SBCL.
+
+(defvar *sharp-equal-circle-table* nil
+ "Objects already seen by `circle-subst'.")
+
+(defun circle-subst (old-new-alist tree)
+ "This function is kind of like NSUBLIS, but checks for
+circularities and substitutes in arrays and structures as well as
+lists. The first arg is an alist of the things to be replaced
+assoc'd with the things to replace them."
+ (cond ((not (typep tree
+ '(or cons (array t) structure-object standard-object)))
+ (let ((entry (find tree old-new-alist :key #'first)))
+ (if entry (second entry) tree)))
+ ((null (gethash tree *sharp-equal-circle-table*))
+ (setf (gethash tree *sharp-equal-circle-table*) t)
+ (cond ((typep tree '(or structure-object standard-object))
+ ;; I am time and again saved by the MOP as I code
+ ;; myself into a corner.
+ (let ((class (class-of tree)))
+ (dolist (slotd (clim-mop:class-slots class))
+ (when (clim-mop:slot-boundp-using-class class tree slotd)
+ (let* ((old (clim-mop:slot-value-using-class class tree slotd))
+ (new (circle-subst old-new-alist old)))
+ (unless (eq old new)
+ (setf (clim-mop:slot-value-using-class
+ class tree slotd)
+ new)))))))
+ ((arrayp tree)
+ (loop for i from 0 below (length tree) do
+ (let* ((old (aref tree i))
+ (new (circle-subst old-new-alist old)))
+ (unless (eq old new)
+ (setf (aref tree i) new)))))
+ (t
+ (let ((a (circle-subst old-new-alist (car tree)))
+ (d (circle-subst old-new-alist (cdr tree))))
+ (unless (eq a (car tree))
+ (rplaca tree a))
+ (unless (eq d (cdr tree))
+ (rplacd tree d)))))
+ tree)
+ (t tree)))
+
+(defun replace-placeholders (&rest values)
+ "Replace the placeholder symbols in `values' with the real
+objects as determined by `*label-placeholders->objects*' and
+return the modified `values' as multiple return values."
+ (values-list
+ (mapcar #'(lambda (value)
+ (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20)))
+ (circle-subst *label-placeholders->object* value)))
+ values)))
+
+(defvar *form-to-object-depth* 0
+ "This variable is used to keep track of how deeply nested calls
+to `form-to-object' are.")
+
(defgeneric form-to-object (syntax form &key no-error package read backquote-level case)
(:documentation "Return the Lisp object `form' would become if
read. An attempt will be made to construct objects from
@@ -2710,17 +2877,25 @@
will be signalled for incomplete forms.")
(:method :around ((syntax lisp-syntax) (form form) &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.
+ ;; in the correct package.
(flet ((act ()
- (let ((*package* (or package
- (package-at-mark
- syntax (start-offset form)))))
-
- (call-next-method))))
- (if no-error
- (handler-case (act)
- (form-conversion-error ()))
- (act))))
+ (handler-case
+ (multiple-value-call #'replace-placeholders (call-next-method))
+ (reader-invoked (c)
+ (if (> (offset (end-mark c)) (end-offset form))
+ (signal c)
+ (object c)))
+ (form-conversion-error (e)
+ (unless no-error
+ (error e))))))
+ (let ((*form-to-object-depth* (1+ *form-to-object-depth*))
+ (*package* (or package (package-at-mark
+ syntax (start-offset form)))))
+ (if (= *form-to-object-depth* 1)
+ (let ((*labels->placeholders* nil)
+ (*label-placeholders->object* nil))
+ (act))
+ (act)))))
(:method ((syntax lisp-syntax) (form t) &rest args
&key no-error &allow-other-keys)
(unless no-error
@@ -2738,9 +2913,20 @@
(defmethod form-to-object ((syntax lisp-syntax) (form list-form) &rest args
&key &allow-other-keys)
- (mapcan #'(lambda (child)
- (multiple-value-list (apply #'form-to-object syntax child args)))
- (remove-if-not #'formp (children form))))
+ (labels ((recurse (elements)
+ (unless (null elements)
+ (handler-case
+ (nconc (multiple-value-list
+ (apply #'form-to-object syntax (first elements) args))
+ (recurse (rest elements)))
+ (reader-invoked (c)
+ (let ((remaining-elements (remove (offset (end-mark c)) elements
+ :key #'start-offset :test #'>)))
+ (if (and (not (null (rest elements)))
+ (null remaining-elements))
+ (signal c)
+ (cons (object c) (recurse remaining-elements)))))))))
+ (recurse (remove-if-not #'formp (children form)))))
(defmethod form-to-object ((syntax lisp-syntax) (form complete-quote-form) &rest args
&key (backquote-level 0) &allow-other-keys)
@@ -2825,7 +3011,7 @@
(defmethod form-to-object ((syntax lisp-syntax) (form number-lexeme)
&key &allow-other-keys)
(let ((*read-base* (base syntax)))
- (values (read-from-string (form-string syntax form)))))
+ (invoke-reader syntax form)))
(defmethod form-to-object ((syntax lisp-syntax) (form simple-vector-form)
&key &allow-other-keys)
@@ -2837,7 +3023,7 @@
(defmethod form-to-object ((syntax lisp-syntax) (form complete-string-form)
&key &allow-other-keys)
- (values (read-from-string (form-string syntax form))))
+ (invoke-reader syntax form))
(defmethod form-to-object ((syntax lisp-syntax) (form function-form) &rest args)
(list 'cl:function (apply #'form-to-object syntax (second (children form)) args)))
@@ -2875,9 +3061,10 @@
(defmethod form-to-object ((syntax lisp-syntax) (form undefined-reader-macro-form)
&key read &allow-other-keys)
- ;; ???
+ ;; This is likely to malfunction for some really evil reader macros,
+ ;; in that case, you need to extend the parser to understand them.
(when read
- (read-from-string (form-string syntax form))))
+ (invoke-reader syntax form)))
(defmethod form-to-object ((syntax lisp-syntax) (form literal-object-form) &key &allow-other-keys)
(object-after (start-mark form)))
@@ -2910,6 +3097,14 @@
(when read
(values (eval (apply #'form-to-object syntax (first-form (children form)) args)))))
+(defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-equals-form)
+ &rest args)
+ (apply #'register-form-label syntax form args))
+
+(defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-sharpsign-lexeme)
+ &rest args)
+ (apply #'label-placeholder syntax form (extract-label syntax form) t args))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Arglist fetching.
