From: Christophe Rhodes Date: Sun, 13 Apr 2014 19:57:27 +0000 (+0100) Subject: add files from Jan Moringen's pattern-specializer repository X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=commitdiff_plain;h=HEAD add files from Jan Moringen's pattern-specializer repository --- diff --git a/examples/lambda-calculus.lisp b/examples/lambda-calculus.lisp new file mode 100644 index 0000000..a50f503 --- /dev/null +++ b/examples/lambda-calculus.lisp @@ -0,0 +1,120 @@ +;;;; lambda-calculus.lisp --- Untyped lambda calculus based on pattern specializers. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +;;;; 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))) diff --git a/examples/test.lisp b/examples/test.lisp new file mode 100644 index 0000000..36847ce --- /dev/null +++ b/examples/test.lisp @@ -0,0 +1,63 @@ +;;;; test.lisp --- +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(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")) diff --git a/language-extension.pattern-specializer.asd b/language-extension.pattern-specializer.asd new file mode 100644 index 0000000..d57d1dc --- /dev/null +++ b/language-extension.pattern-specializer.asd @@ -0,0 +1,28 @@ +;;;; language-extension.pattern-specializer.asd --- System definition for the language-extension.pattern-specializer system. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(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 " + :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"))))) diff --git a/src/optima-extensions.lisp b/src/optima-extensions.lisp new file mode 100644 index 0000000..19eefac --- /dev/null +++ b/src/optima-extensions.lisp @@ -0,0 +1,119 @@ +;;;; optima-extensions.lisp --- Necessary extensions of the optima library. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(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")) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..2f86c44 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,51 @@ +;;;; package.lisp --- Package definition for the language-extension.pattern-specializer system. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(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)) diff --git a/src/pattern-specializer.lisp b/src/pattern-specializer.lisp new file mode 100644 index 0000000..9b201a8 --- /dev/null +++ b/src/pattern-specializer.lisp @@ -0,0 +1,289 @@ +;;;; pattern-specializer.lisp --- Implementation of pattern specializers. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(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))))) diff --git a/src/pcl-patch.lisp b/src/pcl-patch.lisp new file mode 100644 index 0000000..dbb4add --- /dev/null +++ b/src/pcl-patch.lisp @@ -0,0 +1,161 @@ +;;;; pcl-patch.lisp --- Hot-patch for SBCL's PCL variant. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(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))))