Centralise declaration and documentation string handling.

8 files changed, 153 insertions, 53 deletions

diff --git a/MLKCons.h b/MLKCons.h
index 2d9f31b..3d17ff5 100644
--- a/MLKCons.h
+++ b/MLKCons.h
@@ -37,14 +37,19 @@
 -(void) setCar:(id)value;
 -(void) setCdr:(id)value;
 
--(NSArray *)array;
+-(NSArray *) array;
 
--(NSString *)bareDescriptionForLisp;  // description without
-                                      // parentheses, for internal use
-                                      // only
--(NSString *)descriptionForLisp;
+-(void) appendObject:(id)object;
+-(MLKCons *) listByAppendingObject:(id)object;
+-(MLKCons *) copyList;
+
+-(NSString *) bareDescriptionForLisp;  // description without
+                                       // parentheses, for internal use
+                                       // only
+-(NSString *) descriptionForLisp;
 
 -(id) copyWithZone:(NSZone *)zone;
+-(BOOL) isEqual:(id)object;
   
 -(void) dealloc;
 @end
diff --git a/MLKCons.m b/MLKCons.m
index ba543b9..67aba08 100644
--- a/MLKCons.m
+++ b/MLKCons.m
@@ -98,7 +98,42 @@
   return array;
 }
 
--(NSString *)bareDescriptionForLisp
+-(void) appendObject:(id)object
+{
+  MLKCons *rest;
+
+  rest = self;
+  while (rest->_cdr)
+    {
+      rest = rest->_cdr;
+    }
+
+  LASSIGN (rest->_cdr, object);
+}
+
+-(MLKCons *) listByAppendingObject:(id)object
+{
+  MLKCons *rest = _cdr;
+  MLKCons *new_list = [MLKCons cons:_car with:nil];
+  MLKCons *tail = new_list;
+
+  while (rest)
+    {
+      LASSIGN (tail->_cdr, [MLKCons cons:rest->_car with:nil]);
+      tail = tail->_cdr;
+    }
+
+  LASSIGN (tail->_cdr, object);
+
+  return new_list;
+}
+
+-(MLKCons *) copyList
+{
+  return [self listByAppendingObject:nil];
+}
+
+-(NSString *) bareDescriptionForLisp
 {
   if (!_cdr)
     return [NSString stringWithFormat:@"%@",
@@ -130,6 +165,15 @@
     return [NSString stringWithFormat:@"(%@)", [self bareDescriptionForLisp]];
 }
 
+-(BOOL) isEqual:(id)object
+{
+  if ([object isKindOfClass:[MLKCons class]])
+    return ([((MLKCons*)object)->_car isEqual:_car]
+            && [((MLKCons*)object)->_cdr isEqual:_cdr]);
+  else
+    return NO;
+}
+
 -(id) copyWithZone:(NSZone *)zone
 {
   MLKCons *copy = [MLKCons allocWithZone:zone];
diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index 1dd5e6b..159de2a 100644
--- a/MLKInterpreter.m
+++ b/MLKInterpreter.m
@@ -633,25 +633,14 @@ static MLKSymbol *MULTIPLE_VALUE_CALL;
             }
           else if (car == _MACROLET)
             {
-              id declarations;
+              id declarations, doc;
               id clauses;
               id body;
               NSArray *result;
               MLKLexicalContext *ctx;
 
-              body = [[program cdr] cdr];
-
-              if ([[body car] isKindOfClass:[MLKCons class]]
-                  && [[body car] car] == DECLARE)
-                {
-                  declarations = [[body car] cdr];
-                  body = [body cdr];
-                }
-              else
-                {
-                  declarations = nil;
-                }
-
+              MLKSplitDeclarationsDocAndForms (&declarations, &doc, &body,
+                                               [[program cdr] cdr]);
               ctx = LAUTORELEASE ([[MLKLexicalContext alloc]
                                    initWithParent:context
                                    variables:nil
@@ -704,7 +693,7 @@ static MLKSymbol *MULTIPLE_VALUE_CALL;
             }
           else if (car == _FLET)
             {
-              id declarations;
+              id declarations, doc;
               id clauses;
               NSMutableArray *new_clauses;
               id body;
@@ -712,18 +701,8 @@ static MLKSymbol *MULTIPLE_VALUE_CALL;
               MLKLexicalContext *ctx;
               MLKLexicalEnvironment *env;
 
-              body = [[program cdr] cdr];
-
-              if ([[body car] isKindOfClass:[MLKCons class]]
-                  && [[body car] car] == DECLARE)
-                {
-                  declarations = [[body car] cdr];
-                  body = [body cdr];
-                }
-              else
-                {
-                  declarations = nil;
-                }
+              MLKSplitDeclarationsDocAndForms (&declarations, &doc, &body,
+                                               [[program cdr] cdr]);
 
               ctx = LAUTORELEASE ([[MLKLexicalContext alloc]
                                    initWithParent:context
@@ -790,7 +769,7 @@ static MLKSymbol *MULTIPLE_VALUE_CALL;
             }
           else if (car == LET)
             {
-              id declarations;
+              id declarations, doc;
               id clauses;
               id body;
               NSArray *result;
@@ -799,17 +778,8 @@ static MLKSymbol *MULTIPLE_VALUE_CALL;
               MLKLexicalEnvironment *env;
               MLKDynamicContext *dynctx;
 
-              body = [[program cdr] cdr];
-              if ([[body car] isKindOfClass:[MLKCons class]]
-                  && [[body car] car] == DECLARE)
-                {
-                  declarations = [[body car] cdr];
-                  body = [body cdr];
-                }
-              else
-                {
-                  declarations = nil;
-                }
+              MLKSplitDeclarationsDocAndForms (&declarations, &doc, &body,
+                                               [[program cdr] cdr]);
 
               ctx = LAUTORELEASE ([[MLKLexicalContext alloc]
                                    initWithParent:context
diff --git a/MLKPackage.m b/MLKPackage.m
index b83eef6..2d14ef5 100644
--- a/MLKPackage.m
+++ b/MLKPackage.m
@@ -135,6 +135,7 @@ static NSMutableDictionary *packages = nil;
   [sys export:[sys intern:@"INTERN"]];
   [sys export:[sys intern:@"SYMBOL-NAME"]];
   [sys export:[sys intern:@"FIXNUM-EQ"]];
+  [sys export:[sys intern:@"DECLARATIONS-AND-DOC-AND-FORMS"]];
 
   [sys export:[sys intern:@"OBJC-CLASS-OF"]];
   [sys export:[sys intern:@"OBJC-SUBCLASSP"]];
diff --git a/MLKRoot.m b/MLKRoot.m
index 8add77e..f726841 100644
--- a/MLKRoot.m
+++ b/MLKRoot.m
@@ -624,4 +624,21 @@ as provided by method %@ of object %@",
       RETURN_VALUE (MLKLispValueWithForeignValue (returnValue, returnType));
     }
 }
+
+
++(NSArray *) declarations_and_doc_and_forms:(NSArray *)args
+{
+  id decls, doc, forms;
+  id bodyAndDecls = denullify ([args objectAtIndex:0]);
+
+  MLKSplitDeclarationsDocAndForms (&decls, &doc, &forms, bodyAndDecls);
+
+  RETURN_VALUE ([MLKCons
+                  cons:decls
+                  with:[MLKCons
+                         cons:doc
+                         with:[MLKCons
+                                cons:forms
+                                with:nil]]]);
+}
 @end
diff --git a/defun-1.lisp b/defun-1.lisp
index 209ee4d..b3496e7 100644
--- a/defun-1.lisp
+++ b/defun-1.lisp
@@ -22,10 +22,16 @@
 
 
 (%defun* make-defun-body (lambda-list body destructuring-p)
-  (let ((lambda-sym (gensym)))
+  (let* ((lambda-sym (gensym))
+         (ddf (declarations-and-doc-and-forms body))
+         (decls (car ddf))
+         (docstring (cadr ddf))
+         (forms (caddr ddf)))
     `(,lambda-sym
+       ,@(when docstring (list docstring))
        (d-b ,lambda-list nil nil ,lambda-sym
-         ,@body))))
+         ,@decls
+         ,@forms))))
 
 (%defmacro* defun (name lambda-list . body)
   `(%defun ,name
@@ -36,12 +42,18 @@
         (lambda-sym (gensym))
         (whole-sym (gensym))
         (env-sym (gensym)))
-    `(,arg-sym
-       (let ((,whole-sym (first ,arg-sym))
-             (,lambda-sym (cdr (first ,arg-sym)))
-             (,env-sym (second ,arg-sym)))
-         (d-b ,lambda-list ,env-sym ,whole-sym ,lambda-sym
-           ,@body)))))
+    (let* ((ddf (declarations-and-doc-and-forms body))
+           (decls (car ddf))
+           (docstring (cadr ddf))
+           (forms (caddr ddf)))
+      `(,arg-sym
+         ,@(when docstring (list docstring))
+         (let ((,whole-sym (first ,arg-sym))
+               (,lambda-sym (cdr (first ,arg-sym)))
+               (,env-sym (second ,arg-sym)))
+           (d-b ,lambda-list ,env-sym ,whole-sym ,lambda-sym
+                ,@decls
+                ,@forms))))))
 
 (%defmacro* defmacro (name lambda-list . body)
   `(%defmacro ,name
diff --git a/functions.h b/functions.h
index 6539b21..7be8eee 100644
--- a/functions.h
+++ b/functions.h
@@ -44,6 +44,8 @@ id MLKSubtractFixnums (id x, id y);
 id MLKIDivideFixnums (id x, id y);
 id MLKMultiplyFixnums (id x, id y);
 
+void MLKSplitDeclarationsDocAndForms (id *decls, id *doc, id *forms, id body);
+
 typedef enum MLKForeignType
 {
   MLKT_PTR,
diff --git a/functions.m b/functions.m
index d74b1fa..895b70b 100644
--- a/functions.m
+++ b/functions.m
@@ -18,6 +18,7 @@
 
 #import "functions.h"
 #import "util.h"
+#import "MLKCons.h"
 #import "MLKCharacter.h"
 #import "MLKInteger.h"
 #import "MLKPackage.h"
@@ -147,6 +148,7 @@ id MLKMultiplyFixnums (id x, id y)
 static MLKSymbol *INT, *SHORT, *LONG, *VOID, *POINTER,
   *UINT, *USHORT, *ULONG, *STRING, *ID, *BOOLEAN, *CLASS, *UNICHAR, *CHAR,
   *ERROR;
+static MLKSymbol *DECLARE;
 static MLKPackage *keyword = nil, *cl = nil;
 
 #define INTERN_KEYWORD(VAR, NAME)               \
@@ -174,6 +176,53 @@ static void init_symbols ()
   INTERN_KEYWORD (CHAR, @"CHAR");
   INTERN_KEYWORD (ERROR, @"ERROR");
   INTERN_KEYWORD (VOID, @"VOID");
+
+  DECLARE = [cl intern:@"DECLARE"];
+}
+
+
+void MLKSplitDeclarationsDocAndForms (id *decls, id *doc, id *forms, id body)
+{
+  id declarations;
+
+  init_symbols ();
+
+  *doc = nil;
+
+  declarations = nil;
+  while (([[body car] isKindOfClass:[MLKCons class]]
+          && [[body car] car] == DECLARE)
+         || [[body car] isKindOfClass:[NSString class]])
+    {
+      id thing = [body car];
+
+      if ([thing isKindOfClass:[NSString class]])
+        {
+          if (*doc)
+            {
+              body = [body cdr];
+              break;
+            }
+          else
+            {
+              *doc = thing;
+            }
+        }
+      else
+        {
+          thing = [thing cdr];
+
+          if (declarations)
+            declarations = [declarations listByAppendingObject:thing];
+          else
+            declarations = thing;
+        }
+
+      body = [body cdr];
+    }
+
+  *decls = declarations;
+  *forms = body;
 }