Changeset 6221

Timestamp:

Apr 7, 2007, 9:57:47 PM (18 years ago)

Author:

Gary Byers

Message:

Slight changes (preserve typedef name) in function/objc method arglists.
UNESCAPE-FOREIGN-NAME: handle missing brackets.

File:

• trunk/ccl/lib/db-io.lisp (modified) (10 diffs)

trunk/ccl/lib/db-io.lisp

@@ -567 +567 @@
                           (setf (schar name k)
                                 (schar string (incf i))))
+                        (setq name (escape-foreign-name name))
                         (if (eql ch #\r)
-                          `(:struct ,(escape-foreign-name name))
+                          `(:struct ,name)
                           (if (eql ch #\u)
-                            `(:union ,(escape-foreign-name name))
+                            `(:union ,name)
                             name)))
                       (cdr (assoc ch *arg-spec-encoding*)))))
@@ -894 +895 @@
                  (arg-type ()))
             (multiple-value-setq (class-name p) (%decode-name buf p t))
-            (multiple-value-setq (result-type p) (%decode-type buf p ftd))
+            (multiple-value-setq (result-type p) (%decode-type buf p ftd t))
             (dotimes (i nargs)
-              (multiple-value-setq (arg-type p) (%decode-type buf p ftd))
+              (multiple-value-setq (arg-type p) (%decode-type buf p ftd t))
               (push arg-type arg-types))
             (unless (dolist (m (objc-message-info-methods info))
@@ -1236 +1237 @@
       (break "Type spec = ~s" spec))))
 
-(defun encode-ffi-arg-type (spec &optional return-value-p)
+(defun encode-ffi-arg-type (spec)
   (case (car spec)
     (:primitive
@@ -1281 +1282 @@
            ,@(encode-name (ffi-struct-reference (cadr spec)))))
     (:typedef
-     (let* ((typedef (cadr spec))
-            (type (ffi-typedef-type typedef)))
-       (if (or return-value-p
-               (not (member (car type) '(:struct :union)))
-               #+eabi-target t)
-         (encode-ffi-arg-type type)
-         `(#\t ,@(encode-name (ffi-typedef-name typedef))))))
+     `(#\t ,@(encode-name (ffi-typedef-name (cadr spec)))))
     (:pointer
       `(#\a))
@@ -1309 +1304 @@
     `(,min-args
       ,@(encode-name name t)            ; verbatim
-      ,@(encode-ffi-arg-type result t)
+      ,@(encode-ffi-arg-type result)
       ,@(encode-ffi-arg-list args))))
 
@@ -1440 +1435 @@
                    (string-downcase key)
                    (string key)))
-         (nbrackets (count #\< string)))
-    (declare (fixnum nbrackets))
+         (nleftbrackets (count #\< string))
+         (nrightbrackets (count #\> string))
+         (nbrackets (+ nleftbrackets nrightbrackets)))
+    (declare (fixnum nleftbrackets nrightbrackets nbrackets))
     (if (zerop nbrackets)
       string
-      (let* ((len (length string))
-             (out (make-string (- len (* 2 nbrackets))))
-             (j 0)
-             (state :lower))
-        (dotimes (i len out)
-          (let* ((ch (schar string i)))
-            (if (or (and (eq ch #\<)
-                         (eq state :upper))
-                    (and (eq ch #\>)
-                         (eq state :lower)))
-              (error "Mismatched brackets in ~s." key))
-            (case ch
-              (#\< (setq state :upper))
-              (#\> (setq state :lower))
-              (t (setf (schar out j) (if (eq state :upper)
-                                       (char-upcase ch)
-                                       (char-downcase ch))
-                       j (1+ j))))))))))
+      (if (/= nleftbrackets nrightbrackets)
+        (error "Mismatched brackets in ~s." key)
+        (let* ((len (length string))
+               (out (make-string (- len nbrackets)))
+               (j 0)
+               (state :lower))
+          (dotimes (i len out)
+            (let* ((ch (schar string i)))
+              (if (or (and (eq ch #\<)
+                           (eq state :upper))
+                      (and (eq ch #\>)
+                           (eq state :lower)))
+                (error "Mismatched brackets in ~s." key))
+              (case ch
+                (#\< (setq state :upper))
+                (#\> (setq state :lower))
+                (t (setf (schar out j) (if (eq state :upper)
+                                         (char-upcase ch)
+                                         (char-downcase ch))
+                         j (1+ j)))))))))))
 
         
@@ -1500 +1499 @@
   
 ;; Should return a FOREIGN-TYPE structure.
-(defun %decode-type (buf p ftd)
+(defun %decode-type (buf p ftd &optional suppress-typedef-expansion)
   (declare (type macptr buf) (fixnum p))
   (let* ((q (1+ p)))
@@ -1531 +1530 @@
                                              encoded-type-void)
                                       (values nil (1+ q))
-                                      (%decode-type buf q ftd))
+                                      (%decode-type buf q ftd suppress-typedef-expansion))
                                 (values (make-foreign-pointer-type
                                          :to target
@@ -1551 +1550 @@
                      qqq)))))
       (#.encoded-type-named-type-ref
-       (multiple-value-bind (name qq) (%decode-name buf q)
-         (values (%parse-foreign-type name) qq)))
+       (multiple-value-bind (name qq) (%decode-name buf q)         
+         (values (if suppress-typedef-expansion
+                   name
+                   (%parse-foreign-type name))
+                 qq)))
       (#.encoded-type-named-struct-ref
        (multiple-value-bind (name qq) (%decode-name buf q)
@@ -1725 +1727 @@
       (let* ((r (%load-foreign-record (db-records d) name ftd already)))
         (when r (return r))))))
+
+