Fix the case of generated symbol names.

glib/cl-cffi-gtk-glib.asd

@@ -47,6 +47,7 @@
                (:file "glib.random")         ; Pseudo-random number generator
               )
   :depends-on (:cffi
+               :alexandria
                :iterate
                :trivial-features))
 

glib/glib.init.lisp

@@ -132,10 +132,8 @@
                  `(when (or (and (= ,major-version-var ,major)
                                  (>= ,minor-version-var ,minor))
                             (> ,major-version-var ,major))
-                    (pushnew ,(intern (format nil "~A-~A-~A"
-                                              (string library-name)
-                                              major minor)
-                                      (find-package :keyword))
+                    (pushnew ,(format-symbol
+                               :keyword "~A-~A-~A" library-name major minor)
                              *features*))))))
 
 (define-condition foreign-library-minimum-version-mismatch (error)

glib/glib.package.lisp

@@ -27,6 +27,7 @@
 
 (defpackage :glib
   (:use :cl :cffi :iter)
+  (:import-from :alexandria :format-symbol)
   (:export ;; Symbols from glib.stable-pointer.lisp
            #:allocate-stable-pointer
            #:get-stable-pointer-value

gobject/cl-cffi-gtk-gobject.asd

@@ -57,6 +57,7 @@
   :depends-on (:cl-cffi-gtk-glib
                :cffi
                :trivial-garbage
+               :alexandria
                :iterate
                :bordeaux-threads
                :closer-mop))

gobject/gobject.boxed-lisp.lisp

@@ -82,12 +82,10 @@
 ;; Helper functions to create an internal symbol
 
 (defun generated-cstruct-name (symbol)
-  (intern (format nil "~A-CSTRUCT" (symbol-name symbol))
-          (symbol-package symbol)))
+  (format-symbol (symbol-package symbol) "~A-CSTRUCT" symbol))
 
 (defun generated-cunion-name (symbol)
-  (intern (format nil "~A-CUNION" (symbol-name symbol))
-          (symbol-package symbol)))
+  (format-symbol (symbol-package symbol) "~A-CUNION" symbol))
 
 ;;; ----------------------------------------------------------------------------
 
@@ -330,8 +328,7 @@
                (gethash ,gtype *g-type-name->g-boxed-foreign-info*)
                (get ',name 'g-boxed-foreign-info)
                (get ',name 'structure-constructor)
-               ',(intern (format nil "MAKE-~A" (symbol-name name))
-                         (symbol-package name)))))))
+               ',(format-symbol (symbol-package name) "MAKE-~A" name))))))
 
 ;;; ----------------------------------------------------------------------------
 
@@ -594,8 +591,7 @@
                  (collect `(,(cstruct-slot-description-name slot)
                              ,(cstruct-slot-description-initform slot)))))
        (setf (get ',name 'structure-constructor)
-             ',(intern (format nil "MAKE-~A" (symbol-name name))
-                       (symbol-package name))))))
+             ',(format-symbol (symbol-package name) "MAKE-~A" name)))))
 
 (defun generate-structures (str)
   (iter (for variant in (reverse (all-structures str)))
@@ -860,14 +856,12 @@
       (g-boxed-cstruct-wrapper-info
        (append
          (list name
-               (intern (format nil "MAKE-~A" (symbol-name name)))
-               (intern (format nil "COPY-~A" (symbol-name name))))
+               (format-symbol t "MAKE-~A" name)
+               (format-symbol t "COPY-~A" name))
          (iter (for slot in (cstruct-description-slots
                               (g-boxed-cstruct-wrapper-info-cstruct-description info)))
                (for slot-name = (cstruct-slot-description-name slot))
-               (collect (intern (format nil "~A-~A"
-                                        (symbol-name name)
-                                        (symbol-name slot-name)))))))
+               (collect (format-symbol t "~A-~A" name slot-name)))))
       (g-boxed-opaque-wrapper-info
        (list name))
       (g-boxed-variant-cstruct-info
@@ -878,13 +872,13 @@
                (for cstruct-description = (var-structure-resulting-cstruct-description var-struct))
                (appending (append
                             (list s-name)
-                            (list (intern (format nil "MAKE-~A" (symbol-name s-name)))
-                                  (intern (format nil "COPY-~A" (symbol-name s-name))))
+                            (list (format-symbol t "MAKE-~A" s-name)
+                                  (format-symbol t "COPY-~A" s-name))
                             (iter (for slot in (cstruct-description-slots cstruct-description))
                                   (for slot-name = (cstruct-slot-description-name slot))
-                                  (collect (intern (format nil "~A-~A"
-                                                           (symbol-name s-name)
-                                                           (symbol-name slot-name)))))))))))))
+                                  (collect (format-symbol t "~A-~A"
+                                                          s-name
+                                                          slot-name)))))))))))
 
 ;;; ----------------------------------------------------------------------------
 

gobject/gobject.foreign-gobject-subclassing.lisp

@@ -283,12 +283,10 @@
   (iter (for item in items)
         (when (eq :skip (first item)) (next-iteration))
         (destructuring-bind (name (return-type &rest args) &key impl-call) item
-          (for method-name = (intern (format nil "~A-~A-IMPL"
-                                             (symbol-name iface-name)
-                                             (symbol-name name))))
-          (for callback-name = (intern (format nil "~A-~A-CALLBACK"
-                                               (symbol-name iface-name)
-                                               (symbol-name name))))
+          (for method-name = (format-symbol t "~A-~A-IMPL"
+                                            iface-name name))
+          (for callback-name = (format-symbol t "~A-~A-CALLBACK"
+                                              iface-name name))
           (collect (make-vtable-method-info :slot-name name
                                             :name method-name
                                             :return-type return-type
@@ -304,7 +302,7 @@
   methods)
 
 (defmacro define-vtable ((type-name name) &body items)
-  (let ((cstruct-name (intern (format nil "~A-VTABLE" (symbol-name name))))
+  (let ((cstruct-name (format-symbol t "~A-VTABLE" name))
         (methods (vtable-methods name items)))
     `(progn
        (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items))

gobject/gobject.generating.lisp

@@ -135,10 +135,8 @@
 (defvar *strip-prefix* "")
 
 (defun accessor-name (class-name property-name)
-  (intern (format nil "~A-~A"
-                      (symbol-name class-name)
-                      (lispify-name property-name))
-          *lisp-name-package*))
+  (format-symbol *lisp-name-package*
+                 "~A-~A" class-name (lispify-name property-name)))
 
 (defun lispify-name (name)
   (with-output-to-string (stream)
@@ -226,10 +224,10 @@
      :g-property-type ,(if (gobject-property-p property)
                            (gobject-property-type property)
                            (cffi-property-type property))
-     :accessor ,(intern (format nil "~A-~A"
-                                (symbol-name class-name)
-                                (property-name property))
-                        (symbol-package class-name))
+     :accessor ,(format-symbol (symbol-package class-name)
+                               "~A-~A"
+                               class-name
+                               (property-name property))
      ,@(when (if (gobject-property-p property)
                  t
                  (not (null (cffi-property-writer property))))
@@ -267,10 +265,10 @@
                          (find-package
                            ,(package-name (symbol-package name))))
                (mapcar (lambda (property)
-                         `(export ',(intern (format nil "~A-~A"
-                                                       (symbol-name name)
-                                                       (property-name property))
-                                              (symbol-package name))
+                         `(export ',(format-symbol (symbol-package name)
+                                                   "~A-~A"
+                                                   name
+                                                   (property-name property))
                                    (find-package
                                      ,(package-name (symbol-package name)))))
                         properties)))))
@@ -294,12 +292,10 @@
          (cons `(export ',name
                         (find-package ,(package-name (symbol-package name))))
                (mapcar (lambda (property)
-                         `(export ',(intern (format nil "~A-~A"
-                                                    (symbol-name name)
-                                                    (property-name property))
-                                            (symbol-package name))
-                                  (find-package
-                                   ,(package-name (symbol-package name)))))
+                         `(export ',(format-symbol (symbol-package name)
+                                                   "~A-~A"
+                                                   name
+                                                   (property-name property))))
                        properties)))
      (eval-when (:compile-toplevel :load-toplevel :execute)
        (setf (gethash ,g-type-name *known-interfaces*) ',name))))

gobject/gobject.init.lisp

@@ -59,9 +59,7 @@
   (let ((vars (iter (for sym in (if (listp categories)
                                     categories
                                     (list categories)))
-                    (collect (intern (format nil "*DEBUG-~A*"
-                                             (symbol-name sym))
-                                     (find-package :gobject))))))
+                    (collect (format-symbol :gobject "*DEBUG-~A*" sym)))))
     `(progn
        (when (or ,@vars)
          (format *debug-stream* ,control-string ,@args))

gobject/gobject.object-function.lisp

@@ -33,8 +33,7 @@
 
 (defmacro define-cb-methods (name return-type (&rest args))
   (flet ((make-name (control-string)
-           (intern (format nil control-string (symbol-name name))
-                   (symbol-package name))))
+           (format-symbol (symbol-package name) control-string name)))
     (let ((call-cb (make-name "~A-CB"))
           (destroy-cb (make-name "~A-DESTROY-NOTIFY"))
           (object (gensym "OBJECT"))

gobject/gobject.package.lisp

@@ -33,6 +33,7 @@
 (defpackage :gobject
   (:nicknames :g)
   (:use :c2cl :glib :cffi :tg :bordeaux-threads :iter :closer-mop)
+  (:import-from :alexandria :format-symbol)
   (:export
     #:*lisp-name-exceptions*
 

gtk/cl-cffi-gtk.asd

@@ -313,6 +313,7 @@
                :cl-cffi-gtk-cairo
                :cffi
                :bordeaux-threads
+               :alexandria
                :iterate
                :trivial-features))
 

gtk/gtk.child-properties.lisp

@@ -74,10 +74,10 @@
              (list `(export ',property-name)))))
 
 (defun child-property-name (type-name property-name package-name)
-  (intern (format nil "~A-CHILD-~A"
-                  (symbol-name (registered-object-type-by-name type-name))
-                  (string-upcase property-name))
-          (find-package package-name)))
+  (format-symbol package-name
+                 "~A-CHILD-~A"
+                 (registered-object-type-by-name type-name)
+                 (string-upcase property-name)))
 
 (defun generate-child-properties (&optional (type-root "GtkContainer") (package-name "GTK"))
   (setf type-root (gtype type-root))

gtk/gtk.package.lisp

@@ -41,6 +41,7 @@
 (defpackage :gtk
   (:use :cl :cl-user :cffi
    :gobject :gdk :gdk-pixbuf :glib :gio :pango :cairo :iter :bordeaux-threads)
+  (:import-from :alexandria :format-symbol)
   (:export #:cl-cffi-gtk-build-info))
 
 (in-package :gtk)