From 7a417274fbc5913ccc288f06842345ff494363df Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Tue, 12 Feb 2008 12:25:45 +0100
Subject: Add function PRINT-TYPESPEC.

darcs-hash:8b64d370e2168812dfd3dea46c02fdffb8461252
---
 Lisp/constant-data.lisp | 37 +++++++++++++++++++++++++++++++++
 Lisp/type-handling.lisp | 54 ++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 90 insertions(+), 1 deletion(-)

diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp
index 85b5584..7c7176d 100644
--- a/Lisp/constant-data.lisp
+++ b/Lisp/constant-data.lisp
@@ -72,6 +72,37 @@
     (complex  . #\j)))
 
 
+(defparameter *objcl-typespec-map*
+  '((id                  . id)
+    (objective-c-class   . class)
+    (exception           . exc)
+    (selector            . sel)
+    (:char               . chr)
+    (:unsigned-char      . uchr)
+    (:short              . sht)
+    (:unsigned-short     . usht)
+    (:int                . int)
+    (:unsigned-int       . uint)
+    (:long               . lng)
+    (:unsigned-long      . ulng)
+    (:long-long          . lng-lng)
+    (:unsigned-long-long . ulng-lng)
+    (:float              . flt)
+    (:double             . dbl)
+    (bit-field           . bfld)
+    (:boolean            . bool)
+    (:void               . void)
+    (:unknown            . undef)
+    (pointer             . ptr)
+    (:string             . charptr)
+    (:atom               . atom)
+    (array               . (ary-b ary-e))
+    (union               . (union-b union-e))
+    (struct              . (struct-b struct-e))
+    (vector              . vector)
+    (complex             . complex)))
+
+
 (defparameter *objcl-type-map*
   '((id       . id)
     (class    . objective-c-class)
@@ -128,3 +159,9 @@
 (declaim (ftype (function (symbol) symbol) type-name->c-type))
 (defun type-name->c-type (type-name)
   (cdr (assoc type-name *objcl-c-type-map*)))
+
+(defun typespec-name->type-name (typespec-name)
+  (cdr (assoc typespec-name *objcl-typespec-map*)))
+
+(defun typespec-name->type-id (typespec-name)
+  (type-name->type-id (typespec-name->type-name typespec-name)))
diff --git a/Lisp/type-handling.lisp b/Lisp/type-handling.lisp
index 58adc7e..e4d15e1 100644
--- a/Lisp/type-handling.lisp
+++ b/Lisp/type-handling.lisp
@@ -220,4 +220,56 @@ Returns: (VALUES typespec byte-position string-position)"
               (setq string-position new-string-pos)
               byte-position)
             #-(or) nil
-            string-position)))
\ No newline at end of file
+            string-position)))
+
+
+(defun print-typespec-to-string (typespec)
+  (with-output-to-string (out)
+    (print-typespec typespec out)))
+
+
+(defun print-typespec (typespec &optional (stream *standard-output*))
+  "Convert a TYPESPEC into a typestring and write the result to a STREAM."
+  (destructuring-bind (type-name modifiers &rest rest)
+      typespec
+    (dolist (modifier modifiers)
+      (format stream "~A" (ecase modifier
+                            (const #\r)
+                            (in #\n)
+                            (inout #\N)
+                            (out #\o)
+                            (bycopy #\O)
+                            (oneway #\V)
+                            (byref #\R)
+                            (opaque ""))))
+    (case type-name
+      ((struct union) (destructuring-bind (name . children) rest
+                        (format stream "~C~A"
+                                (ecase type-name
+                                  (struct #\{)
+                                  (union #\())
+                                name)
+                        (unless (member 'opaque modifiers)
+                          (format stream "=")
+                          (dolist (child children)
+                            (print-typespec child stream)))
+                        (format stream "~C" (ecase type-name
+                                              (struct #\})
+                                              (union #\))))))
+      ((bit-field) (if (eq +runtime-type+ :gnu)
+                       (destructuring-bind (alignment length . children) rest
+                         (format stream "b~D" alignment)
+                         (dolist (child children)
+                           (print-typespec child stream))
+                         (format stream "~D" length))
+                       (destructuring-bind (alignment length . children) rest
+                         (declare (ignore alignment children))
+                         (format stream "b~D" length))))
+      ((array) (destructuring-bind (length . children) rest
+                 (format stream "[~D" length)
+                 (dolist (child children)
+                   (print-typespec child stream))
+                 (format stream "]")))
+      (t (format stream "~A" (typespec-name->type-id type-name))
+         (dolist (child rest)
+           (print-typespec child stream))))))
-- 
cgit v1.2.3