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/type-handling.lisp | 54 ++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 53 insertions(+), 1 deletion(-)

(limited to 'Lisp/type-handling.lisp')

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