src/class-finalize-impl.lisp: Overhaul `check-sod-class', `compute-chains'.

[sod] / src / c-types-impl.lisp

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index a27b30f8b6afbbe94269069c7ced0e0a5adcb1c6..6b7c9042a5f2fa863801111e76f93799d3fa109a 100644 (file)
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -35,7 +35,22 @@ (defparameter *c-type-intern-map* (make-hash-table :test #'equal)
 (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
@@ -192,7 +207,7 @@ (defmethod pprint-c-type ((type simple-c-type) stream kernel)
 
 ;; 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)
@@ -211,12 +226,23 @@   (defmethod expand-c-type-form ((head string) tail)
 (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.
 
@@ -250,7 +276,7 @@ (define-simple-c-type float "float" :export t)
 (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)
@@ -302,7 +328,7 @@ (macrolet ((define-tagged-type (kind what)
               `(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)))
@@ -559,7 +585,7 @@ (defun fix-and-check-keyword-argument-list (list)
        (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)
@@ -601,7 +627,7 @@ (defun merge-keyword-lists (lists)
                       (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)~]."
+                           ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]"
                           name
                           type what
                           other-type other-what))))))))