(defun intern-c-type (class &rest initargs)
"If the CLASS and INITARGS have already been interned, then return the
existing object; otherwise make a new one."
- (let ((list (cons class initargs)))
+ (let ((list (cons (typecase class
+ ;; Canonify the class object; we'd prefer a name.
+ (standard-class (class-name class))
+ (t class))
+ (let ((alist nil) (plist initargs))
+ ;; Canonify the initargs. Arrange for them to be in
+ ;; ascending order by name. This is annoying because
+ ;; a plist isn't a readily sortable sequence.
+ (loop
+ (when (null plist) (return))
+ (let ((name (pop plist)) (value (pop plist)))
+ (push (cons name value) alist)))
+ (dolist (assoc (sort alist #'string> :key #'car))
+ (push (cdr assoc) plist)
+ (push (car assoc) plist))
+ plist))))
(or (gethash list *c-type-intern-map*)
(let ((new (apply #'make-instance class initargs)))
(setf (gethash new *c-type-intern-map*) t
;; S-expression notation protocol.
-(defparameter *simple-type-map* (make-hash-table)
+(defparameter *simple-type-map* (make-hash-table :test #'equal)
"Hash table mapping strings of C syntax to symbolic names.")
(defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
(export 'define-simple-c-type)
(defmacro define-simple-c-type (names type &key export)
"Define each of NAMES to be a simple type called TYPE."
- (let ((names (if (listp names) names (list names))))
- `(progn
- (setf (gethash ,type *simple-type-map*) ',(car names))
- (defctype ,names ,type :export ,export)
- (define-c-type-syntax ,(car names) (&rest quals)
- `(make-simple-type ,',type (list ,@quals))))))
+ (let ((names (if (listp names) names (list names)))
+ (types (if (listp type) type (list type))))
+ (with-gensyms (type name)
+ `(progn
+ (dolist (,type ',types)
+ (setf (gethash ,type *simple-type-map*) ',(car names)))
+ (dolist (,name ',names)
+ (setf (gethash ,name *simple-type-map*) ,(car types)))
+ (defctype ,names ,(car types) :export ,export)
+ (define-c-type-syntax ,(car names) (&rest quals)
+ `(make-simple-type ,',(car types) (list ,@quals)))))))
+
+(export 'find-simple-c-type)
+(defun find-simple-c-type (name)
+ "Return the `simple-c-type' with the given NAME, or nil."
+ (aand (gethash name *simple-type-map*)
+ (make-simple-type (gethash it *simple-type-map*))))
;; Built-in C types.
(define-simple-c-type double "double" :export t)
(define-simple-c-type long-double "long double" :export t)
-(define-simple-c-type bool "_Bool" :export t)
+(define-simple-c-type bool ("_Bool" "bool") :export t)
(define-simple-c-type float-complex "float _Complex" :export t)
(define-simple-c-type double-complex "double _Complex" :export t)
`(progn
(export '(,type ,kind ,constructor))
(defclass ,type (tagged-c-type) ()
- (:documentation ,(format nil "C ~a types." what)))
+ (:documentation ,(format nil "C ~A types." what)))
(defmethod c-tagged-type-kind ((type ,type))
',keyword)
(defmethod kind-c-tagged-type ((kind (eql ',keyword)))
(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)))))
+ (error "Duplicate keyword argument name `~A'" this-name)))))
list))
(export 'merge-keyword-lists)
-(defun merge-keyword-lists (lists)
+(defun merge-keyword-lists (whatfn 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 WHATFN is either nil or a designator for a function (see below).
+
+ The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is
+ either nil or a designator for a function (see below); and and ARGS is a
+ list of `argument' objects.
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."
+ If the same name appears in multiple input lists with different types, a
+ continuable error is signalled.
+
+ The WHATFN function is given no arguments, and is expected to return a
+ file location (or other object convertible with `file-location'), and a
+ string (or other printable object) describing the site at which the
+ keyword argument lists are being merged or nil; a mismatch error will be
+ reported as being at the location returned by WHATFN, and the description
+ will be included in the error message. A nil WHATFN is equivalent to a
+ function which returns a nil location and description, though this is
+ considered poor practice.
+
+ The REPORTFN is given a single argument ARG, which is one of the
+ conflicting `argument' objects found in the REPORTFN's corresponding
+ argument list: the REPORTFN is expected to issue additional `info'
+ messages to help the user diagnose the problem. The (common) name of the
+ argument has already been reported. A nil REPORTFN is equivalent to one
+ which does nothing, though this is considered poor practice."
;; The easy way through all of this is with a hash table mapping argument
- ;; names to (ARGUMENT . WHAT) pairs.
+ ;; names to (WHAT . ARG) 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)))
+ (let ((reportfn (car item))
+ (args (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))
+ (setf (gethash name argmap) (cons reportfn arg))
(let* ((type (argument-type arg))
- (other (car other-item))
- (other-type (argument-type other))
- (other-what (cdr other-item)))
+ (other-reportfn (car other-item))
+ (other (cdr other-item))
+ (other-type (argument-type other)))
(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))))))))
+ (multiple-value-bind (floc desc)
+ (if whatfn (funcall whatfn) (values nil nil))
+ (cerror*-with-location floc
+ "Type mismatch for keyword ~
+ argument `~A'~@[ in ~A~]"
+ name desc)
+ (when reportfn
+ (funcall reportfn arg))
+ (when other-reportfn
+ (funcall other-reportfn other))))))))))
;; 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))
+ (push (cdr item) result))
argmap)
(fix-and-check-keyword-argument-list result))))
~mdw / sod / blobdiff