743 | | (eval-when (:compile-toplevel :load-toplevel :execute) |
744 | | (defstruct method-combination |
745 | | name |
746 | | operator |
747 | | identity-with-one-argument |
748 | | documentation) |
749 | | |
750 | | (defun expand-short-defcombin (whole) |
751 | | (let* ((name (cadr whole)) |
752 | | (documentation |
753 | | (getf (cddr whole) :documentation "")) |
754 | | (identity-with-one-arg |
755 | | (getf (cddr whole) :identity-with-one-argument nil)) |
756 | | (operator |
757 | | (getf (cddr whole) :operator name))) |
758 | | `(progn |
759 | | (setf (get ',name 'method-combination-object) |
760 | | (make-method-combination :name ',name |
761 | | :operator ',operator |
762 | | :identity-with-one-argument ',identity-with-one-arg |
763 | | :documentation ',documentation)) |
764 | | ',name))) |
765 | | |
766 | | (defun expand-long-defcombin (whole) |
767 | | (declare (ignore whole)) |
768 | | (error "The long form of DEFINE-METHOD-COMBINATION is not implemented."))) |
769 | | |
770 | | (defmacro define-method-combination (&whole form &rest args) |
771 | | (declare (ignore args)) |
| 745 | (defstruct method-combination |
| 746 | name |
| 747 | documentation) |
| 748 | |
| 749 | (defstruct (short-method-combination |
| 750 | (:include method-combination)) |
| 751 | operator |
| 752 | identity-with-one-argument) |
| 753 | |
| 754 | (defstruct (long-method-combination |
| 755 | (:include method-combination)) |
| 756 | lambda-list |
| 757 | method-group-specs |
| 758 | args-lambda-list |
| 759 | generic-function-symbol |
| 760 | function |
| 761 | arguments |
| 762 | declarations |
| 763 | forms) |
| 764 | |
| 765 | (defun expand-long-defcombin (name args) |
| 766 | (destructuring-bind (lambda-list method-groups &rest body) args |
| 767 | `(apply #'define-long-form-method-combination |
| 768 | ',name |
| 769 | ',lambda-list |
| 770 | (list ,@(mapcar #'canonicalize-method-group-spec method-groups)) |
| 771 | ',body))) |
| 772 | |
| 773 | (defun expand-short-defcombin (whole) |
| 774 | (let* ((name (cadr whole)) |
| 775 | (documentation |
| 776 | (getf (cddr whole) :documentation "")) |
| 777 | (identity-with-one-arg |
| 778 | (getf (cddr whole) :identity-with-one-argument nil)) |
| 779 | (operator |
| 780 | (getf (cddr whole) :operator name))) |
| 781 | `(progn |
| 782 | (setf (get ',name 'method-combination-object) |
| 783 | (make-short-method-combination |
| 784 | :name ',name |
| 785 | :operator ',operator |
| 786 | :identity-with-one-argument ',identity-with-one-arg |
| 787 | :documentation ',documentation)) |
| 788 | ',name))) |
| 789 | |
| 790 | (defmacro define-method-combination (&whole form name &rest args) |
| 806 | ;;; |
| 807 | ;;; long form of define-method-combination (from Sacla and XCL) |
| 808 | ;;; |
| 809 | (defun define-method-combination-type (name &rest initargs) |
| 810 | (setf (get name 'method-combination-object) |
| 811 | (apply 'make-long-method-combination initargs))) |
| 812 | |
| 813 | (defun method-group-p (selecter qualifiers) |
| 814 | ;; selecter::= qualifier-pattern | predicate |
| 815 | (etypecase selecter |
| 816 | (list (or (equal selecter qualifiers) |
| 817 | (let ((last (last selecter))) |
| 818 | (when (eq '* (cdr last)) |
| 819 | (let* ((prefix `(,@(butlast selecter) ,(car last))) |
| 820 | (pos (mismatch prefix qualifiers))) |
| 821 | (or (null pos) (= pos (length prefix)))))))) |
| 822 | ((eql *) t) |
| 823 | (symbol (funcall (symbol-function selecter) qualifiers)))) |
| 824 | |
| 825 | (defun check-variable-name (name) |
| 826 | (flet ((valid-variable-name-p (name) |
| 827 | (and (symbolp name) (not (constantp name))))) |
| 828 | (assert (valid-variable-name-p name)))) |
| 829 | |
| 830 | (defun canonicalize-method-group-spec (spec) |
| 831 | ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]]) |
| 832 | ;; long-form-option::= :description description | :order order | |
| 833 | ;; :required required-p |
| 834 | ;; a canonicalized-spec is a simple plist. |
| 835 | (let* ((rest spec) |
| 836 | (name (prog2 (check-variable-name (car rest)) |
| 837 | (car rest) |
| 838 | (setq rest (cdr rest)))) |
| 839 | (option-names '(:description :order :required)) |
| 840 | (selecters (let ((end (or (position-if #'(lambda (it) |
| 841 | (member it option-names)) |
| 842 | rest) |
| 843 | (length rest)))) |
| 844 | (prog1 (subseq rest 0 end) |
| 845 | (setq rest (subseq rest end))))) |
| 846 | (description (getf rest :description "")) |
| 847 | (order (getf rest :order :most-specific-first)) |
| 848 | (required-p (getf rest :required))) |
| 849 | `(list :name ',name |
| 850 | :predicate (lambda (qualifiers) |
| 851 | (loop for item in ',selecters |
| 852 | thereis (method-group-p item qualifiers))) |
| 853 | :description ',description |
| 854 | :order ,order |
| 855 | :required ',required-p))) |
| 856 | |
| 857 | (defun extract-required-part (lambda-list) |
| 858 | (flet ((skip (key lambda-list) |
| 859 | (if (eq (first lambda-list) key) |
| 860 | (cddr lambda-list) |
| 861 | lambda-list))) |
| 862 | (ldiff (skip '&environment (skip '&whole lambda-list)) |
| 863 | (member-if #'(lambda (it) (member it lambda-list-keywords)) |
| 864 | lambda-list)))) |
| 865 | |
| 866 | (defun extract-specified-part (key lambda-list) |
| 867 | (case key |
| 868 | ((&eval &whole) |
| 869 | (list (second (member key lambda-list)))) |
| 870 | (t |
| 871 | (let ((here (cdr (member key lambda-list)))) |
| 872 | (ldiff here |
| 873 | (member-if #'(lambda (it) (member it lambda-list-keywords)) |
| 874 | here)))))) |
| 875 | |
| 876 | (defun extract-optional-part (lambda-list) |
| 877 | (extract-specified-part '&optional lambda-list)) |
| 878 | |
| 879 | (defun parse-define-method-combination-arguments-lambda-list (lambda-list) |
| 880 | ;; Define-method-combination Arguments Lambda Lists |
| 881 | ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm |
| 882 | (let ((required (extract-required-part lambda-list)) |
| 883 | (whole (extract-specified-part '&whole lambda-list)) |
| 884 | (optional (extract-specified-part '&optional lambda-list)) |
| 885 | (rest (extract-specified-part '&rest lambda-list)) |
| 886 | (keys (extract-specified-part '&key lambda-list)) |
| 887 | (aux (extract-specified-part '&aux lambda-list))) |
| 888 | (values (first whole) |
| 889 | required |
| 890 | (mapcar #'(lambda (spec) |
| 891 | (if (consp spec) |
| 892 | `(,(first spec) ,(second spec) ,@(cddr spec)) |
| 893 | `(,spec nil))) |
| 894 | optional) |
| 895 | (first rest) |
| 896 | (mapcar #'(lambda (spec) |
| 897 | (let ((key (if (consp spec) (car spec) spec)) |
| 898 | (rest (when (consp spec) (rest spec)))) |
| 899 | `(,(if (consp key) key `(,(make-keyword key) ,key)) |
| 900 | ,(car rest) |
| 901 | ,@(cdr rest)))) |
| 902 | keys) |
| 903 | (mapcar #'(lambda (spec) |
| 904 | (if (consp spec) |
| 905 | `(,(first spec) ,(second spec)) |
| 906 | `(,spec nil))) |
| 907 | aux)))) |
| 908 | |
| 909 | (defmacro getk (plist key init-form) |
| 910 | "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST." |
| 911 | (let ((not-exist (gensym)) |
| 912 | (value (gensym))) |
| 913 | `(let ((,value (getf ,plist ,key ,not-exist))) |
| 914 | (if (eq ,not-exist ,value) ,init-form ,value)))) |
| 915 | |
| 916 | (defconstant +gf-args-var+ (make-symbol "GF-ARGS-VAR")) |
| 917 | |
| 918 | (defmacro with-args-lambda-list (args-lambda-list generic-function-symbol |
| 919 | &body forms) |
| 920 | (let ((gf-lambda-list (gensym)) |
| 921 | (nrequired (gensym)) |
| 922 | (noptional (gensym)) |
| 923 | (rest-args (gensym))) |
| 924 | (multiple-value-bind (whole required optional rest keys aux) |
| 925 | (parse-define-method-combination-arguments-lambda-list args-lambda-list) |
| 926 | `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list)) |
| 927 | (,nrequired (length (extract-required-part ,gf-lambda-list))) |
| 928 | (,noptional (length (extract-optional-part ,gf-lambda-list))) |
| 929 | (,rest-args (subseq ,+gf-args-var+ (+ ,nrequired ,noptional))) |
| 930 | ,@(when whole `((,whole ,+gf-args-var+))) |
| 931 | ,@(loop for var in required and i upfrom 0 |
| 932 | collect `(,var (when (< ,i ,nrequired) |
| 933 | (nth ,i ,+gf-args-var+)))) |
| 934 | ,@(loop for (var init-form) in optional and i upfrom 0 |
| 935 | collect |
| 936 | `(,var (if (< ,i ,noptional) |
| 937 | (nth (+ ,nrequired ,i) ,+gf-args-var+) |
| 938 | ,init-form))) |
| 939 | ,@(when rest `((,rest ,rest-args))) |
| 940 | ,@(loop for ((key var) init-form) in keys and i upfrom 0 |
| 941 | collect `(,var (getk ,rest-args ',key ,init-form))) |
| 942 | ,@(loop for (var init-form) in aux and i upfrom 0 |
| 943 | collect `(,var ,init-form))) |
| 944 | ,@forms)))) |
| 945 | |
| 946 | (defmacro with-method-groups (method-group-specs methods-form &body forms) |
| 947 | (flet ((grouping-form (spec methods-var) |
| 948 | (let ((predicate (coerce-to-function (getf spec :predicate))) |
| 949 | (group (gensym)) |
| 950 | (leftovers (gensym)) |
| 951 | (method (gensym))) |
| 952 | `(let ((,group '()) |
| 953 | (,leftovers '())) |
| 954 | (dolist (,method ,methods-var) |
| 955 | (if (funcall ,predicate (method-qualifiers ,method)) |
| 956 | (push ,method ,group) |
| 957 | (push ,method ,leftovers))) |
| 958 | (ecase ,(getf spec :order) |
| 959 | (:most-specific-last ) |
| 960 | (:most-specific-first (setq ,group (nreverse ,group)))) |
| 961 | ,@(when (getf spec :required) |
| 962 | `((when (null ,group) |
| 963 | (error "Method group ~S must not be empty." |
| 964 | ',(getf spec :name))))) |
| 965 | (setq ,methods-var (nreverse ,leftovers)) |
| 966 | ,group)))) |
| 967 | (let ((rest (gensym)) |
| 968 | (method (gensym))) |
| 969 | `(let* ((,rest ,methods-form) |
| 970 | ,@(mapcar #'(lambda (spec) |
| 971 | `(,(getf spec :name) ,(grouping-form spec rest))) |
| 972 | method-group-specs)) |
| 973 | (dolist (,method ,rest) |
| 974 | (invalid-method-error ,method |
| 975 | "Method ~S with qualifiers ~S does not belong to any method group." |
| 976 | ,method (method-qualifiers ,method))) |
| 977 | ,@forms)))) |
| 978 | |
| 979 | (defun method-combination-type-lambda |
| 980 | (&key name lambda-list args-lambda-list generic-function-symbol |
| 981 | method-group-specs declarations forms &allow-other-keys) |
| 982 | (let ((methods (gensym))) |
| 983 | `(lambda (,generic-function-symbol ,methods ,@lambda-list) |
| 984 | ,@declarations |
| 985 | (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name))) |
| 986 | (with-method-groups ,method-group-specs |
| 987 | ,methods |
| 988 | ,@(if (null args-lambda-list) |
| 989 | forms |
| 990 | `((with-args-lambda-list ,args-lambda-list |
| 991 | ,generic-function-symbol |
| 992 | ,@forms)))))))) |
| 993 | |
| 994 | (defun declarationp (expr) |
| 995 | (and (consp expr) (eq (car expr) 'DECLARE))) |
| 996 | |
| 997 | (defun long-form-method-combination-args (args) |
| 998 | ;; define-method-combination name lambda-list (method-group-specifier*) args |
| 999 | ;; args ::= [(:arguments . args-lambda-list)] |
| 1000 | ;; [(:generic-function generic-function-symbol)] |
| 1001 | ;; [[declaration* | documentation]] form* |
| 1002 | (let ((rest args)) |
| 1003 | (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest)))) |
| 1004 | (args-lambda-list () |
| 1005 | (when (nextp :arguments) |
| 1006 | (prog1 (cdr (car rest)) (setq rest (cdr rest))))) |
| 1007 | (generic-function-symbol () |
| 1008 | (if (nextp :generic-function) |
| 1009 | (prog1 (second (car rest)) (setq rest (cdr rest))) |
| 1010 | (gensym))) |
| 1011 | (declaration* () |
| 1012 | (let ((end (position-if-not #'declarationp rest))) |
| 1013 | (when end |
| 1014 | (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest)))))) |
| 1015 | (documentation? () |
| 1016 | (when (stringp (car rest)) |
| 1017 | (prog1 (car rest) (setq rest (cdr rest))))) |
| 1018 | (form* () rest)) |
| 1019 | (let ((declarations '())) |
| 1020 | `(:args-lambda-list ,(args-lambda-list) |
| 1021 | :generic-function-symbol ,(generic-function-symbol) |
| 1022 | :documentation ,(prog2 (setq declarations (declaration*)) |
| 1023 | (documentation?)) |
| 1024 | :declarations (,@declarations ,@(declaration*)) |
| 1025 | :forms ,(form*)))))) |
| 1026 | |
| 1027 | (defun define-long-form-method-combination (name lambda-list method-group-specs |
| 1028 | &rest args) |
| 1029 | (let* ((initargs `(:name ,name |
| 1030 | :lambda-list ,lambda-list |
| 1031 | :method-group-specs ,method-group-specs |
| 1032 | ,@(long-form-method-combination-args args))) |
| 1033 | (lambda-expression (apply #'method-combination-type-lambda initargs))) |
| 1034 | (apply #'define-method-combination-type name |
| 1035 | `(,@initargs |
| 1036 | ;; :function ,(compile nil lambda-expression) |
| 1037 | :function ,(coerce-to-function lambda-expression))) |
| 1038 | name)) |
| 1039 | |