qf
/
quakeforge
mirror of https://git.code.sf.net/p/quake/quakeforge
0
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Added proper argument number checking to lambdas, a bunch more builtins, 

a few misc optimizations.
This commit is contained in:
Brian Koropoff 2005-05-08 10:37:57 +00:00
parent 2ebd2e0c2a
commit 86606cc627
11 changed files with 242 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ruamoko/scheme/Boolean.r
View File

@ -8,9 +8,9 @@ Boolean falseConstant;
+ (void) initialize
{
trueConstant = [Boolean new];
[trueConstant makeRootCell];
[trueConstant retain];
falseConstant = [Boolean new];
[falseConstant makeRootCell];
[falseConstant retain];
}

4
ruamoko/scheme/CompiledCode.h
View File

@ -20,6 +20,7 @@ typedef struct lineinfo_s lineinfo_t;
Array constants;
instruction_t [] code;
lineinfo_t [] lineinfo;
integer minargs, size;
}
- (void) addInstruction: (Instruction) inst;
- (integer) addConstant: (SchemeObject) c;
@ -27,6 +28,9 @@ typedef struct lineinfo_s lineinfo_t;
- (instruction_t []) code;
- (lineinfo_t []) lineinfo;
- (Frame) literals;
- (integer) minimumArguments;
- (void) minimumArguments: (integer) min;
@end
#endif //__CompiledCode_h

19
ruamoko/scheme/CompiledCode.r
View File

@ -56,6 +56,7 @@
lineinfo[index].sourcefile = symbol([inst source]);
[lineinfo[index].sourcefile retain];
}
size = [instructions count];
[instructions release];
[constants release];
instructions = constants = NIL;
@ -94,7 +95,25 @@
if (code) {
obj_free (code);
}
if (lineinfo) {
local integer i;
for (i = 0; i < size; i++) {
[lineinfo[i].sourcefile release];
}
obj_free (lineinfo);
}
[super dealloc];
}
- (integer) minimumArguments
{
return minargs;
}
- (void) minimumArguments: (integer) min
{
minargs = min;
}
@end

13
ruamoko/scheme/Compiler.r
View File

@ -16,15 +16,15 @@ Symbol letrecSym;
+ (void) initialize
{
lambdaSym = [Symbol forString: "lambda"];
[lambdaSym makeRootCell];
[lambdaSym retain];
quoteSym = [Symbol forString: "quote"];
[quoteSym makeRootCell];
[quoteSym retain];
defineSym = [Symbol forString: "define"];
[defineSym makeRootCell];
[defineSym retain];
ifSym = [Symbol forString: "if"];
[ifSym makeRootCell];
[ifSym retain];
letrecSym = symbol("letrec");
[letrecSym makeRootCell];
[letrecSym retain];
}
+ (id) newWithLambda: (SchemeObject) xp scope: (Scope) sc
@ -52,6 +52,7 @@ Symbol letrecSym;
for (cur = arguments; [cur isKindOfClass: [Cons class]]; cur = [cur cdr]) {
count++;
}
[code minimumArguments: count];
if (cur != [Nil nil]) {
count++;
}
@ -130,7 +131,7 @@ Symbol letrecSym;
if (err) return;
} else if ([[expression car] isKindOfClass: [Symbol class]]) {
index = [code addConstant: [expression car]];
[self emitExpression: [[expression cdr] car]];
[self emitExpression: [[expression cdr] car] flags: 0];
if (err) return;
} else {
err = [Error type: "syntax"

1
ruamoko/scheme/Cons.h
View File

@ -16,5 +16,6 @@
@extern Cons cons (SchemeObject car, SchemeObject cdr);
@extern BOOL isList (SchemeObject ls);
@extern integer length (SchemeObject foo);
#endif //__Cons_h

11
ruamoko/scheme/Cons.r
View File

@ -8,6 +8,17 @@ Cons cons (SchemeObject car, SchemeObject cdr)
return [Cons newWithCar: car cdr: cdr];
}
integer length (SchemeObject foo)
{
local integer len;
for (len = 0; [foo isKindOfClass: [Cons class]]; foo = [foo cdr]) {
len++;
}
return len;
}
BOOL isList (SchemeObject ls)
{
return ls == [Nil nil] ||

10
ruamoko/scheme/Lambda.r
View File

@ -2,7 +2,10 @@
#include "Nil.h"
#include "Symbol.h"
#include "string.h"
#include "Cons.h"
#include "defs.h"
#include "Error.h"
#include "Machine.h"
@implementation Lambda
+ (id) newWithCode: (CompiledCode) c environment: (Frame) e
@ -21,6 +24,13 @@
- (void) invokeOnMachine: (Machine) m
{
[super invokeOnMachine: m];
if (length([m stack]) < [code minimumArguments]) {
[m value: [Error type: "call"
message: sprintf("expected at least %i arguments, received %i",
[code minimumArguments], length([m stack]))
by: m]];
return;
}
[m loadCode: code];
[m environment: env];
[m procedure: self];

2
ruamoko/scheme/Nil.r
View File

@ -8,7 +8,7 @@ Nil one_nil_to_rule_them_all;
+ (void) initialize
{
one_nil_to_rule_them_all = [Nil new];
[one_nil_to_rule_them_all makeRootCell];
[one_nil_to_rule_them_all retain];
}
+ (id) nil

1
ruamoko/scheme/SchemeObject.r
View File

@ -92,7 +92,6 @@ integer checkpoint;
queue_pos = queue_pos.next;
//if (++amount == GC_AMOUNT) return;
}
dprintf("Alloced: %i Freed: %i\n", alloced, freed);
maybe_garbage = not_garbage;
not_garbage_end.next = wait_list;
if (wait_list) {

8
ruamoko/scheme/Symbol.r
View File

@ -35,10 +35,10 @@ Symbol symbol (string str)
rparen = [Symbol forString: ")"];
quote = [Symbol forString: "'"];
dot = symbol(".");
[lparen makeRootCell];
[rparen makeRootCell];
[quote makeRootCell];
[dot makeRootCell];
[lparen retain];
[rparen retain];
[quote retain];
[dot retain];
}
+ (Symbol) forString: (string) s

202
ruamoko/scheme/builtins.r
View File

@ -58,6 +58,102 @@ SchemeObject bi_add (SchemeObject args, Machine m)
return [Number newFromInt: sum];
}
SchemeObject bi_sub (SchemeObject args, Machine m)
{
local integer diff = 0;
local SchemeObject cur;
if (args == [Nil nil]) {
return [Error type: "-"
message: sprintf("expected at least 1 argument")
by: m];
}
cur = [args car];
if (![cur isKindOfClass: [Number class]]) {
return [Error type: "-"
message: sprintf("non-number argument: %s\n",
[cur printForm])
by: m];
}
diff = [(Number) cur intValue];
if ([args cdr] == [Nil nil]) {
return [Number newFromInt: -diff];
}
for (cur = [args cdr]; cur != [Nil nil]; cur = [cur cdr]) {
if (![[cur car] isKindOfClass: [Number class]]) {
return [Error type: "-"
message: sprintf("non-number argument: %s\n",
[[cur car] printForm])
by: m];
}
diff -= [(Number) [cur car] intValue];
}
return [Number newFromInt: diff];
}
SchemeObject bi_mult (SchemeObject args, Machine m)
{
local integer prod = 1;
local SchemeObject cur;
for (cur = args; cur != [Nil nil]; cur = [cur cdr]) {
if (![[cur car] isKindOfClass: [Number class]]) {
return [Error type: "*"
message: sprintf("non-number argument: %s\n",
[[cur car] printForm])
by: m];
}
prod *= [(Number) [cur car] intValue];
}
return [Number newFromInt: prod];
}
SchemeObject bi_div (SchemeObject args, Machine m)
{
local integer frac = 0;
local SchemeObject cur;
if (args == [Nil nil]) {
return [Error type: "/"
message: sprintf("expected at least 1 argument")
by: m];
}
cur = [args car];
if (![cur isKindOfClass: [Number class]]) {
return [Error type: "/"
message: sprintf("non-number argument: %s\n",
[cur printForm])
by: m];
}
frac = [(Number) cur intValue];
if ([args cdr] == [Nil nil]) {
return [Number newFromInt: 1/frac];
}
for (cur = [args cdr]; cur != [Nil nil]; cur = [cur cdr]) {
if (![[cur car] isKindOfClass: [Number class]]) {
return [Error type: "/"
message: sprintf("non-number argument: %s\n",
[[cur car] printForm])
by: m];
}
frac /= [(Number) [cur car] intValue];
}
return [Number newFromInt: frac];
}
SchemeObject bi_cons (SchemeObject args, Machine m)
{
if (!num_args(args, 2)) {
@ -156,26 +252,94 @@ SchemeObject bi_callcc (SchemeObject args, Machine m)
[[args car] invokeOnMachine: m];
return NIL;
}
SchemeObject bi_eq (SchemeObject args, Machine m)
{
if (!num_args(args, 2)) {
return [Error type: "eq?"
message: "expected 2 arguments"
by: m];
}
return
[args car] == [[args cdr] car] ?
[Boolean trueConstant] :
[Boolean falseConstant];
}
SchemeObject bi_numeq (SchemeObject args, Machine m)
{
local SchemeObject num1, num2;
if (!num_args(args, 2)) {
return [Error type: "="
message: "expected 2 arguments"
by: m];
}
num1 = [args car];
num2 = [[args cdr] car];
if (![num1 isKindOfClass: [Number class]]) {
return [Error type: "="
message: sprintf("expected number argument, got: %s",
[num1 printform])
by: m];
} else if (![num2 isKindOfClass: [Number class]]) {
return [Error type: "="
message: sprintf("expected number argument, got: %s",
[num2 printform])
by: m];
}
return
[num1 intValue] == [num2 intValue] ?
[Boolean trueConstant] :
[Boolean falseConstant];
}
SchemeObject bi_islist (SchemeObject args, Machine m)
{
if (!num_args(args, 1)) {
return [Error type: "list?"
message: "expected 1 argument"
by: m];
}
return
isList (args) ?
[Boolean trueConstant] :
[Boolean falseConstant];
}
SchemeObject bi_ispair (SchemeObject args, Machine m)
{
if (!num_args(args, 1)) {
return [Error type: "pair?"
message: "expected 1 argument"
by: m];
}
return
[[args car] isKindOfClass: [Cons class]] ?
[Boolean trueConstant] :
[Boolean falseConstant];
}
#define builtin(name, func) [m addGlobal: symbol(#name) value: [Primitive newFromFunc: (func)]]
void builtin_addtomachine (Machine m)
{
[m addGlobal: symbol("display")
value: [Primitive newFromFunc: bi_display]];
[m addGlobal: symbol("newline")
value: [Primitive newFromFunc: bi_newline]];
[m addGlobal: symbol("+")
value: [Primitive newFromFunc: bi_add]];
[m addGlobal: symbol("cons")
value: [Primitive newFromFunc: bi_cons]];
[m addGlobal: symbol("null?")
value: [Primitive newFromFunc: bi_null]];
[m addGlobal: symbol("car")
value: [Primitive newFromFunc: bi_car]];
[m addGlobal: symbol("cdr")
value: [Primitive newFromFunc: bi_cdr]];
[m addGlobal: symbol("apply")
value: [Primitive newFromFunc: bi_apply]];
[m addGlobal: symbol("call-with-current-continuation")
value: [Primitive newFromFunc: bi_callcc]];
builtin(display, bi_display);
builtin(newline, bi_newline);
builtin(+, bi_add);
builtin(-, bi_sub);
builtin(*, bi_mult);
builtin(/, bi_div);
builtin(cons, bi_cons);
builtin(null?, bi_null);
builtin(car, bi_car);
builtin(cdr, bi_cdr);
builtin(apply, bi_apply);
builtin(call-with-current-continuation, bi_callcc);
builtin(eq?, bi_eq);
builtin(=, bi_numeq);
builtin(list?, bi_islist);
builtin(pair?, bi_ispair);
}