From 81054f0131824964d2cebfd7dec6f18be113020b Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sat, 3 Aug 2019 15:40:37 +0100 Subject: [PATCH] src/class-make-{proto,impl}.lisp, ...: Use &key rather than &optional. This makes it easier to add new bells and whistles as needed. --- doc/meta.tex | 26 +++++++++++++------------- src/class-make-impl.lisp | 31 ++++++++++++++++--------------- src/class-make-proto.lisp | 22 +++++++++++----------- src/module-parse.lisp | 31 +++++++++++++++++-------------- 4 files changed, 57 insertions(+), 53 deletions(-) diff --git a/doc/meta.tex b/doc/meta.tex index 43a71fe..2d1a577 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -62,7 +62,7 @@ \end{describe*} \begin{describe}{fun} - {make-sod-class @ @ @ \&optional @ + {make-sod-class @ @ @ \&key :location @> @} \end{describe} @@ -125,7 +125,7 @@ \end{describe*} \begin{describe}{gf} - {make-sod-slot @ @ @ @ \&optional @ + {make-sod-slot @ @ @ @ \&key :location @> @} \end{describe} @@ -166,17 +166,17 @@ \begin{describe*} {\dhead{gf} {make-sod-instance-initializer - \=@ @ @ @ @ \&optional @ + \=@ @ @ @ @ \&key :location \nlret @} \dhead{gf} {make-sod-class-initializer - \=@ @ @ @ @ \&optional @ + \=@ @ @ @ @ \&key :location \nlret @}} \end{describe*} \begin{describe}{gf} {make-sod-initializer-using-slot - \=@ @ @ @ @ \&optional @ + @ @ @ @ @ @ \nlret @} \end{describe} @@ -196,7 +196,7 @@ \begin{describe}{gf} {make-sod-user-initarg @ @ @ @ - \&optional @ @} + \&key :default :location} \end{describe} \begin{describe}{gf}{sod-initarg-default @ @> @} @@ -212,19 +212,19 @@ \begin{describe}{gf} {make-sod-slot-initarg @ @ @ @ @ - \&optional @} + \&key :location} \end{describe} \begin{describe}{gf} {make-sod-slot-initarg-using-slot @ @ @ @ - \&optional @} + \&key :location} \end{describe} \begin{describe*} {\dhead{gf}{make-sod-class-initfrag @ @ @ - \&optional @} + \&key :location} \dhead{gf}{make-sod-class-tearfrag @ @ @ - \&optional @}} + \&key :location}} \end{describe*} \begin{describe}{cls}{sod-message () \&key :name :location :class :type} @@ -237,7 +237,7 @@ \end{describe*} \begin{describe}{gf} - {make-sod-message @ @ @ @ \&optional @ + {make-sod-message @ @ @ @ \&key :location @> @} \end{describe} @@ -263,7 +263,7 @@ \begin{describe}{gf} {make-sod-method \=@ @ @ @ @ \+\\ - @ \&optional @ \- + @ \&key :location \- \nlret @} \end{describe} @@ -271,7 +271,7 @@ {make-sod-method-using-message \=@ @ @ @ \+\\ - @ \&optional @ \- + @ \&key :location \- \nlret @} \end{describe} diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index da6cd2c..5fe9de7 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -84,7 +84,7 @@ ;;; Slots. (defmethod make-sod-slot - ((class sod-class) name type pset &optional location) + ((class sod-class) name type pset &key location) (with-default-error-location (location) (when (typep type 'c-function-type) (error "Slot declarations cannot have function type")) @@ -99,8 +99,8 @@ (with-slots (slots) class (setf slots (append slots (list slot)))) (when initarg-name - (make-sod-slot-initarg-using-slot class initarg-name - slot pset location)) + (make-sod-slot-initarg-using-slot class initarg-name slot pset + :location location)) slot))) (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset) @@ -115,7 +115,7 @@ ;;; Slot initializers. (defmethod make-sod-instance-initializer - ((class sod-class) nick name value pset &optional location) + ((class sod-class) nick name value pset &key location) (with-default-error-location (location) (let* ((slot (find-instance-slot-by-name class nick name)) (initarg-name (get-property pset :initarg :id)) @@ -127,15 +127,15 @@ (unless (or initarg-name initializer) (error "Slot initializer declaration with no effect")) (when initarg-name - (make-sod-slot-initarg-using-slot class initarg-name slot - pset location)) + (make-sod-slot-initarg-using-slot class initarg-name slot pset + :location location)) (when initializer (setf instance-initializers (append instance-initializers (list initializer))))) initializer))) (defmethod make-sod-class-initializer - ((class sod-class) nick name value pset &optional location) + ((class sod-class) nick name value pset &key location) (with-default-error-location (location) (let* ((slot (find-class-slot-by-name class nick name)) (initializer (make-sod-initializer-using-slot @@ -165,7 +165,7 @@ nil) (defmethod make-sod-user-initarg - ((class sod-class) name type pset &optional default location) + ((class sod-class) name type pset &key default location) (with-slots (initargs) class (push (make-instance (get-property pset :initarg-class :symbol 'sod-user-initarg) @@ -174,12 +174,13 @@ initargs))) (defmethod make-sod-slot-initarg - ((class sod-class) name nick slot-name pset &optional location) + ((class sod-class) name nick slot-name pset &key location) (let ((slot (find-instance-slot-by-name class nick slot-name))) - (make-sod-slot-initarg-using-slot class name slot pset location))) + (make-sod-slot-initarg-using-slot class name slot pset + :location location))) (defmethod make-sod-slot-initarg-using-slot - ((class sod-class) name (slot sod-slot) pset &optional location) + ((class sod-class) name (slot sod-slot) pset &key location) (with-slots (initargs) class (with-slots ((type %type)) slot (push (make-instance (get-property pset :initarg-class :symbol @@ -199,13 +200,13 @@ ;;; Initialization and teardown fragments. (defmethod make-sod-class-initfrag - ((class sod-class) frag pset &optional location) + ((class sod-class) frag pset &key location) (declare (ignore pset location)) (with-slots (initfrags) class (setf initfrags (append initfrags (list frag))))) (defmethod make-sod-class-tearfrag - ((class sod-class) frag pset &optional location) + ((class sod-class) frag pset &key location) (declare (ignore pset location)) (with-slots (tearfrags) class (setf tearfrags (append tearfrags (list frag))))) @@ -214,7 +215,7 @@ ;;; Messages. (defmethod make-sod-message - ((class sod-class) name type pset &optional location) + ((class sod-class) name type pset &key location) (with-default-error-location (location) (let* ((msg-class (or (get-property pset :message-class :symbol) (and (get-property pset :combination :keyword) @@ -246,7 +247,7 @@ ;;; Methods. (defmethod make-sod-method - ((class sod-class) nick name type body pset &optional location) + ((class sod-class) nick name type body pset &key location) (with-default-error-location (location) (let* ((message (find-message-by-name class nick name)) (method (make-sod-method-using-message message class diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp index 2e1fe7c..a2783ee 100644 --- a/src/class-make-proto.lisp +++ b/src/class-make-proto.lisp @@ -37,7 +37,7 @@ the direct superclasses of CLASS, or to signal an error if that failed.")) (export 'make-sod-class) -(defun make-sod-class (name superclasses pset &optional location) +(defun make-sod-class (name superclasses pset &key location) "Construct and return a new SOD class with the given NAME and SUPERCLASSES. This is the main constructor function for classes. The protocol works as @@ -72,7 +72,7 @@ ;;; Slots and slot initializers. (export 'make-sod-slot) -(defgeneric make-sod-slot (class name type pset &optional location) +(defgeneric make-sod-slot (class name type pset &key location) (:documentation "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. @@ -86,7 +86,7 @@ (export 'make-sod-instance-initializer) (defgeneric make-sod-instance-initializer - (class nick name value pset &optional location) + (class nick name value pset &key location) (:documentation "Construct and attach an instance slot initializer, to CLASS. @@ -99,7 +99,7 @@ (export 'make-sod-class-initializer) (defgeneric make-sod-class-initializer - (class nick name value pset &optional location) + (class nick name value pset &key location) (:documentation "Construct and attach a class slot initializer, to CLASS. @@ -135,7 +135,7 @@ (export 'make-sod-user-initarg) (defgeneric make-sod-user-initarg - (class name type pset &optional default location) + (class name type pset &key default location) (:documentation "Attach a user-defined initialization keyword argument to the CLASS. @@ -145,7 +145,7 @@ (export 'make-sod-slot-initarg) (defgeneric make-sod-slot-initarg - (class name nick slot-name pset &optional location) + (class name nick slot-name pset &key location) (:documentation "Attach an initialization keyword argument to a slot by name. @@ -154,7 +154,7 @@ (export 'make-sod-slot-initarg-using-slot) (defgeneric make-sod-slot-initarg-using-slot - (class name slot pset &optional location) + (class name slot pset &key location) (:documentation "Attach an initialization keyword argument to a SLOT. @@ -169,7 +169,7 @@ (:documentation "Returns an `argument' object for the initarg.")) (export 'make-sod-class-initfrag) -(defgeneric make-sod-class-initfrag (class frag pset &optional location) +(defgeneric make-sod-class-initfrag (class frag pset &key location) (:documentation "Attach an initialization fragment FRAG to the CLASS. @@ -177,7 +177,7 @@ list.")) (export 'make-sod-class-tearfrag) -(defgeneric make-sod-class-tearfrag (class frag pset &optional location) +(defgeneric make-sod-class-tearfrag (class frag pset &key location) (:documentation "Attach a teardown fragment FRAG to the CLASS. @@ -188,7 +188,7 @@ ;;; Messages and methods. (export 'make-sod-message) -(defgeneric make-sod-message (class name type pset &optional location) +(defgeneric make-sod-message (class name type pset &key location) (:documentation "Construct and attach a new message with given NAME and TYPE, to CLASS. @@ -204,7 +204,7 @@ (export 'make-sod-method) (defgeneric make-sod-method - (class nick name type body pset &optional location) + (class nick name type body pset &key location) (:documentation "Construct and attach a new method to CLASS. diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 747bdf7..81a3956 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -226,7 +226,7 @@ (parse (seq ((make (or (seq ("init") #'make-sod-class-initfrag) (seq ("teardown") #'make-sod-class-tearfrag))) (frag (parse-delimited-fragment scanner #\{ #\}))) - (funcall make class frag pset scanner))))) + (funcall make class frag pset :location scanner))))) (define-pluggable-parser class-item initargs (scanner class pset) ;; initarg-item ::= `initarg' declspec+ list[init-declarator] @@ -243,7 +243,9 @@ (make-sod-user-initarg class (cdr declarator) (car declarator) - pset init scanner)) + pset + :default init + :location scanner)) #\,)) (nil (must #\;))))))) @@ -282,7 +284,8 @@ (unless (pset-get pset "nick") (add-property pset "nick" var :type :id)) var))) - (class (make-sod-class synthetic-name superclasses pset scanner)) + (class (make-sod-class synthetic-name superclasses pset + :location scanner)) (nick (sod-class-nickname class))) (labels ((must-id () @@ -313,8 +316,8 @@ ;; Don't allow a method-body here if the message takes a ;; varargs list, because we don't have a name for the ;; `va_list' parameter. - (let ((message (make-sod-message class name type - sub-pset scanner))) + (let ((message (make-sod-message class name type sub-pset + :location scanner))) (if (varargs-message-p message) (parse #\;) (parse (or #\; (parse-method-item sub-pset @@ -330,7 +333,8 @@ scanner #\{ #\})))) (restart-case (make-sod-method class sub-nick name type - body sub-pset scanner) + body sub-pset + :location scanner) (continue () :report "Continue"))))) (parse-initializer () @@ -350,14 +354,12 @@ (flet ((make-it (name type init) (restart-case (progn - (make-sod-slot class name type - sub-pset scanner) + (make-sod-slot class name type sub-pset + :location scanner) (when init - (make-sod-instance-initializer class - nick name - init - sub-pset - scanner))) + (make-sod-instance-initializer + class nick name init sub-pset + :location scanner))) (continue () :report "Continue")))) (parse (and (error () (seq ((init (? (parse-initializer)))) @@ -388,7 +390,8 @@ (restart-case (funcall constructor class name-a name-b init - sub-pset scanner) + sub-pset + :location scanner) (continue () :report "Continue"))) (skip-until () #\, #\;)) #\,) -- 2.11.0