[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Mon Feb 18 10:45:26 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv4903/Drei
Modified Files:
lisp-syntax-swine.lisp
Log Message:
Added support for undefing command and undefiners.
n metacircular uninterpreter!
--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/16 22:06:09 1.17
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/18 10:45:26 1.18
@@ -956,6 +956,26 @@
`undefiner'. If it isn't, the results are undefined. `Syntax' is
the Lisp syntax object that has `definition-form'."))
+(defvar *undefiners* (make-hash-table)
+ "A hash table mapping operators to undefiners. The undefiners
+are instances of `undefiner'.")
+
+(defun get-undefiner (definition-type)
+ "Return the undefiner for `definition-type', which must be a
+symbol. Returns NIL if there is no undefiner of the given type."
+ (values (gethash definition-type *undefiners*)))
+
+(defun invalid-form-for-type (syntax form type-name)
+ "Signal a `form-conversion-error' describing the fact that
+`form' cannot define a `type-name'."
+ (form-conversion-error syntax form "Form cannot define a ~A." type-name))
+
+(defun invalid-form (undefiner syntax form)
+ "Signal a `form-conversion-error' describing the fact that
+`form' cannot define whatever kind of definition `undefiner'
+handles."
+ (invalid-form-for-type syntax form (undefiner-type undefiner)))
+
(defclass simple-undefiner (undefiner)
((%undefiner-type :reader undefiner-type
:initform (error "A description must be provided.")
@@ -972,7 +992,7 @@
:initarg :undefiner-function)))
(defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form form))
- (form-conversion-error syntax form "Form ~A cannot define a ~A." (undefiner-type undefiner)))
+ (invalid-form undefiner syntax form))
(defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form list-form))
(if (>= (length (form-children form)) 2)
@@ -984,15 +1004,6 @@
(definition-name undefiner syntax form)
form))
-(defvar *undefiners* (make-hash-table)
- "A hash table mapping operators to undefiners. The undefiners
-are instances of `undefiner'.")
-
-(defun get-undefiner (definition-type)
- "Return the undefiner for `definition-type', which must be a
-symbol. Returns NIL if there is no undefiner of the given type."
- (values (gethash definition-type *undefiners*)))
-
(defmacro define-simple-undefiner (definition-spec (syntax-sym name-sym form-sym) &body body)
"Define a way to undefine some definition. `Definition-spec' is
the operator (like `defun', `defclass', etc), and `syntax-sym',
@@ -1014,6 +1025,82 @@
(declare (ignorable ,syntax-sym ,name-sym ,form-sym))
, at body)))))
+(defclass generic-undefiner (undefiner)
+ ((%undefiner-type :reader undefiner-type
+ :initform (error "A description must be provided.")
+ :type string
+ :documentation "A textual, user-oriented name
+for the type of definition handled by this
+undefiner."
+ :initarg :undefiner-type)
+ (%name-function :reader name-function
+ :initform (error "A name retrieval function must be provided.")
+ :documentation "A function of three arguments:
+the syntax object and the form to retrieve a name from. Should
+return the name as a Lisp object (probably a symbol). Should
+signal a `form-conversion-error' if the form cannot define
+whatever type this undefiner handles."
+ :initarg :name-function)
+ (%undefiner-function :reader undefiner-function
+ :initform (error "An undefiner function must be provided.")
+ :documentation "A function of three
+arguments: the syntax object, the name of the definition to be
+undefined and the form to be undefined."
+ :initarg :undefiner-function)))
+
+(defmethod definition-name ((undefiner generic-undefiner) (syntax lisp-syntax) (form form))
+ (funcall (name-function undefiner) syntax form))
+
+(defmethod undefine ((undefiner generic-undefiner) (syntax lisp-syntax) (form form))
+ (funcall (undefiner-function undefiner) syntax
+ (definition-name undefiner syntax form)
+ form))
+
+(defmacro define-undefiner (definition-spec
+ ((name-syntax-sym name-form-sym) &body name-body)
+ ((undef-syntax-sym undef-name-sym undef-form-sym)
+ &body undefiner-body))
+ "Define a way to undefine definitions. `Definition-spec' is the
+operator (like `defun', `defclass', etc) and may optionally be a
+list, in which case the first element is the operator, and the
+second a user-oriented name for the kind of thing defined by the
+operator. `Name-body' and `Undefiner-body' will be evaluated to
+retrieve the name and perform the undefinition, respectively.
+
+`Name-syntax-sym' and `name-form-sym' will be bound to the Lisp
+syntax instance and the entire form of the definition during
+evaluation of `name-body'. Syntactical problems (such as an
+incomplete or invalid form) should be signalled by an
+invocation `(invalid)'
+
+`undef-syntax-sym', `undef-name-sym' and `undef-form-sym' will be
+bound to the Lisp syntax instance, the name of the definition to
+be undefined and the entire form of the definition when
+`undefiner-body' is evaluated. Syntactical problems (such as an
+incomplete or invalid form) should be signalled by an
+invocation `(invalid)'."
+ (check-type definition-spec (or list symbol))
+ (let* ((definition-type (unlisted definition-spec))
+ (undefiner-name (if (listp definition-spec)
+ (second definition-spec)
+ (string-downcase definition-type))))
+ (check-type definition-type symbol)
+ `(setf (gethash ',definition-type *undefiners*)
+ (make-instance 'generic-undefiner
+ :undefiner-type ,undefiner-name
+ :name-function #'(lambda (,name-syntax-sym ,name-form-sym)
+ (declare (ignorable ,name-syntax-sym ,name-form-sym))
+ (flet ((invalid ()
+ (invalid-form-for-type ,name-syntax-sym ,name-form-sym ,undefiner-name)))
+ (declare (ignorable #'invalid))
+ , at name-body))
+ :undefiner-function #'(lambda (,undef-syntax-sym ,undef-name-sym ,undef-form-sym)
+ (declare (ignorable ,undef-syntax-sym ,undef-name-sym ,undef-form-sym))
+ (flet ((invalid ()
+ (invalid-form-for-type ,undef-syntax-sym ,undef-form-sym ,undef-name-sym)))
+ (declare (ignorable #'invalid))
+ , at undefiner-body))))))
+
(define-simple-undefiner (defun "function") (syntax name form)
(fmakunbound name))
@@ -1065,3 +1152,50 @@
(define-simple-undefiner (defpackage "package") (syntax name form)
(delete-package name))
+
+(defun get-listed-name (syntax form)
+ "Retrieve the name of `form' under the assumption that the name
+is the second element of `form', and if this is a list, the first
+element of that list. The secondary value will be true if a name
+can be found, false otherwise."
+ (if (and (form-list-p form)
+ (>= (length (form-children form)) 2))
+ (let ((name-form (second (form-children form))))
+ (cond ((and (form-list-p name-form)
+ (form-children name-form))
+ (values (form-to-object syntax (first (form-children name-form))) t))
+ ((form-token-p name-form)
+ (values (form-to-object syntax name-form) t))
+ (t (values nil nil))))
+ (values nil nil)))
+
+;; Cannot recognize the common define-FOO-command macros.
+(define-undefiner (define-command "command")
+ ((syntax form)
+ (multiple-value-bind (name success) (get-listed-name syntax form)
+ (if success name (invalid))))
+ ((syntax name form)
+ ;; Pick out the command table from the define-command form. The
+ ;; command may also be in other command tables, but we can't find
+ ;; those.
+ (let ((name-form (listed (form-to-object syntax (second (form-children form))))))
+ (destructuring-bind (ignore &key command-table keystroke &allow-other-keys) name-form
+ (declare (ignore ignore))
+ (when command-table
+ (remove-command-from-command-table name command-table :errorp nil)
+ (remove-keystroke-from-command-table command-table keystroke :errorp nil))))
+ (fmakunbound name)))
+
+(define-undefiner (define-undefiner "undefiner")
+ ((syntax form)
+ (multiple-value-bind (name success) (get-listed-name syntax form)
+ (if success name (invalid))))
+ ((syntax name form)
+ (remhash name *undefiners*)))
+
+(define-undefiner (define-simple-undefiner "simple undefiner")
+ ((syntax form)
+ (multiple-value-bind (name success) (get-listed-name syntax form)
+ (if success name (invalid))))
+ ((syntax name form)
+ (remhash name *undefiners*)))
More information about the Mcclim-cvs
mailing list