summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MLKCons.h15
-rw-r--r--MLKCons.m46
-rw-r--r--MLKInterpreter.m48
-rw-r--r--MLKPackage.m1
-rw-r--r--MLKRoot.m17
-rw-r--r--defun-1.lisp28
-rw-r--r--functions.h2
-rw-r--r--functions.m49
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;
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-12 23:23:23 +0000