X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/e43d353268fc869045f757932d78d6073db9de6e..ced609b8c5cc865f25cf5cce91a3d7dc9c85bdee:/src/c-types-impl.lisp diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index 9257bf2..16351a3 100644 --- a/src/c-types-impl.lisp +++ b/src/c-types-impl.lisp @@ -416,6 +416,79 @@ (argument-type arg-b))))) list-a list-b))) +(defun fix-and-check-keyword-argument-list (list) + "Check the keyword argument LIST is valid; if so, fix it up and return it. + + Check that the keyword arguments have distinct names. Fix the list up by + sorting it by keyword name." + + (unless (every #'argumentp list) + (error "(INTERNAL) not an argument value")) + + (let ((list (sort (copy-list list) #'string< :key #'argument-name))) + (do ((list (cdr list) (cdr list)) + (this (car list) (car list)) + (prev nil this)) + ((endp list)) + (when prev + (let ((this-name (argument-name this)) + (prev-name (argument-name prev))) + (when (string= this-name prev-name) + (error "Duplicate keyword argument name `~A'." this-name))))) + list)) + +(export 'merge-keyword-lists) +(defun merge-keyword-lists (lists) + "Return the union of keyword argument lists. + + The LISTS parameter consists of pairs (ARGS . WHAT), where ARGS is a list + of `argument' objects, and WHAT is either nil or a printable object + describing the origin of the corresponding argument list suitable for + quoting in an error message. + + The resulting list contains exactly one argument for each distinct + argument name appearing in the input lists; this argument will contain the + default value corresponding to the name's earliest occurrence in the input + LISTS. + + If the same name appears in multiple input lists with different types, an + error is signalled; this error will quote the origins of a representative + conflicting pair of arguments." + + ;; The easy way through all of this is with a hash table mapping argument + ;; names to (ARGUMENT . WHAT) pairs. + + (let ((argmap (make-hash-table :test #'equal))) + + ;; Set up the table. When we find a duplicate, check that the types + ;; match. + (dolist (item lists) + (let ((args (car item)) + (what (cdr item))) + (dolist (arg args) + (let* ((name (argument-name arg)) + (other-item (gethash name argmap))) + (if (null other-item) + (setf (gethash name argmap) (cons arg what)) + (let* ((type (argument-type arg)) + (other (car other-item)) + (other-type (argument-type other)) + (other-what (cdr other-item))) + (unless (c-type-equal-p type other-type) + (error "Type mismatch for keyword argument `~A': ~ + ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]." + name + type what + other-type other-what)))))))) + + ;; Now it's just a matter of picking the arguments out again. + (let ((result nil)) + (maphash (lambda (name item) + (declare (ignore name)) + (push (car item) result)) + argmap) + (fix-and-check-keyword-argument-list result)))) + ;; Class definition. (export '(c-function-type c-function-arguments)) @@ -438,13 +511,46 @@ nil arguments)))) +(export '(c-keyword-function-type c-function-keywords)) +(defclass c-keyword-function-type (c-function-type) + ((keywords :initarg :keywords :type list + :reader c-function-keywords)) + (:documentation + "C function types for `functions' which take keyword arguments.")) + +(defmethod shared-initialize :after + ((type c-keyword-function-type) slot-names &key (keywords nil keysp)) + (declare (ignore slot-names)) + (when keysp + (setf (slot-value type 'keywords) + (fix-and-check-keyword-argument-list keywords)))) + ;; Constructor function. (export 'make-function-type) (defun make-function-type (subtype arguments) - "Return a new function type, returning SUBTYPE and accepting ARGUMENTS." - (make-instance 'c-function-type :subtype subtype - :arguments arguments)) + "Return a new function type, returning SUBTYPE and accepting ARGUMENTS. + + As a helper for dealing with the S-expression syntax for keyword + functions, if ARGUMENTS has the form (ARGS ... :keys KEYWORDS ...)' then + return a keyword function with arguments (ARGS ...) and keywords (KEYWORDS + ...)." + (let ((split (member :keys arguments))) + (if split + (make-instance 'c-keyword-function-type + :subtype subtype + :arguments (ldiff arguments split) + :keywords (cdr split)) + (make-instance 'c-function-type + :subtype subtype + :arguments arguments)))) + +(export 'make-keyword-function-type) +(defun make-keyword-function-type (subtype arguments keywords) + "Return a new keyword-function type, returning SUBTYPE and accepting + ARGUMENTS and KEYWORDS." + (make-instance 'c-keyword-function-type :subtype subtype + :arguments arguments :keywords keywords)) ;; Comparison protocol. @@ -454,29 +560,78 @@ (argument-lists-equal-p (c-function-arguments type-a) (c-function-arguments type-b)))) +(defmethod c-type-equal-p and + ((type-a c-keyword-function-type) (type-b c-keyword-function-type)) + ;; Actually, there's nothing to check here. I'm happy as long as both + ;; functions notionally accept keyword arguments. + t) + ;; C syntax output protocol. +(export 'pprint-c-function-type) +(defun pprint-c-function-type (return-type stream print-args print-kernel) + "Common top-level printing for function types. + + Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return + type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and + PRINT-KERNEL functions. + + The PRINT-KERNEL function is the standard such thing for the + `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream." + (pprint-c-type return-type stream + (lambda (stream prio spacep) + (maybe-in-parens (stream (> prio 2)) + (when spacep (c-type-space stream)) + (funcall print-kernel stream 2 nil) + (pprint-indent :block 4 stream) + (pprint-newline :linear stream) + (pprint-logical-block + (stream nil :prefix "(" :suffix ")") + (funcall print-args stream)))))) + +(export 'pprint-argument-list) +(defun pprint-argument-list (args stream) + "Print an argument list. + + The ARGS is a list of `argument' objects, optionally containing an + `:ellipsis' marker. The output is written to STREAM. + + Returns non-nil if any arguments were actually printed." + (let ((anyp nil)) + (pprint-logical-block (stream nil) + (dolist (arg args) + (if anyp + (format stream ", ~_") + (setf anyp t)) + (etypecase arg + ((member :ellipsis) + (write-string "..." stream)) + (argument + (pprint-logical-block (stream nil) + (pprint-c-type (argument-type arg) stream (argument-name arg)) + (let ((default (argument-default arg))) + (when default + (format stream " = ~2I~_~A" default)))))))) + anyp)) + (let ((void-arglist (list (make-argument nil c-type-void)))) (defmethod pprint-c-type ((type c-function-type) stream kernel) - (pprint-c-type (c-type-subtype type) stream - (lambda (stream prio spacep) - (maybe-in-parens (stream (> prio 2)) - (when spacep (c-type-space stream)) - (funcall kernel stream 2 nil) - (pprint-indent :block 4 stream) - (pprint-logical-block - (stream nil :prefix "(" :suffix ")") - (let ((firstp t)) - (dolist (arg (or (c-function-arguments type) - void-arglist)) - (if firstp - (setf firstp nil) - (format stream ", ~_")) - (if (eq arg :ellipsis) - (write-string "..." stream) - (pprint-c-type (argument-type arg) - stream - (argument-name arg))))))))))) + (let ((args (or (c-function-arguments type) void-arglist))) + (pprint-c-function-type (c-type-subtype type) stream + (lambda (stream) + (pprint-argument-list args stream)) + kernel)))) + +(defmethod pprint-c-type ((type c-keyword-function-type) stream kernel) + (let ((args (c-function-arguments type)) + (keys (c-function-keywords type))) + (pprint-c-function-type (c-type-subtype type) stream + (lambda (stream) + (when (pprint-argument-list args stream) + (format stream ", ~_")) + (write-char #\? stream) + (pprint-argument-list keys stream)) + kernel))) ;; S-expression notation protocol. @@ -484,21 +639,32 @@ (stream (type c-function-type) &optional colon atsign) (declare (ignore colon atsign)) (format stream "~:@<~ - FUN ~@_~:I~/sod:print-c-type/~ - ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~ + FUN ~@_~:I~ + ~/sod:print-c-type/~:[~; ~]~:*~_~ + ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~ + ~:[~2*~; ~_~S ~@_~<~@{~:<~S ~@_~/sod:print-c-type/~ + ~@[ ~@_~S~]~:>~^ ~_~}~:>~]~ ~:>" (c-type-subtype type) (mapcar (lambda (arg) (if (eq arg :ellipsis) arg (list (argument-name arg) (argument-type arg)))) - (c-function-arguments type)))) + (c-function-arguments type)) + (typep type 'c-keyword-function-type) + :keys + (and (typep type 'c-keyword-function-type) + (mapcar (lambda (arg) + (list (argument-name arg) + (argument-type arg) + (argument-default arg))) + (c-function-keywords type))))) (export '(fun function () func fn)) (define-c-type-syntax fun (ret &rest args) "Return the type of functions which returns RET and has arguments ARGS. - The ARGS are a list of arguments of the form (NAME TYPE). The NAME can be - NIL to indicate that no name was given. + The ARGS are a list of arguments of the form (NAME TYPE [DEFAULT]). The + NAME can be NIL to indicate that no name was given. If an entry isn't a list, it's assumed to be the start of a Lisp expression to compute the tail of the list; similarly, if the list is @@ -516,16 +682,21 @@ `(make-function-type ,(expand-c-type-spec ret) ,(do ((args args (cdr args)) (list nil - (cons `(make-argument ,(caar args) - ,(expand-c-type-spec - (cadar args))) - list))) - ((or (atom args) (atom (car args))) + (if (keywordp (car args)) + (cons (car args) list) + (let* ((name (caar args)) + (type (expand-c-type-spec + (cadar args))) + (default (and (cddar args) + (caddar args))) + (arg `(make-argument + ,name ,type ,default))) + (cons arg list))))) + ((or (atom args) + (and (atom (car args)) + (not (keywordp (car args))))) (cond ((and (null args) (null list)) `nil) ((null args) `(list ,@(nreverse list))) - ((and (consp args) - (eq (car args) :ellipsis)) - `(list ,@(nreverse list) :ellipsis)) ((null list) `,args) (t `(list* ,@(nreverse list) ,args))))))) (c-type-alias fun function () func fn) @@ -541,7 +712,8 @@ (mapcar (lambda (arg) (if (eq arg :ellipsis) arg (make-argument (commentify-argument-name (argument-name arg)) - (argument-type arg)))) + (argument-type arg) + (argument-default arg)))) arguments)) (export 'commentify-function-type) @@ -553,4 +725,11 @@ (commentify-argument-names (c-function-arguments type)))) +(export 'reify-variable-argument-tail) +(defun reify-variable-argument-tail (arguments) + "Replace any `:ellipsis' item in ARGUMENTS with a `va_list' argument. + + The argument's name is taken from the variable `*sod-ap*'." + (substitute (make-argument *sod-ap* c-type-va-list) :ellipsis arguments)) + ;;;----- That's all, folks --------------------------------------------------