From 9186189b62240acdae1f3bd6d4146cec00cddda3 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Mon, 28 Jul 2008 01:18:23 +0200
Subject: Add PRIMITIVE-TYPE-OF.

---
 MLKPackage.m |  1 +
 MLKRoot.m    | 39 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 40 insertions(+)

diff --git a/MLKPackage.m b/MLKPackage.m
index 93dece3..c57dd7d 100644
--- a/MLKPackage.m
+++ b/MLKPackage.m
@@ -124,6 +124,7 @@ static NSMutableDictionary *packages = nil;
   [sys export:[sys intern:@"FIND-OBJC-CLASS"]];
   [sys export:[sys intern:@"NS-LOG"]];
   [sys export:[sys intern:@"SYMBOL-NAME"]];
+  [sys export:[sys intern:@"PRIMITIVE-TYPE-OF"]];
 
   [cl export:[cl intern:@"*BREAK-ON-SIGNALS*"]];
   [cl export:[cl intern:@"*COMPILE-FILE-PATHNAME*"]];
diff --git a/MLKRoot.m b/MLKRoot.m
index 07cfe5f..3ad0f01 100644
--- a/MLKRoot.m
+++ b/MLKRoot.m
@@ -17,8 +17,10 @@
  */
 
 #import "MLKBinding.h"
+#import "MLKCharacter.h"
 #import "MLKCons.h"
 #import "MLKDynamicContext.h"
+#import "MLKInterpretedClosure.h"
 #import "MLKInterpreter.h"
 #import "MLKNumber.h"
 #import "MLKPackage.h"
@@ -452,4 +454,41 @@ static id truify (BOOL value)
   MLKSymbol *symbol = denullify ([args objectAtIndex:0]);
   RETURN_VALUE (symbol ? (id)[symbol name] : (id)@"NIL");
 }
+
++(NSArray *) primitive_type_of:(NSArray *)args
+{
+  id object = denullify ([args objectAtIndex:0]);
+
+  if (!object)
+    { RETURN_VALUE ([cl intern:@"NULL"]); }
+  else if ([object isKindOfClass:[MLKSymbol class]])
+    { RETURN_VALUE ([cl intern:@"SYMBOL"]); }
+  else if ([object isKindOfClass:[MLKCons class]])
+    { RETURN_VALUE ([cl intern:@"CONS"]); }
+  else if ([object isKindOfClass:[MLKDoubleFloat class]])
+    { RETURN_VALUE ([cl intern:@"DOUBLE-FLOAT"]); }
+  else if ([object isKindOfClass:[MLKSingleFloat class]])
+    { RETURN_VALUE ([cl intern:@"SINGLE-FLOAT"]); }
+  else if ([object isKindOfClass:[MLKInteger class]])
+    { RETURN_VALUE ([cl intern:@"INTEGER"]); }
+  else if ([object isKindOfClass:[MLKCharacter class]])
+    //FIXME: STANDARD-CHAR
+    { RETURN_VALUE ([cl intern:@"BASE-CHAR"]); }
+  else if ([object isKindOfClass:[MLKInterpretedClosure class]])
+    { RETURN_VALUE ([cl intern:@"FUNCTION"]); }
+  else if ([object isKindOfClass:[MLKLexicalContext class]])
+    { RETURN_VALUE ([sys intern:@"LEXICAL-CONTEXT"]); }
+  else if ([object isKindOfClass:[MLKBinding class]])
+    { RETURN_VALUE ([sys intern:@"BINDING"]); }
+  else if ([object isKindOfClass:[MLKPackage class]])
+    { RETURN_VALUE ([cl intern:@"PACKAGE"]); }
+  else if ([object isKindOfClass:[MLKStream class]])
+    { RETURN_VALUE ([cl intern:@"STREAM"]); }
+  else if ([object isKindOfClass:[NSException class]])
+    { RETURN_VALUE ([sys intern:@"EXCEPTION"]); }
+  else if ([object isKindOfClass:[NSArray class]])
+    { RETURN_VALUE ([cl intern:@"ARRAY"]); }
+  else
+    { RETURN_VALUE ([cl intern:@"T"]); }
+}
 @end
-- 
cgit v1.2.3