Permalink
Browse files

multi-method update, utils added.

  • Loading branch information...
1 parent 530bb5a commit aabfc8862ba8741942002121fc0e10fab0ce05f4 @VincentToups committed Mar 8, 2011
View
@@ -30,6 +30,7 @@
((data :accessor string-of :initarg :string)
(ix :accessor index-of :initarg :index :initform 0)))
+
(defmethod input-empty? ((input <parser-input-string>))
(= (length (string-of input)) (index-of input)))
(defmethod input-empty-p ((input <parser-input-string>))
@@ -43,6 +44,23 @@
(string-of input)
:index (+ 1 (index-of input))))
+(defclass <parser-input-sequence> ()
+ ((data :accessor seq-of :initarg :seq)
+ (ix :accessor index-of :initarg :index :initform 0)))
+
+(defmethod input-empty? ((input <parser-input-sequence>))
+ (= (length (seq-of input)) (index-of input)))
+(defmethod input-empty-p ((input <parser-input-sequence>))
+ (= (length (seq-of input)) (index-of input)))
+(defmethod input-first ((input <parser-input-sequence>))
+ (elt (seq-of input) (index-of input)))
+(defmethod input-rest ((input <parser-input-sequence>))
+ (make-instance '<parser-input-sequence> :seq
+ (seq-of input)
+ :index (+ 1 (index-of input))))
+
+
+
(defclass <parser-input-buffer> ()
((buffer :accessor buffer-of :initarg :buffer)
(ix :accessor index-of :initarg :index :initform 1)))
@@ -74,6 +92,10 @@
(defun input->string (input)
(if input (input-as-string input) nil))
+(defmethod input-as-list ((input <parser-input-sequence>))
+ (elts (seq-of input)
+ (range (index-of input)
+ (length (seq-of input)))))
(defun buffer->parser-input (buffer-or-name)
(make-instance '<parser-input-buffer>
@@ -92,6 +114,10 @@
(make-instance '<parser-input-string>
:string str))
+(defun sequence->parser-input (seq)
+ (make-instance '<parser-input-sequence>
+ :seq (coerce seq 'vector)))
+
(defun parser-fail ()
(lambda (input) nil))
@@ -156,13 +182,14 @@
(defun ->in (x)
(cond
- ((bufferp (get-buffer x))
+ ((and (stringp x) (bufferp (get-buffer x)))
(buffer->parser-input x))
((stringp x)
(string->parser-input x))
+ ((sequencep x)
+ (sequence->parser-input x))
(t (error "Can't convert %s into a parser input." x))))
-
(lexical-let ((lowers (coerce "abcdefghijklmnopqrztuvwxyz" 'list))
(uppers (coerce "ABCDEFGHIJKLMNOPQRZTUVWXYZ" 'list)))
(defun upper-case-char? (x)
@@ -264,6 +291,9 @@
(lex-defun parser-maybe (parser)
(=or parser (parser-return nil)))
+(lex-defun =maybe (parser)
+ (=or parser (parser-return nil)))
+
(defun letters ()
(=or (=let* [x (letter)
@@ -348,6 +378,9 @@
(defun parse-string (parser string)
(car (car (funcall parser (->in string)))))
+(defun parse-sequence (parser sequence)
+ (car (car (funcall parser (->in sequence)))))
+
(defun parse-string-det (parser string)
(let* ((pr (funcall parser (->in string)))
(result (car (car pr)))
View
Binary file not shown.
View
@@ -6,6 +6,9 @@
(defvar *hierarchy-weak-table* (make-hash-table :test 'eql :weakness t) "Weak table for keeping track of hierarchies.")
+(defvar *multi-method-heirarchy* (alist>> :down nil
+ :up nil
+ :resolutions nil) "The default multimethod hierarchy used for isa? dispatch.")
(defun make-hierarchy ()
"Create a hierarchy for multi-method dispatch."
@@ -113,6 +116,15 @@
,@body))
',name))
+(defmacro* undefunmethod (name value)
+ "Undefine the method for the multimethod NAME and dispatch value VALUE."
+ (let ((table-name (mk-dispatch-table-name name)))
+ `(let ((*multi-method-heirarchy* ,(mk-dispatch-hierarchy-name name)))
+ (clear-dispatch-cache)
+ (setq ,table-name
+ (dissoc-equal ,table-name ,value)))))
+
+
(defmacro* defunmethod (name value arglist &body body)
"Define a method using DEFUN syntax for the dispatch value VALUE."
(let ((g (gensym))
@@ -129,7 +141,7 @@
"Indicate that the NAMEd multimethod should prefer PREF-VAL over NOT-PREF-VAL when dispatching ambiguous inputs."
(let ((subtbl (alist *preferred-dispatch-table* name)))
(alist! subtbl (vector pref-val not-pref-val) pref-val)
- (alist! subtbl (vector not-pref-val pref-val) prev-val)
+ (alist! subtbl (vector not-pref-val pref-val) pref-val)
(setf (alist *preferred-dispatch-table* name) subtbl)))
(defmacro prefer-method (name pref-val not-pref-val)
@@ -139,9 +151,7 @@
-(defvar *multi-method-heirarchy* (alist>> :down nil
- :up nil
- :resolutions nil) "The default multimethod hierarchy used for isa? dispatch.")
+
(defun clear-mm-heirarchy ()
"Clear the hierarchy in the dynamic scope. "
@@ -162,18 +172,35 @@
(setf (alist *multi-method-heirarchy* :up) (alist-add-to-set parents child parent)))
*multi-method-heirarchy*)
+(defun remove-parent-relation (child parent)
+ "Add a PARENT CHILD relationship to the hierarchy in the dynamic scope."
+ (let ((parents (alist *multi-method-heirarchy* :up)))
+ (setf (alist *multi-method-heirarchy* :up) (alist-remove-from-set parents child parent)))
+ *multi-method-heirarchy*)
+
(defun add-child-relation (parent child)
"Add a CHILD PARENT relationship to the hierarchy in the dynamic scope."
(let ((children (alist *multi-method-heirarchy* :down)))
(setf (alist *multi-method-heirarchy* :down) (alist-add-to-set children parent child)))
*multi-method-heirarchy*)
+(defun remove-child-relation (parent child)
+ "Removes a CHILD PARENT relationship to the hierarchy in the dynamic scope."
+ (let ((children (alist *multi-method-heirarchy* :down)))
+ (setf (alist *multi-method-heirarchy* :down) (alist-remove-from-set children parent child)))
+ *multi-method-heirarchy*)
+
(defun derive2 (parent child)
"Declare a PARENT-CHILD relationship in the dynamically scoped hierarchy."
(clear-dispatch-cache)
(add-child-relation parent child)
(add-parent-relation child parent))
+(defun underive2 (parent child)
+ (clear-dispatch-cache)
+ (remove-child-relation parent child)
+ (remove-parent-relation child parent))
+
(defun derive (&rest args)
"derive H PARENT CHILD establishes a parent-child relationship in H, a heirarchy.
derive PARENT CHILD uses the default hierarchy."
@@ -183,6 +210,16 @@
(apply #'derive2 (cdr args))))
(t "Derive takes 2 or 3 arguments. More or less were given.")))
+(defun underive (&rest args)
+ "derive H PARENT CHILD establishes a parent-child relationship in H, a heirarchy.
+ derive PARENT CHILD uses the default hierarchy."
+ (case (length args)
+ ((2) (apply #'derive2 args))
+ ((3) (let ((*multi-method-heirarchy* (car args)))
+ (apply #'derive2 (cdr args))))
+ (t "Derive takes 2 or 3 arguments. More or less were given.")))
+
+
(defun* derives-from (child parent &optional (h *multi-method-heirarchy*))
(let ((*multi-method-heirarchy* h))
(derive2 parent child)))
@@ -236,7 +273,7 @@
"Get the multimethod of kind NAME that is the nearest match for the DISPATCH-VALUE."
(let* ((method-table-name (mk-dispatch-table-name name))
(method-table (eval method-table-name)))
- (isa-dispatch dispatch-value method-table (make-resolve-by-table name))))
+ (isa-dispatch dispatch-value method-table (make-resolve-by-table method-table name))))
(defun get-method-funcall (name dispatch-value &rest args)
"Get the method associated with NAME and DISPATCH-VALUE and call it on ARGS."
@@ -299,8 +336,6 @@
0))
list-of))))
-
-
(defun isa? (o1 o2)
"ISA? test for equality using the default hierarchy. Child ISA? Parent but not vice versa. Isa? returns a number representing the distance to the nearest ancestor that matches. For vectors of objects, these distances are summed. If nil, o1 is not an o2."
(case (count-equilength-vectors (list o1 o2))
@@ -335,19 +370,19 @@
(alist! *multi-method-heirarchy* ::::dispatch-cache cache)
cache)))
-(defun clear-dispatch-cache-raw ()
- "Clear the dispatch cache for the hierarchy in the dynamic scope."
- (alist! *multi-method-heirarchy* ::::dispatch-cache nil)
- t)
-
-(defun clear-dispatch-cache (&rest args)
- "Retrieve the cache of dispatches for the currently scoped hierarchy, or for one passed in."
- (case (length args)
- ((0) (clear-dispatch-cache-raw))
- ((1) (let ((*multi-method-heirarchy* (car args)))
- (clear-dispatch-cache-raw)))
- (otherwise
- (error "clear-dispatch-cache: Takes either 0 or 1 arguments."))))
+;; (defun clear-dispatch-cache-raw ()
+;; "Clear the dispatch cache for the hierarchy in the dynamic scope."
+;; (alist! *multi-method-heirarchy* ::::dispatch-cache nil)
+;; t)
+
+;; (defun clear-dispatch-cache (&rest args)
+;; "Retrieve the cache of dispatches for the currently scoped hierarchy, or for one passed in."
+;; (case (length args)
+;; ((0) (clear-dispatch-cache-raw))
+;; ((1) (let ((*multi-method-heirarchy* (car args)))
+;; (clear-dispatch-cache-raw)))
+;; (otherwise
+;; (error "clear-dispatch-cache: Takes either 0 or 1 arguments."))))
(defun get-dispatch-cache (&rest args)
"Retrieve the cache of dispatches for the currently scoped hierarchy, or for one passed in."
View
Binary file not shown.
View
@@ -160,9 +160,13 @@ Conclusion
I think multimethods are probably useful and well suited to emacs
lisp. They are lightweight, powerful and coexist well with the emacs
-ecosystem. I'm going to add dispatch lookup caching eventually. This
-should improve performance on method dispatch even for very deep or
-convoluted hierarchies. This is possible because any call to `derive`
-or `prefer-method` is sufficient notice to clear the cache of dispatch
-values. After a brief period where dispatches are recached, this
-should make method dispatch a constant time operation.
+ecosystem.
+
+Notes/Updates:
+--------------
+
+I added method dispatch caching, so method look up should be constant
+time now, after dispatch has been calculated a few times. I also
+added a bunch of forms to underive and undefmethod so that you can
+easily develop systems without nuking your whole hierarchy or method
+system.
@@ -69,6 +69,7 @@ In this version of the function, the rest form is enclosed in a list, for subseq
nil)))
+
(dont-do
;example
@@ -0,0 +1,122 @@
+(require 'utils)
+(require 'monad-parse)
+(require 'functional)
+(provide 'simplified-lambda-list-parser)
+
+(defun not-lambda-list-sentinal (symbol)
+ "Returns true for anything that isn't in '(&rest &optional &key)."
+ (and (not (eq '&rest symbol))
+ (not (eq '&key symbol))
+ (not (eq '&optional symbol))))
+(defun lambda-list-sentinal (symbol)
+ "Returns true for anything that is in '(&rest &optional &key)."
+ (or (eq '&rest symbol)
+ (eq '&optional symbol)
+ (eq '&key symbol)))
+(defun lambda-list-tail-sentinal (symbol)
+ "Returns true for either '&rest or '&key, which are mutually exclusive in a lambda list."
+ (or (eq '&rest symbol)
+ (eq '&key symbol)))
+
+
+(defun =not-lambda-list-sentinal ()
+ "Return a parser which parses a single item which is not a lambda list sentinal."
+ (=satisfies #'not-lambda-list-sentinal))
+(defun =lambda-list-tail-sentinal ()
+ "Return a parser which parses a single item which is a lambda list sentinal."
+ (=satisfies #'lambda-list-tail-sentinal))
+
+(defun =regular-args ()
+ "Return a parser which gets the regular argument symbols of a lambda list,
+that is, the symbols up to the first lambda list sentinal."
+ (=let* [_ (zero-or-more (=not-lambda-list-sentinal))]
+ _))
+
+(defun symbol-or-proper-pair (o)
+ "Returns true for either a naked symbol, a list of only one symbol, or a list
+with two elements, a symbol and a form, which is an arbitrary lisp expression."
+ (or (not-lambda-list-sentinal o)
+ (and (listp o)
+ (symbolp (car o))
+ (<= (length o) 2))))
+
+(defun =maybe-optional-arg ()
+ "Returns a parser which parses a single argument representing a symbol and its
+default value, or a symbol. That is, x, (x) or (x 10), as examples."
+ (=satisfies #'symbol-or-proper-pair))
+
+(defun =optional-args ()
+ "Returns a parser which parses optional arguments from a lambda list. The
+parses returns a list of these args."
+ (=let* [sentinal (=satisfies (par #'eq '&optional))
+ args (zero-or-more (=maybe-optional-arg))]
+ args))
+
+(defun =key-args ()
+ "Returns a parser which parses the arguments of the &key part of a lambda list,
+and returns the list of argument forms."
+ (=let* [sentinal (=satisfies (par #'eq '&key))
+ args (zero-or-more (=maybe-optional-arg))]
+ args))
+
+(defun =rest-arg ()
+ "Returns a parser which parses the arguments of the &rest part of a lambda list,
+and returns the symbol which will contain the tail of the passed in args."
+ (=let* [sentinal (=satisfies (par #'eq '&rest))
+ arg (=not-lambda-list-sentinal)]
+ (if arg arg (error "Lambda list parser error - &rest needs a symbol to bind the rest to."))))
+
+(defun =lambda-list-tail ()
+ "Returns a parser which parses the tail of a lambda list, either an &key for, or an &rest form,
+but not both. The context using this parser should check to see that this form exhausts the lambda list,
+because not doing so indicates an error."
+ (=let* [sentinal (=satisfies #'lambda-list-tail-sentinal)
+ part/s
+ (cond ((eq sentinal '&rest)
+ (=satisfies #'not-lambda-list-sentinal))
+ ((eq sentinal '&key)
+ (zero-or-more (=maybe-optional-arg))))]
+ (list (case sentinal
+ (&rest :rest)
+ ('&key :key))
+ part/s)))
+
+(defun =lambda-list ()
+ "Returns a parser which parses a lambda list into an alist with :normal,
+:optional, :key or :rest entries, containing the appropriate forms."
+ (=let* [normals (zero-or-more (=regular-args))
+ optionals (=maybe (=optional-args))
+ tail (=maybe (=lambda-list-tail))]
+ (let ((table (alist>> :optional optionals :normal normals)))
+ (if tail
+ (cons tail table)
+ table))))
+
+(defun simple-parse-lambda-list (lambda-list)
+ "Parse the lambda list in LAMBDA-LIST and return a table of the lambda list information where
+:normal holds the normal argument symbols
+:optional holds the optional arguments, as either symbol or symbol/form pairs
+:rest holds the symbol to bind the tail of the arguments to
+and :key holds the key symbols or symbol/val pairs.
+
+ Pairs are proper lists, rather than PAIRS in the strict sense. Throws errors if the lambda
+list is not parsable."
+ (let* ((result-and-state (funcall (=lambda-list) (->in lambda-list)))
+ (result (car (car result-and-state)))
+ (remainder (input-as-list (cdr (car result-and-state)))))
+ (if remainder (error "Can't figure out how to parse the lambda-list tail %S" remainder)
+ result)))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Binary file not shown.
Oops, something went wrong.

0 comments on commit aabfc88

Please sign in to comment.