[Bese-devel] method combination
Larry D'Anna
smoof-ra at elder-gods.org
Wed Aug 10 04:07:38 UTC 2005
here's standard method combination for the interpreter. Also adds &rest support.
--larry
-------------- next part --------------
(in-package :arnesi)
(fmakunbound 'supercool)
(defgeneric supercool (x)
(:method-combination cc-standard))
(defmethod/cc supercool ((x integer))
(if (next-method-p)
(call-next-method x))
(print (+ 2000 x)))
(defmethod/cc supercool :before (x)
(print 'before))
(defmethod/cc supercool :after (x)
(print 'after))
(with-call/cc
(supercool 7))
;BEFORE
;2007
;AFTER
(defmethod/cc supercool (x)
(print (+ 1000 x)))
(with-call/cc
(supercool 7))
;BEFORE
;1007
;2007
;AFTER
(defmethod/cc supercool :around (x)
(print 'pre)
(call-next-method x)
(print 'post))
(defmethod/cc supercool :around ((x integer))
(print 'ipre)
(call-next-method x)
(print 'ipost))
(with-call/cc
(supercool 7))
;IPRE
;PRE
;BEFORE
;1007
;2007
;AFTER
;POST
;IPOST
(defparameter *c* nil)
(defmethod/cc supercool :before (x)
(print 'before)
(let/cc k (setq *c* k)))
(with-call/cc
(supercool 7))
;IPRE
;PRE
;BEFORE
(kall *c*)
;1007
;2007
;AFTER
;POST
;IPOST
-------------- next part --------------
New patches:
[ method combination
smoof-ra at elder-gods.org**20050810035825] {
hunk ./src/cc-interpreter.lisp 170
+
+ ((and (eql 'call-next-method (operator func))
+ (second (multiple-value-list (lookup env :next-method t))))
+ (aif (lookup env :next-method t)
+ (evaluate-arguments-then-apply
+ (lambda (arguments)
+ (apply-lambda/cc it arguments k))
+ (arguments func) '() env)
+ (error "no next method")))
+
+ ((and (eql 'next-method-p (operator func))
+ (second (multiple-value-list (lookup env :next-method t))))
+ (kontinue k (lookup env :next-method t)))
hunk ./src/cc-interpreter.lisp 264
- (optional-function-argument-form
+ (rest-function-argument-form
+ (setf env (register env :let (name parameter) remaining-arguments))
+ (setf remaining-arguments nil))
+ (optional-function-argument-form
hunk ./src/cc-interpreter.lisp 591
-(defmacro defmethod/cc (name arguments &body body)
- `(progn
- (setf (get ',name 'defmethod/cc) t)
- (defmethod ,name ,arguments
- (declare (ignorable ,@(extract-argument-names arguments :allow-specializers t)))
- (make-instance 'closure/cc
- :code (walk-form '(lambda ,(extract-argument-names arguments :allow-specializers t
- :keep-lambda-keywords t)
- , at body)
- nil nil)
- :env nil))))
+; for emacs: (setf (get 'defmethod/cc 'common-lisp-indent-function) 'lisp-indent-defmethod)
+
+(defmacro defmethod/cc (name &rest args)
+ (let ((qlist (if (symbolp (car args))
+ (prog1
+ (list (car args))
+ (setf args (cdr args))))))
+ (destructuring-bind (arguments &body body) args
+ `(progn
+ (setf (get ',name 'defmethod/cc) t)
+ (defmethod ,name , at qlist ,arguments
+ (declare (ignorable ,@(extract-argument-names arguments :allow-specializers t)))
+ (make-instance 'closure/cc
+ :code (walk-form '(lambda ,(extract-argument-names arguments :allow-specializers t
+ :keep-lambda-keywords t)
+ , at body)
+ nil nil)
+ :env nil))))))
+
hunk ./src/cc-interpreter.lisp 614
+
+
+(defun closure-with-nextmethod (closure next)
+ (make-instance 'closure/cc
+ :code (code closure)
+ :env (register (env closure) :next-method t next)))
+
+(defun closure-with-befores (closure befores)
+ (make-instance 'closure/cc
+ :code (walk-form `(lambda (&rest args)
+ ,@(loop
+ for before in befores
+ collect `(apply ,before args))
+ (apply ,closure args)))
+ :env nil))
+
+(defun closure-with-afters (closure afters)
+ (make-instance 'closure/cc
+ :code (walk-form `(lambda (&rest args)
+ (prog1
+ (apply ,closure args)
+ ,@(loop
+ for after in afters
+ collect `(apply ,after args)))))
+ :env nil))
+
+(define-method-combination cc-standard
+ (&key (around-order :most-specific-first)
+ (before-order :most-specific-first)
+ (primary-order :most-specific-first)
+ (after-order :most-specific-last))
+ ((around (:around))
+ (before (:before))
+ (primary () :required t)
+ (after (:after)))
+
+ (labels ((effective-order (methods order)
+ (ecase order
+ (:most-specific-first methods)
+ (:most-specific-last (reverse methods))))
+ (primary-wrap (methods &optional nextmethod)
+ (case (length methods)
+ (1 `(closure-with-nextmethod
+ (call-method ,(first methods))
+ ,nextmethod))
+ (t `(closure-with-nextmethod
+ (call-method ,(first methods))
+ ,(primary-wrap (cdr methods) nextmethod)))))
+ (call-methods (methods)
+ `(list ,@(loop
+ for m in methods
+ collect `(call-method ,m)))))
+ (let* (;; reorder the methods based on the -order arguments
+ (around (effective-order around around-order))
+ (before (effective-order before before-order))
+ (primary (effective-order primary primary-order))
+ (after (effective-order after after-order))
+ (form (primary-wrap primary)))
+ (when after
+ (setf form `(closure-with-afters ,form ,(call-methods after))))
+ (when before
+ (setf form `(closure-with-befores ,form ,(call-methods before))))
+ (when around
+ (setf form (primary-wrap around form)))
+ form)))
+
+
+
}
Context:
[Added copyright notice to cc-interpreter.lisp
Marco Baringer <mb at bese.it>**20050809151738]
[Remove occurences of 'cps' in the api. We don't actually cps transforme anymore so this is misleading.
Marco Baringer <mb at bese.it>**20050809125933]
[Remove 'cps' from test suite, replace it with 'call/cc'
Marco Baringer <mb at bese.it>**20050809104818]
[Rename cps.lisp to cc-interpreter.lisp
Marco Baringer <mb at bese.it>**20050809104737]
[Fix typo in fold-strings' docstring
Marco Baringer <mb at bese.it>**20050809083006]
[Trivial change to the name of the gensym generated by DOLIST*
Marco Baringer <mb at bese.it>**20050809061102]
[Fix lexical-variables and lexical-functions on clisp
Marco Baringer <mb at bese.it>**20050807223244]
[Use FDEFINITION instead of SYMBOL-FUNCTION to get a function from a function name.
Marco Baringer <mb at bese.it>**20050807222932]
[Make sure we only pass symbols to functions like GET and MACRO-FUNCTION
Marco Baringer <mb at bese.it>**20050807222905]
[Implement lexical-functions for CLISP
Marco Baringer <mb at bese.it>**20050807204738]
[Implement lexical-variables and lexical-functions for NIL environments
Marco Baringer <mb at bese.it>**20050807204711]
[Remove arnesi.el from ssytem def
Marco Baringer <mb at bese.it>**20050807204654]
[Fix evaluation of #'(foo bar) in cps interpreter
Marco Baringer <mb at bese.it>**20050806182653]
[Delete arnesi.el. SLIME is perfectly able to figure out the indententation by itself.
Marco Baringer <mb at bese.it>**20050807075500]
[aparently global variables can be found in sbcl lexical environments
smoof-ra at elder-gods.org**20050804164859]
[Implement environment-p and lexical-variables for CLISP
Marco Baringer <mb at bese.it>**20050804165821]
[Make the lexenv stuff use generic-functions and methods
Marco Baringer <mb at bese.it>**20050804161857]
[Fixup lexical-variables and lexical-functions for OpenMCL
Marco Baringer <mb at bese.it>**20050804152727
This patch causes lexical-variables to no longer return ignored
variables and symbol-macrolets. We've also implemented
lexical-functions (though we do some hackery to convert functions
names to something "normal" (ie SETF::|FOO::BAR| ==> (SETF FOO::BAR))
]
[Typo in lexical-variables for sbcl (we were accessing lexenv-funs instead of lexenv-vars)
Marco Baringer <mb at bese.it>**20050804152051]
[Change lexical-variables for sbcl so that it doesn't return ignored variables
Marco Baringer <mb at bese.it>**20050804150841]
[Fix lexical-variables for cmucl to not return ignored variables
Marco Baringer <mb at bese.it>**20050804150256]
[Typo in previous patch
Marco Baringer <mb at bese.it>**20050804150242]
[Implement lexical-functions for cmucl
Marco Baringer <mb at bese.it>**20050804143350]
[recognise flets from the lexical environment (on sbcl)
smoof-ra at elder-gods.org**20050803222732]
[Rewrite multiple-value-setf so that my simple mind can understand it.
Marco Baringer <mb at bese.it>**20050803104652]
[Added cps evaluation of THE forms
Marco Baringer <mb at bese.it>**20050803092059]
[minor comment fixup
Marco Baringer <mb at bese.it>**20050803085322]
[Moved defclass progv-form to keep the walker classes defined in alphabetical order
Marco Baringer <mb at bese.it>**20050803085254]
[Added walker class for THE forms
Marco Baringer <mb at bese.it>**20050803085210]
[allow new special forms to be added to the walker by shadowing *walker-handlers*
smoof-ra at elder-gods.org**20050802165355]
[Minor spacing fixs to the previous patch
Marco Baringer <mb at bese.it>**20050802152421]
[progv
smoof-ra at elder-gods.org**20050802150342]
[labels can have declarations inside the body
smoof-ra at elder-gods.org**20050801193433]
[declares needs to be copied in the labels handler just like the other lambda-function-form slots
smoof-ra at elder-gods.org**20050801193107]
[oops i forgot to actually make the declaration-form instances
smoof-ra at elder-gods.org**20050801185641]
[initial support for remembering declarations
smoof-ra at elder-gods.org**20050801184329
this patch adds a mixin called implicit-progn-with-declare-mixin and
uses it instead of implicit-progn-mixin in all the places that allow declares.
It has slot which should contain a list of the declares at the top of the
implicit-progn. This patch doesn't do anything clever with the declares,
it just creates declaration-form objects and points their source slots
at the original declares, however it would be easy to modify parse-declaration
to generate more usefull declaration objects.
]
[Call the property :FEATURES, not FEATURES
Marco Baringer <mb at bese.it>**20050729103229]
[Rename asdf property version to features, add "cps-interpreter"
Marco Baringer <mb at bese.it>**20050728120238]
[dont need to register allow-other-keys because its not a binding
smoof-ra at elder-gods.org**20050727153603]
[fixed type name mismatch for allow-other-keys-function-arguement-form
smoof-ra at elder-gods.org**20050727152456]
[defmethod arguments should be ignorable, not ignore (openmcl warns whenever you ignore a specialized argument)
Marco Baringer <mb at bese.it>**20050726090308]
[Typo in extract-argument-names
Marco Baringer <mb at bese.it>**20050726090256]
[Fix generation of defmethod froms from defmethod/cc; added tests
Marco Baringer <mb at bese.it>**20050726085226]
[Fix handling of optional arguments in apply-cps-lambda
Marco Baringer <mb at bese.it>**20050726085155]
[More tests
Marco Baringer <mb at bese.it>**20050723133158]
[Fix a bug in the handling of the case when LOOKUP finds a value for a name but the value is NIL
Marco Baringer <mb at bese.it>**20050723133106]
[Export the symbol KALL
Marco Baringer <mb at bese.it>**20050723133052]
[Change the test for constant-form'ness in walk.lisp
Marco Baringer <mb at bese.it>**20050723113019]
[Extend the walker to handle #'(setf foo) function names
Marco Baringer <mb at bese.it>**20050723104431]
[Fix bug in the lambda generated for method forms
Marco Baringer <mb at bese.it>**20050720144450]
[Added ignore declarations to defun/cc and defmethod/cc to make the compiler happy
Marco Baringer <mb at bese.it>**20050720110112]
[Temporarily comment out the log tests
Marco Baringer <mb at bese.it>**20050720092312]
[Rename (optional|keyword|rest)-argument-form classes to include the -form suffix
Marco Baringer <mb at bese.it>**20050720092124]
[Allow defun/cc defined functions te be called outside of a with-call/cc
Marco Baringer <mb at bese.it>**20050720091826]
[Added support for &optional arguments in cps closures
Marco Baringer <mb at bese.it>**20050720091658]
[Added defgeneric/cc
Marco Baringer <mb at bese.it>**20050719153441]
[Move the error checking code for lambda arguments into apply, not lambda (in cps interpreter)
Marco Baringer <mb at bese.it>**20050719153121]
[More cps tests
Marco Baringer <mb at bese.it>**20050719152327]
[Fix openmcl's definition of lexical-variables to deal with ccl::definition-environment
Marco Baringer <mb at bese.it>**20050719152230]
[Added support to the cps interpreter forl communicating with lexical variables
Marco Baringer <mb at bese.it>**20050707094608]
[walk.lisp depends on lexenv.lisp
Marco Baringer <mb at bese.it>**20050707093140]
[added support for walking local varibales in the lexical environment
Marco Baringer <mb at bese.it>**20050707093027
this applies to all those variables defined the envorinment object
grabbed via an &environment macro argument.
]
[mistyped #+openmcl in lexenv.lisp
Marco Baringer <mb at bese.it>**20050707092959]
[added src/lexenv.lisp to arnesi.asd
Marco Baringer <mb at bese.it>**20050707091127]
[Rename src/environment.lisp
Marco Baringer <mb at bese.it>**20050707091114]
[Initial version of environment.lisp
Marco Baringer <mb at bese.it>**20050707091019]
[Minor docstring fixup for with-call/cc
Marco Baringer <mb at bese.it>**20050707090619]
[Big patch including all the cps interpreter stuff upto now
Marco Baringer <mb at bese.it>**20050707083739]
[Fix bug in handling of defclass-struct's :predicate option
Marco Baringer <mb at bese.it>**20050706105324]
[Initial Import
Marco Baringer <mb at bese.it>**20050706101657
This import moves arnesi from arch to darcs. Nothing has actually changed since
bese-2004 at common-lisp.net/arnesi--dev--1.4--patch-14
]
[added arch stuff to boring file
Marco Baringer <mb at bese.it>**20050706101630]
[Setup boring file
Marco Baringer <mb at bese.it>**20050706100535]
Patch bundle hash:
1047890ba1af393a7dd7bc77565211c5d3a5ff11
More information about the bese-devel
mailing list