This makes it easier to add new bells and whistles as needed.
\end{describe*}
\begin{describe}{fun}
- {make-sod-class @<name> @<superclasses> @<pset> \&optional @<floc>
+ {make-sod-class @<name> @<superclasses> @<pset> \&key :location
@> @<class>}
\end{describe}
\end{describe*}
\begin{describe}{gf}
- {make-sod-slot @<class> @<name> @<type> @<pset> \&optional @<floc>
+ {make-sod-slot @<class> @<name> @<type> @<pset> \&key :location
@> @<slot>}
\end{describe}
\begin{describe*}
{\dhead{gf}
{make-sod-instance-initializer
- \=@<class> @<nick> @<name> @<value> @<pset> \&optional @<floc>
+ \=@<class> @<nick> @<name> @<value> @<pset> \&key :location
\nlret @<init>}
\dhead{gf}
{make-sod-class-initializer
- \=@<class> @<nick> @<name> @<value> @<pset> \&optional @<floc>
+ \=@<class> @<nick> @<name> @<value> @<pset> \&key :location
\nlret @<init>}}
\end{describe*}
\begin{describe}{gf}
{make-sod-initializer-using-slot
- \=@<class> @<slot> @<init-class> @<value> @<pset> \&optional @<floc>
+ @<class> @<slot> @<init-class> @<value> @<pset> @<floc>
\nlret @<init>}
\end{describe}
\begin{describe}{gf}
{make-sod-user-initarg @<class> @<name> @<type> @<pset>
- \&optional @<default> @<floc>}
+ \&key :default :location}
\end{describe}
\begin{describe}{gf}{sod-initarg-default @<initarg> @> @<default>}
\begin{describe}{gf}
{make-sod-slot-initarg @<class> @<name> @<nick> @<slot-name> @<pset>
- \&optional @<floc>}
+ \&key :location}
\end{describe}
\begin{describe}{gf}
{make-sod-slot-initarg-using-slot @<class> @<name> @<slot> @<pset>
- \&optional @<floc>}
+ \&key :location}
\end{describe}
\begin{describe*}
{\dhead{gf}{make-sod-class-initfrag @<class> @<frag> @<pset>
- \&optional @<floc>}
+ \&key :location}
\dhead{gf}{make-sod-class-tearfrag @<class> @<frag> @<pset>
- \&optional @<floc>}}
+ \&key :location}}
\end{describe*}
\begin{describe}{cls}{sod-message () \&key :name :location :class :type}
\end{describe*}
\begin{describe}{gf}
- {make-sod-message @<class> @<name> @<type> @<pset> \&optional @<floc>
+ {make-sod-message @<class> @<name> @<type> @<pset> \&key :location
@> @<message>}
\end{describe}
\begin{describe}{gf}
{make-sod-method
\=@<class> @<nick> @<name> @<type> @<body> \+\\
- @<pset> \&optional @<floc> \-
+ @<pset> \&key :location \-
\nlret @<method>}
\end{describe}
{make-sod-method-using-message
\=@<message> @<class>
@<type> @<body> \+\\
- @<pset> \&optional @<floc> \-
+ @<pset> \&key :location \-
\nlret @<method>}
\end{describe}
;;; 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"))
(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)
;;; 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))
(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
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)
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
;;; 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)))))
;;; 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)
;;; 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
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
;;; 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.
(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.
(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.
(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.
(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.
(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.
(: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.
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.
;;; 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.
(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.
(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]
(make-sod-user-initarg class
(cdr declarator)
(car declarator)
- pset init scanner))
+ pset
+ :default init
+ :location scanner))
#\,))
(nil (must #\;)))))))
(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 ()
;; 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
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 ()
(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))))
(restart-case
(funcall constructor class
name-a name-b init
- sub-pset scanner)
+ sub-pset
+ :location scanner)
(continue () :report "Continue")))
(skip-until () #\, #\;))
#\,)
~mdw / sod / commitdiff