--- /dev/null
+;;;; lambda-calculus.lisp --- Untyped lambda calculus based on pattern specializers.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.DE>
+
+;;;; Partially based on idea from
+;;;;
+;;;; [1] Benjamin C. Pierce (2002): Types and Programming languages
+
+(cl:defpackage #:pattern-specializer.examples.lambda-calculus
+ (:use
+ #:cl
+ #:pattern-specializer))
+
+(cl:in-package #:pattern-specializer.examples.lambda-calculus)
+
+;;; Syntax
+
+(defstruct term)
+
+(defstruct (value (:include term) (:constructor make-value (value)))
+ (value nil)) ; TODO val?
+
+(defstruct (var (:include term) (:constructor make-var (name)))
+ (name nil :type symbol))
+
+(defstruct (abst (:include value) (:constructor make-abst (var body)))
+ (var nil :type var)
+ (body nil :type term))
+
+(defstruct (app (:include term) (:constructor make-app (func arg)))
+ (func nil :type term)
+ (arg nil :type term))
+
+;;; Parse
+
+(defgeneric parse (from)
+ (:generic-function-class pattern-generic-function))
+
+(defmethod parse ((form (pattern (optima:guard value (integerp value))))) ; TODO just (form integer)
+ (make-value value))
+
+(defmethod parse ((form (pattern (optima:guard name (symbolp name))))) ; TODO just (form symbol)
+ (make-var form))
+
+(defmethod parse ((form (pattern (list 'λ (optima:guard name (symbolp name)) body))))
+ (make-abst (parse name) (parse body)))
+
+(defmethod parse ((form (pattern (list func arg))))
+ (make-app (parse func) (parse arg)))
+
+;;; Substitution
+
+(defgeneric substitute1 (term var val))
+
+(defmethod substitute1 ((term value) (var var) (val value))
+ term)
+
+;; [1 Page 69]
+(defmethod substitute1 ((term var) (var var) (val value))
+ (if (equalp term var) val term))
+
+;; [1 Page 69]
+(defmethod substitute1 ((term abst) (var var) (val value))
+ ;; TODO capture
+ (make-abst (abst-var term) (substitute1 (abst-body term) var val)))
+
+;; [1 Page 69]
+(defmethod substitute1 ((term app) (var var) (val value))
+ (make-app (substitute1 (app-func term) var val)
+ (substitute1 (app-arg term) var val)))
+
+;;; Evaluation
+
+(defgeneric eval1 (term)
+ (:generic-function-class pattern-generic-function))
+
+(defmethod eval1 ((term (pattern (value)))) ; TODO does not need pattern
+ term)
+
+;; Reduce function to value
+;;
+;; t_1 -> t_1'
+;; ---------------------
+;; t_1 t_2 -> t_1' t_2
+;;
+;; [1 Page 72; Figure 5.3]
+(defmethod eval1 ((term (pattern (app func arg))))
+ (eval1 (make-app (eval1 func) arg)))
+
+;; Reduce argument to value
+;;
+;; t_2 -> t_2'
+;; ---------------------
+;; v_1 t_2 -> v_1 t_2'
+;;
+;; [1 Page 72; Figure 5.3]
+(defmethod eval1 ((term (pattern (app (func (and func (value))) arg))))
+ (eval1 (make-app func (eval1 arg))))
+
+;; Application
+;;
+;; (λx.t_12) v_2 -> [x -> v_2] t_12
+;;
+;; [1 Page 72; Figure 5.3]
+(defmethod eval1 ((term (pattern (app (func (abst var body)) (arg (and arg (value)))))))
+ (let ((arg-value (eval1 arg)))
+ (eval1 (substitute1 body var arg-value))))
+
+;;; Test
+
+(eval1 (make-value 1))
+
+(eval1 (make-abst (make-var 'x) (make-value 1)))
+
+(eval1 (make-app (make-abst (make-var 'x) (make-var 'x)) (make-value 1)))
+;; => S#(VALUE)
+
+(eval1 (parse '(((λ z (λ y z)) 5) 6)))
--- /dev/null
+;;;; test.lisp ---
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:cl-user)
+
+(defgeneric test-match/1 (thing &key &allow-other-keys)
+ (:generic-function-class pattern-specializer:pattern-generic-function))
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons n "bla"))))
+ (list (list :cons-n-string-bla n)
+ (when (next-method-p)
+ (call-next-method))))
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons n "bli"))))
+ (list (list :cons-n-string-bli n)
+ (when (next-method-p)
+ (call-next-method))))
+
+(defmethod test-match/1 :around ((thing (pattern-specializer:pattern (cons 1 "bli"))))
+ (list :around-cons-1-string-bli
+ (when (next-method-p)
+ (call-next-method))))
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons 1 "bli"))))
+ :cons-1-string-bli)
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons n m))))
+ (list :cons-n-m n m))
+
+(test-match/1 (cons 5 "bla"))
+(test-match/1 (cons 1 "bli"))
+(test-match/1 (cons 1 "blu"))
+
+(defgeneric test-match/2 (thing1 thing2 &key foo)
+ (:generic-function-class pattern-specializer:pattern-generic-function))
+
+(defmethod test-match/2 ((thing1 (pattern-specializer:pattern (cons 1 "bla")))
+ (thing2 (pattern-specializer:pattern (cons 2 "bla")))
+ &key foo)
+ :cons-1-string-bla-cons-2-string-bla)
+
+(test-match/2 (cons 1 "bla") (cons 2 "bla"))
+(test-match/2 (cons 1 "bli") (cons 2 "bla"))
+(test-match/2 (cons 1 "blu") (cons 2 "bla"))
+
+
+
+(defgeneric test-match/3 (thing1 thing2 thing3
+ &rest bla)
+ (:generic-function-class pattern-specializer:pattern-generic-function))
+
+(defmethod test-match/3 ((thing1 (pattern-specializer:pattern (cons 1 my-var)))
+ (thing2 t)
+ (thing3 (pattern-specializer:pattern (cons 3 "bla")))
+ &rest bla)
+ (list thing1 thing2 :cons-3-string-bla my-var bla))
+
+(test-match/3 (cons 1 "bla") :bar (cons 3 "bla"))
+(test-match/3 (cons 1 "blu") :bar (cons 3 "bla"))
+(test-match/3 (cons 1 "bli") (cons 2 "bla"))
--- /dev/null
+;;;; language-extension.pattern-specializer.asd --- System definition for the language-extension.pattern-specializer system.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:defpackage #:language-extension.pattern-specializer-sytem
+ (:use
+ #:cl
+ #:asdf))
+
+(cl:in-package #:language-extension.pattern-specializer-sytem)
+
+(defsystem :language-extension.pattern-specializer
+ :author "Jan Moringen <jmoringe@techfak.uni-bielefeld.de>"
+ :license "LLGPLv3; see COPYING file for details."
+ :description "Use optima patterns as specializers in CLOS methods - SBCL ONLY"
+ :depends-on (;; (:feature :sbcl) this works differently than one might think; it's more like (:if-features :sbcl :foo :bar)
+
+ :alexandria
+ :optima)
+ :components ((:module "src"
+ :serial t
+ :components ((:file "pcl-patch"
+ :if-feature :sbcl)
+ (:file "package")
+ (:file "optima-extensions")
+ (:file "pattern-specializer")))))
--- /dev/null
+;;;; optima-extensions.lisp --- Necessary extensions of the optima library.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:pattern-specializer)
+
+(defgeneric pattern-more-specific-p (pattern1 pattern2)
+ (:documentation
+ "Return true if PATTERN1 is strictly more specific than
+ PATTERN2.
+
+ General principles:
+
+ * Variable patterns are less specific than all other patterns
+
+ * For most complex patterns, subpatterns are compared
+ lexicographically. Exceptions:
+
+ * For `class-pattern' s, subclass relations have higher
+ precedence. The above rule applies only when the classes are
+ identical.
+
+ * `and-pattern's are comparable to all patterns by checking
+ whether some of their subpatterns are more specific than the
+ pattern in question.
+
+ * `or-pattern's are similar."))
+
+(defmethod pattern-more-specific-p :around ((pattern1 optima::pattern)
+ (pattern2 optima::pattern))
+ (unless (eq pattern1 pattern2)
+ (call-next-method)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima::pattern))
+ nil)
+
+;; `variable-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima::variable-pattern))
+ t)
+
+(defmethod pattern-more-specific-p ((pattern1 optima::variable-pattern)
+ (pattern2 optima::variable-pattern))
+ nil)
+
+;; `and-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::and-pattern)
+ (pattern2 optima::pattern))
+ (some (lambda (subpattern)
+ (pattern-more-specific-p subpattern pattern2))
+ (optima::complex-pattern-subpatterns pattern1)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima::and-pattern))
+ (some (lambda (subpattern)
+ (pattern-more-specific-p pattern1 subpattern))
+ (optima::complex-pattern-subpatterns pattern2)))
+
+;; `or-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::or-pattern)
+ (pattern2 optima::pattern))
+ (every (lambda (subpattern)
+ (pattern-more-specific-p subpattern pattern2))
+ (optima::complex-pattern-subpatterns pattern1)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima::or-pattern))
+ (every (lambda (subpattern)
+ (pattern-more-specific-p pattern1 subpattern))
+ (optima::complex-pattern-subpatterns pattern2)))
+
+;; `cons-pattern'
+
+; TODO do this in a generic way via optima::complex-pattern-subpatterns
+(defmethod pattern-more-specific-p ((pattern1 optima::cons-pattern)
+ (pattern2 optima::cons-pattern))
+ (let ((car1 (optima::cons-pattern-car-pattern pattern1))
+ (cdr1 (optima::cons-pattern-cdr-pattern pattern1))
+ (car2 (optima::cons-pattern-car-pattern pattern2))
+ (cdr2 (optima::cons-pattern-cdr-pattern pattern2)))
+ (or (pattern-more-specific-p car1 car2)
+ (and (not (pattern-more-specific-p car2 car1))
+ (pattern-more-specific-p cdr1 cdr2)))))
+
+;; `class-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::class-pattern)
+ (pattern2 optima::class-pattern))
+ (let ((class1 (optima::class-pattern-class-name pattern1))
+ (class2 (optima::class-pattern-class-name pattern2)))
+ (multiple-value-bind (result1 certain1-p) (subtypep class1 class2)
+ (multiple-value-bind (result2 certain2-p) (subtypep class2 class1)
+ (assert (and certain1-p certain2-p))
+ (cond
+ ((and result1 result2)
+ ;; TODO this will be call-next-method => method for complex-pattern-sub-patterns
+ (loop :for subpattern1 :in (optima::complex-pattern-subpatterns pattern1) ; TODO permutations
+ :for subpattern2 :in (optima::complex-pattern-subpatterns pattern2)
+ :do (cond
+ ((pattern-more-specific-p subpattern1 subpattern2)
+ (return t))
+ ((pattern-more-specific-p subpattern2 subpattern1)
+ (return nil)))))
+ (result1
+ t)
+ (t
+ nil))))))
+
+;; `structure-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima::structure-pattern)
+ (pattern2 optima::structure-pattern))
+ (error "not implemented"))
--- /dev/null
+;;;; package.lisp --- Package definition for the language-extension.pattern-specializer system.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:defpackage #:pattern-specializer
+ (:use
+ #:cl
+ #:alexandria)
+
+ (:import-from #:sb-mop
+
+ #:funcallable-standard-class
+ #:set-funcallable-instance-function
+
+ #:specializer
+ #:specializer-direct-methods
+
+ #:method-specializers
+ #:method-function
+
+ #:compute-discriminating-function
+ #:compute-effective-method
+
+ #:generic-function-name
+ #:generic-function-methods
+ #:add-direct-method
+ #:remove-direct-method)
+
+ (:import-from #:sb-pcl
+ #:parse-specializer-using-class
+ #:unparse-specializer-using-class
+ #:make-specializer-form-using-class
+
+ #:make-method-lambda-using-specializers)
+
+ ;; Specifier symbol for the pattern specializer
+ (:export
+ #:pattern)
+
+ ;; Pattern specializer class
+ (:export
+ #:pattern-specializer
+ #:specializer-pattern)
+
+ ;; Generic function and method
+ (:export
+ #:pattern-generic-function
+
+ #:pattern-method))
--- /dev/null
+;;;; pattern-specializer.lisp --- Implementation of pattern specializers.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:pattern-specializer)
+
+;;; `pattern-specializer' class
+
+(defclass pattern-specializer (specializer)
+ ((pattern :initarg :pattern
+ :reader specializer-pattern)
+ (direct-methods :type list
+ :initform '()
+ :reader specializer-direct-methods
+ :accessor specializer-%direct-methods))
+ (:default-initargs
+ :pattern (required-argument :pattern)))
+
+(defun specializer-parsed-pattern (specializer)
+ (optima::parse-pattern (specializer-pattern specializer)))
+
+(defun specializer-pattern-variables (specializer)
+ (optima::pattern-variables (specializer-parsed-pattern specializer)))
+
+;; TODO why did i need this again?
+(defmethod class-name ((class (eql (find-class 'pattern-specializer))))
+ 'pattern-specializer)
+
+(defmethod add-direct-method ((specializer pattern-specializer)
+ (method t))
+ (pushnew method (specializer-%direct-methods specializer)))
+
+(defmethod remove-direct-method ((specializer pattern-specializer)
+ (method t))
+ (removef (specializer-%direct-methods specializer) method :count 1))
+
+(defmethod print-object ((object pattern-specializer) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (princ (specializer-pattern object) stream)))
+
+;;;
+
+(defvar *pattern-specializer-table*
+ (make-hash-table :test 'equal :weakness :key-and-value))
+
+(defun ensure-pattern-specializer (pattern)
+ (ensure-gethash pattern *pattern-specializer-table*
+ (make-instance 'pattern-specializer :pattern pattern)))
+
+;;; pattern-method
+
+;; Forward definition. Actual definition is below.
+(defclass pattern-generic-function (standard-generic-function)
+ ()
+ (:metaclass funcallable-standard-class))
+
+(defclass pattern-method (standard-method)
+ ())
+
+(defmethod method-pattern-specializers ((gf pattern-generic-function)
+ (method pattern-method))
+ (remove-if-not (of-type 'pattern-specializer)
+ (mapcar (curry #'parse-specializer-using-class gf) ; TODO necessary?
+ (method-specializers method))))
+
+(defmethod make-method-lambda-using-specializers
+ ((gf pattern-generic-function) (method pattern-method) qualifiers specializers
+ lambda-expression environment)
+
+ ;; This transforms LAMBDA-EXPRESSION of the form
+ ;;
+ ;; (lambda (arg1 arg2 …) BODY)
+ ;;
+ ;; into
+ ;;
+ ;; (lambda (arg1 arg2 …
+ ;; &key
+ ;; ((:PATTERN-VAR1 PATTERN-VAR1)) ((:PATTERN-VAR2 PATTERN-VAR2)) …
+ ;; &allow-other-keys)
+ ;; BODY)
+ ;;
+ ;; TODO obviously, this has to parse the original lambda-list
+ ;; properly in the future.
+ (destructuring-bind (operator lambda-list &body body) lambda-expression
+ (declare (ignore operator))
+ (multiple-value-bind (required optional rest keyword allow-other-keys-p)
+ (parse-ordinary-lambda-list lambda-list :normalize nil)
+ (flet ((make-keyword-parameter (variable)
+ (list `((,(make-keyword variable) ,variable)))))
+ (let* ((variables (mappend #'specializer-pattern-variables ; TODO this stuff is repeated in make-method-matching-form
+ (remove-if-not (of-type 'pattern-specializer)
+ (mapcar (curry #'parse-specializer-using-class gf)
+ specializers))))
+ (new-lambda-list `(,@required
+ ,@(when optional
+ `(&optional ,@optional))
+ ,@(when rest
+ `(&rest ,rest))
+ ,@(when (or keyword variables)
+ `(&key ,@keyword
+ ,@(mapcan #'make-keyword-parameter variables)))
+ ,@(when allow-other-keys-p
+ '(&allow-other-keys))))
+ (new-lambda-expression `(lambda ,new-lambda-list ,@body)))
+
+ (format t "make-method-lambda-using-specializers~% ~A~% ~A~% ~A~% ~A~%=>"
+ gf method specializers lambda-expression)
+ (print new-lambda-list)
+ (print new-lambda-expression)
+
+ (call-next-method
+ gf method qualifiers specializers new-lambda-expression environment))))))
+
+(defgeneric method-more-specific-p (gf method1 method2))
+
+(defmethod method-more-specific-p ((gf pattern-generic-function)
+ (method1 pattern-method)
+ (method2 pattern-method))
+ (let* ((specializers1 (method-pattern-specializers gf method1))
+ (specializers2 (method-pattern-specializers gf method2))
+ (more-index (mismatch specializers1 specializers2
+ :test (complement #'pattern-more-specific-p)
+ :key #'specializer-parsed-pattern))
+ (less-index (mismatch specializers1 specializers2
+ :test #'pattern-more-specific-p
+ :key #'specializer-parsed-pattern)))
+ (or (and more-index (not less-index))
+ (and more-index (< more-index less-index)))))
+
+(defun in-same-cluster-p (gf method1 method2)
+ (or (equal (mapcar #'specializer-pattern
+ (method-pattern-specializers gf method1))
+ (mapcar #'specializer-pattern
+ (method-pattern-specializers gf method2)))
+ (method-more-specific-p gf method1 method2)
+ (method-more-specific-p gf method2 method1)))
+
+(defun cluster-methods (gf methods)
+ (let ((clusters '()))
+ (dolist (method1 methods)
+ (dolist (cluster clusters (push (list (list method1)) clusters))
+ (when (every (lambda (entry) (in-same-cluster-p gf method1 (first entry)))
+ cluster)
+ (dolist (entry cluster
+ (nconcf cluster (list (list method1))))
+ (when (equal (mapcar #'specializer-pattern ; TODO repeated in in-same-cluster-p
+ (method-pattern-specializers gf method1))
+ (mapcar #'specializer-pattern
+ (method-pattern-specializers gf (first entry))))
+ (nconcf entry (list method1))
+ (return)))
+ (return))))
+ (mapcar (lambda (cluster)
+ (stable-sort cluster (lambda (entry1 entry2)
+ (method-more-specific-p gf (first entry1) (first entry2)))))
+ clusters)))
+
+;;; pattern-generic-function
+
+(defclass pattern-generic-function (standard-generic-function)
+ ()
+ (:metaclass funcallable-standard-class)
+ (:default-initargs
+ :method-class (find-class 'pattern-method)))
+
+(defmethod parse-specializer-using-class
+ ((gf pattern-generic-function) (specializer-name t))
+ (if (typep specializer-name '(cons (eql pattern)))
+ (let ((pattern (second specializer-name)))
+ (ensure-pattern-specializer pattern))
+ (call-next-method)))
+
+(defmethod parse-specializer-using-class
+ ((gf pattern-generic-function) (specializer-name pattern-specializer))
+ specializer-name)
+
+(defmethod unparse-specializer-using-class
+ ((gf pattern-generic-function) (specializer pattern-specializer))
+ `(pattern ,(specializer-pattern specializer)))
+
+(defmethod make-specializer-form-using-class or
+ ((proto-generic-function pattern-generic-function)
+ (proto-method pattern-method)
+ (specializer-name cons)
+ (environment t))
+ (when (typep specializer-name '(cons (eql pattern)))
+ `(sb-pcl:parse-specializer-using-class ; TODO packages
+ (sb-pcl:class-prototype (find-class ',(type-of proto-generic-function)))
+ ',specializer-name)))
+
+(defun make-matching-lambda-form (gf methods)
+ (let ((arity (when-let ((first-method (first methods)))
+ (length (method-specializers first-method))))
+ (clusters (cluster-methods gf methods)))
+ (labels ((specializer-pattern1 (specializer)
+ (typecase specializer
+ (pattern-specializer (specializer-pattern specializer))
+ (t '*)))
+ (method-variables (method)
+ (mappend #'specializer-pattern-variables
+ (method-pattern-specializers gf method)))
+ (cluster-clause (most-specific-method other-methods)
+ (let ((specializers (method-specializers most-specific-method)))
+ `(,(case arity
+ (1 (specializer-pattern1 (first specializers)))
+ (t (mapcar #'specializer-pattern1 specializers)))
+ (values
+ '(,most-specific-method ,@other-methods)
+ (list ,@(method-variables most-specific-method))))))
+ (cluster-clauses (cluster)
+ (loop :for ((head-first . head-rest) . rest) :on cluster
+ :collect (cluster-clause
+ head-first (reduce #'append rest
+ :initial-value head-rest)))))
+ `(lambda ,(case arity
+ (1 '(arg))
+ (t '(&rest args)))
+ ,(case arity
+ (1 '(format t "dispatch: ~A~%" arg))
+ (t '(format t "dispatch: ~A~%" args)))
+ (,@(case arity
+ (1 `(optima:match arg))
+ (t `(optima:multiple-value-match (values-list args))))
+ ,@(loop :for cluster :in clusters
+ :appending (cluster-clauses cluster)))))))
+
+(defun make-method-interpreting-function (gf)
+ (format t "~&method-interpreting-function: ~A~%" gf)
+ (let* ((methods (generic-function-methods gf))
+ (f (compile nil (print (make-matching-lambda-form gf methods)))))
+ (named-lambda method-pattern-matching-function (&rest args) ; TODO just return the (compile …) above after debugging
+ (apply f args))))
+
+(defmethod compute-discriminating-function
+ ((gf pattern-generic-function))
+ (lambda (&rest args)
+ (format t "~&discriminating function: ~A~%" args)
+ (labels ((make-effective-method-form (spec)
+ `(lambda (&rest args)
+ (locally
+ (declare (sb-ext:disable-package-locks make-method call-method))
+ (macrolet ((make-method (spec)
+ (let ((make-effective-method-function ,#'make-effective-method-function))
+ (make-instance 'standard-method
+ :specializers nil ; TODO
+ :qualifiers nil ; TODO
+ :function (let ((f (funcall make-effective-method-function spec)))
+ (lambda (a n)
+ (apply f a))))))
+ (call-method (method next-methods)
+ ;; TODO we could do method-specific parsing here
+ ;; TODO can we extract the method-function like ,(method-function method)?
+ `(progn
+ (format t "~& trying to call~% ~A~% ~A~% ~A~%"
+ ,method args (list ,@next-methods))
+ (funcall (method-function ,method) args (list ,@next-methods)))))
+ ,spec))))
+ (make-effective-method-function (spec)
+ (compile nil (make-effective-method-form spec))))
+ (let* ((function2 (make-method-interpreting-function gf))
+ (function4 (lambda (&rest args)
+ (multiple-value-bind (methods variables) (apply function2 args)
+
+ (loop :for spec :in (method-pattern-specializers gf (first methods))
+ :for gen :in (mapcar #'class-of args)
+ :do (print (list spec gen (multiple-value-list (specializer-accepts-generalizer-p
+ gf spec gen)))))
+
+ (let ((function3 (progn
+ (format t "~& methods~% ~A~& variables~& ~A~%" methods variables)
+ (multiple-value-bind (effective-method options)
+ (compute-effective-method
+ gf (sb-mop::generic-function-method-combination gf) methods)
+ (format t "~& effective method:~& ")
+ (print effective-method)
+ (format t "~& options:~& ")
+ (print options)
+ (make-effective-method-function effective-method)))))
+ (apply function3 (append args (loop :for value :in variables
+ :for name :in (when methods
+ (mappend
+ #'specializer-pattern-variables
+ (method-pattern-specializers gf (first methods))))
+ :collect (make-keyword name)
+ :collect value))))))))
+ (set-funcallable-instance-function gf function4) ; TODO seems to be wrong
+ (apply function4 args)))))
--- /dev/null
+;;;; pcl-patch.lisp --- Hot-patch for SBCL's PCL variant.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:sb-pcl)
+
+;;; `make-method-lambda-using-specializers'
+
+(export '(make-method-lambda-using-specializers))
+
+(defgeneric make-method-lambda-using-specializers (gf method qualifiers specializers method-lambda env)
+ (:method ((gf standard-generic-function) (method standard-method) qualifiers specializers method-lambda env)
+ (declare (type (cons (eql lambda) (cons list)) method-lambda))
+ ;; Default behavior: delegate to MAKE-METHOD-LAMBDA.
+ (let* ((lambda-list (second method-lambda))
+ (*method-lambda-list* (append
+ (mapcar #'list (subseq lambda-list 0 (length specializers)) specializers)
+ (subseq lambda-list (length specializers)))))
+ (make-method-lambda gf method method-lambda env)))
+ (:documentation
+ "TODO
+return three values:
+1. the method lambda
+2. initargs for the method instance
+3. a (possibly modified) method lambda-list or nil"))
+
+(defun expand-defmethod (name
+ proto-gf
+ proto-method
+ qualifiers
+ lambda-list
+ body
+ env)
+ (multiple-value-bind (parameters unspecialized-lambda-list specializers)
+ (parse-specialized-lambda-list lambda-list)
+ (declare (ignore parameters))
+ (let ((*method-name* `(,name ,@qualifiers ,specializers))
+ (method-lambda `(lambda ,unspecialized-lambda-list ,@body)))
+ (multiple-value-bind (method-function-lambda initargs new-lambda-list)
+ (make-method-lambda-using-specializers
+ proto-gf proto-method qualifiers specializers method-lambda env)
+ (let ((initargs-form (make-method-initargs-form
+ proto-gf proto-method method-function-lambda
+ initargs env))
+ (specializers-form (make-method-specializers-form
+ proto-gf proto-method specializers env)))
+ `(progn
+ ;; Note: We could DECLAIM the ftype of the generic function
+ ;; here, since ANSI specifies that we create it if it does
+ ;; not exist. However, I chose not to, because I think it's
+ ;; more useful to support a style of programming where every
+ ;; generic function has an explicit DEFGENERIC and any typos
+ ;; in DEFMETHODs are warned about. Otherwise
+ ;;
+ ;; (DEFGENERIC FOO-BAR-BLETCH (X))
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+ ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+ ;;
+ ;; compiles without raising an error and runs without
+ ;; raising an error (since SIMPLE-VECTOR cases fall through
+ ;; to VECTOR) but still doesn't do what was intended. I hate
+ ;; that kind of bug (code which silently gives the wrong
+ ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+ ,(make-defmethod-form name qualifiers specializers-form
+ (or new-lambda-list unspecialized-lambda-list)
+ (if proto-method
+ (class-name (class-of proto-method))
+ 'standard-method)
+ initargs-form)))))))
+
+;;; `make-specializer-form-using-class'
+;;;
+;;; To free every new custom generic function class from having to
+;;; implement iteration over specializers in
+;;; `make-method-specializers-form', we provide a default method
+;;;
+;;; make-method-specializers-form standard-g-f standard-method
+;;;
+;;; which performs this iteration and calls the new generic function
+;;;
+;;; make-specializer-form-using-class proto-g-f proto-m specializer-names env
+;;;
+;;; on which custom generic function classes can install methods to
+;;; handle their custom specializers. The generic function uses OR
+;;; method combination to allow the following idiom:
+;;;
+;;; (defmethod make-specializer-form-using-class or
+;;; (proto-generic-function MY-GENERIC-FUNCTION)
+;;; (proto-method standard-method)
+;;; (specializer-name cons)
+;;; (environment t))
+;;; (when (typep specializer-name '(cons (eql MY-SPECIALIZER)))
+;;; MY-SPECIALIZER-FORM))
+;;;
+;;; The OR method combination lets everything but (my-specializer …)
+;;; fall through to the next methods which will, at some point, handle
+;;; class and eql specializers and eventually reach an error signaling
+;;; method for invalid specializers.
+
+;; TODO same approach for parse-specializer-using-class?
+(defgeneric make-specializer-form-using-class (proto-generic-function proto-method specializer-name environment)
+ (:method-combination or)
+ #+sb-doc
+ (:documentation
+ "Return a form which, when evaluated in lexical environment
+ ENVIRONMENT, parses the specializer SPECIALIZER-NAME and returns
+ the appropriate specializer object.
+
+ Both PROTO-GENERIC-FUNCTION and PROTO-METHOD may be
+ uninitialized. However their types and prototype can be
+ inspected."))
+
+;; Default behavior is signaling an error for not otherwise handled
+;; specializers.
+(defmethod make-specializer-form-using-class or
+ ((proto-generic-function standard-generic-function)
+ (proto-method standard-method)
+ (specializer-name t)
+ (environment t))
+ (error 'simple-reference-error
+ :format-control
+ "~@<~S is not a valid parameter specializer name.~@:>"
+ :format-arguments (list specializer-name)
+ :references (list '(:ansi-cl :macro defmethod)
+ '(:ansi-cl :glossary "parameter specializer name"))))
+
+(defmethod make-specializer-form-using-class or
+ ((proto-generic-function standard-generic-function)
+ (proto-method standard-method)
+ (specializer-name symbol)
+ (environment t))
+ `(find-class ',specializer-name))
+
+(defmethod make-specializer-form-using-class or
+ ((proto-generic-function standard-generic-function)
+ (proto-method standard-method)
+ (specializer-name cons)
+ (environment t))
+ ;; In case of unknown specializer or known specializer with syntax
+ ;; error, TYPECASE may fall through to default method with error
+ ;; signaling.
+ (typecase specializer-name
+ ((cons (eql eql) (cons t null))
+ `(intern-eql-specializer ,(second specializer-name)))
+ ((cons (eql class-eq) (cons t null))
+ `(class-eq-specializer (find-class ',(second specializer-name))))))
+
+(defmethod make-method-specializers-form
+ ((proto-generic-function standard-generic-function)
+ (proto-method standard-method)
+ (specializer-names t)
+ (environment t))
+ (flet ((make-parse-form (name)
+ (make-specializer-form-using-class
+ proto-generic-function proto-method name environment)))
+ `(list ,@(mapcar #'make-parse-form specializer-names))))
projects / specializable.git / commitdiff