summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--apl9.h8
-rw-r--r--array.c15
-rw-r--r--eval.c74
-rw-r--r--functions.c179
-rw-r--r--lexer.c17
-rw-r--r--print.c2
6 files changed, 255 insertions, 40 deletions
diff --git a/apl9.h b/apl9.h
index 24ddc01..d86d659 100644
--- a/apl9.h
+++ b/apl9.h
@@ -12,8 +12,6 @@ typedef enum
BoundFunctionTag, /* Function with left arg bound */
LParTag,
RParTag,
- LBracketTag,
- RBracketTag,
ArrowTag,
AssignmentTag,
NameTag,
@@ -70,6 +68,7 @@ struct Statement
{
int ntoks;
Datum *toks;
+ Statement *guard;
Statement *next;
};
@@ -170,6 +169,7 @@ int commontype(Array *, Array *, Array **, Array **, int);
Array *arrayitem(Array *, int);
Array *simplifyarray(Array *);
int comparearray(Array *, Array *, int);
+Array *fillelement(Array *);
/* eval.c */
Datum *eval(Statement *);
@@ -189,6 +189,7 @@ void incref(Array *);
/* functions.c */
Array *runfunc(Function, Array *,Array *);
+Array *rundfn(Rune *, Array *, Array *);
/* quadnames.c */
Datum quadnamedatum(QuadnameDef);
@@ -196,6 +197,8 @@ Datum quadnamedatum(QuadnameDef);
/* Monadic functions from function.c */
Array *fnSame(Array *);
Array *fnTally(Array *);
+Array *fnMix(Array *);
+Array *fnSplit(Array *);
Array *fnEnclose(Array *);
Array *fnNest(Array *);
Array *fnGradeUp(Array *);
@@ -218,6 +221,7 @@ Array *fnLogarithm(Array *, Array *);
Array *fnLeft(Array *, Array *);
Array *fnRight(Array *, Array *);
Array *fnMatch(Array *, Array *);
+Array *fnTake(Array *, Array *);
Array *fnIndex(Array *, Array *);
Array *fnCatenateFirst(Array *, Array *);
Array *fnReshape(Array *, Array *);
diff --git a/array.c b/array.c
index 1167cea..37cd159 100644
--- a/array.c
+++ b/array.c
@@ -264,4 +264,19 @@ comparearray(Array *a, Array *b, int checkshapes)
return -1;
else
return 0;
+}
+
+Array *
+fillelement(Array *a)
+{
+ switch(a->type){
+ case AtypeInt: return mkscalarint(0);
+ case AtypeFloat: return mkscalarfloat(0);
+ case AtypeRune: return mkscalarrune(' ');
+ case AtypeArray:
+ default:
+ print("Can't make fill element of array type %d\n", a->type);
+ exits(nil);
+ return 0;
+ }
} \ No newline at end of file
diff --git a/eval.c b/eval.c
index 3958a98..7d9afbe 100644
--- a/eval.c
+++ b/eval.c
@@ -21,38 +21,34 @@ Datum monadop(Datum, Datum);
Datum dyadop(Datum, Datum);
Datum *lookup(Datum);
-int bindingstrengths[13][13] = {
-/* A F H MO DO AF ( ) [ ] ← IS N */
- 6, 3, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* A */
- 2, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* F */
- 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* H */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* MO */
- 5, 5, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* DO */
- 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* AF */
- 0, 0, 0, 0, 0, 0, 0, 7, 0, 0, 0, 0, 0, /* ( */
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, /* ) */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* [ */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ] */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ← */
- 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* IS */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 0, 0, /* N */
+int bindingstrengths[11][11] = {
+/* A F H MO DO AF ( ) ← IS N */
+ 6, 3, 0, 4, 0, 0, 0, 0, 0, 0, 0, /* A */
+ 2, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, /* F */
+ 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, /* H */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* MO */
+ 5, 5, 5, 0, 0, 0, 0, 0, 0, 0, 0, /* DO */
+ 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* AF */
+ 0, 0, 0, 0, 0, 0, 0, 7, 0, 0, 0, /* ( */
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, /* ) */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ← */
+ 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* IS */
+ 0, 0, 0, 0, 0, 0, 0, 0, 8, 0, 0, /* N */
};
-evalfn evalfns[13][13] = {
-/* A F H MO DO AF ( ) [ ] ← IS N */
- strand, dyadfun, 0, monadop, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* A */
- monadfun, 0, 0, monadop, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* F */
- 0, 0, 0, monadop, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* H */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* MO */
- dyadop, dyadop, dyadop, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* DO */
- monadfun, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* AF */
- 0, 0, 0, 0, 0, 0, 0, parens, 0, 0, 0, 0, 0, /* ( */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ) */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* [ */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ] */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ← */
- assign, assign, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* IS */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, nameis, 0, 0, /* N */
+evalfn evalfns[11][11] = {
+/* A F H MO DO AF ( ) ← IS N */
+ strand, dyadfun, 0, monadop, 0, 0, 0, 0, 0, 0, 0, /* A */
+ monadfun, 0, 0, monadop, 0, 0, 0, 0, 0, 0, 0, /* F */
+ 0, 0, 0, monadop, 0, 0, 0, 0, 0, 0, 0, /* H */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* MO */
+ dyadop, dyadop, dyadop, 0, 0, 0, 0, 0, 0, 0, 0, /* DO */
+ monadfun, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* AF */
+ 0, 0, 0, 0, 0, 0, 0, parens, 0, 0, 0, /* ( */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ) */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* ← */
+ assign, assign, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* IS */
+ 0, 0, 0, 0, 0, 0, 0, 0, nameis, 0, 0, /* N */
};
Datum *
@@ -107,6 +103,7 @@ retry:
return nil;
}else{
Datum new = fn(stmt->toks[offset],stmt->toks[offset+1]);
+ traceprint("handler fn done\n");
if(stmt->toks[offset].tag == ArrayTag)
freearray(stmt->toks[offset].array);
if(stmt->toks[offset+1].tag == ArrayTag)
@@ -125,6 +122,23 @@ retry:
}
}
if(stmt->ntoks == 1){
+ if(stmt->guard){
+ int guardOK = 1;
+ if(stmt->toks[0].tag != ArrayTag)
+ guardOK = 0;
+ else if(stmt->toks[0].array->size != 1)
+ guardOK = 0;
+ else if(stmt->toks[0].array->type != AtypeInt)
+ guardOK = 0;
+ else if(stmt->toks[0].array->intdata[0] != 0 && stmt->toks[0].array->intdata[0] != 1)
+ guardOK = 0;
+ if(!guardOK){
+ print("Guard expected single valued boolean\n");
+ exits(nil);
+ }
+ if(stmt->toks[0].array->intdata[0] == 1)
+ return eval(stmt->guard);
+ }
if(stmt->next)
return eval(stmt->next);
else
diff --git a/functions.c b/functions.c
index 9649e27..7d8b46c 100644
--- a/functions.c
+++ b/functions.c
@@ -36,8 +36,8 @@ fnmonad monadfunctiondefs[] = {
0, /* ∧ */
0, /* ⍲ */
0, /* ⍱ */
- 0, /* ↑ */
- 0, /* ↓ */
+ fnMix, /* ↑ */
+ fnSplit, /* ↓ */
fnEnclose, /* ⊂ */
0, /* ⊃ */
fnNest, /* ⊆ */
@@ -91,7 +91,7 @@ fndyad dyadfunctiondefs[] = {
0, /* ∧ */
0, /* ⍲ */
0, /* ⍱ */
- 0, /* ↑ */
+ fnTake, /* ↑ */
0, /* ↓ */
0, /* ⊂ */
0, /* ⊃ */
@@ -156,6 +156,15 @@ runfunc(Function f, Array *left, Array *right)
}
}
+Array *
+rundfn(Rune *code, Array *left, Array *right)
+{
+ Function dfn;
+ dfn.type = FunctypeDfn;
+ dfn.dfn = code;
+ return runfunc(dfn, left, right);
+}
+
/* Monadic functions */
Array *
@@ -172,6 +181,110 @@ fnTally(Array *right)
}
Array *
+fnMix(Array *right)
+{
+ if(right->type != AtypeArray || right->size == 0)
+ return fnSame(right);
+
+ int commonrank = 0;
+ int i,j;
+ for(i = 0; i < right->size; i++)
+ if(right->arraydata[i]->rank > commonrank)
+ commonrank = right->arraydata[i]->rank;
+
+ Array *commonshape = allocarray(AtypeInt, 1, commonrank);
+ commonshape->shape[0] = commonrank;
+ for(i = 0; i < commonrank; i++)
+ commonshape->intdata[i] = 0;
+
+ for(i = 0; i < right->size; i++){
+ Array *a = right->arraydata[i];
+ for(j = 0; j < a->rank; j++){
+ if(a->shape[a->rank-1-j] > commonshape->intdata[commonrank-1-j])
+ commonshape->intdata[commonrank-1-j] = a->shape[a->rank-1-j];
+ }
+ }
+
+ int size = 1;
+ int commonsize = 1;
+ for(i = 0; i < right->rank; i++)
+ size *= right->shape[i];
+ for(i = 0; i < commonshape->size; i++){
+ size *= commonshape->intdata[i];
+ commonsize *= commonshape->intdata[i];
+ }
+
+ /* TODO: think about types */
+ Array *result = allocarray(right->arraydata[0]->type, right->rank + commonrank, size);
+ for(i = 0; i < right->rank; i++)
+ result->shape[i] = right->shape[i];
+ for(j = 0; j < commonshape->size; j++)
+ result->shape[i+j] = commonshape->intdata[j];
+
+ int *index = malloc(sizeof(int) * commonrank);
+ int offset;
+ for(i = 0; i < size/commonsize; i++){
+ print("COPY CELL %d\n", i);
+ Array *a = right->arraydata[i];
+ Array *fill = fillelement(a);
+ if(a->rank == 0){
+ print("Copy scalar :-)\n");
+ memcpy(
+ result->rawdata + i * commonsize * datasizes[a->type],
+ a->rawdata, datasizes[a->type]);
+ if(a->type == AtypeArray)
+ incref(a->arraydata[0]);
+ for(j = 1; j < commonsize; j++){
+ memcpy(result->rawdata + (i * commonsize + j) * datasizes[a->type],
+ fill->rawdata, datasizes[a->type]);
+ if(fill->type == AtypeArray)
+ incref(fill->arraydata[0]);
+ }
+ }else{
+ for(j = 0; j < commonrank; j++)
+ index[j] = 0;
+ for(j = 0, offset = 0; offset < commonsize; j++){
+ for(int k = 0; index[commonrank-1-k] == a->shape[a->rank-1-k]; k++){
+ int nfill = commonshape->intdata[commonrank-1-k] - a->shape[a->rank-1-k];
+ if(nfill)
+ print("Adding %d fills\n", nfill);
+ while(nfill--){
+ memcpy(result->rawdata + (i * commonsize + offset) * datasizes[a->type],
+ fill->rawdata, datasizes[a->type]);
+ if(fill->type == AtypeArray)
+ incref(fill->arraydata[0]);
+ offset++;
+ }
+ index[commonrank-1-k] = 0;
+ index[commonrank-2-k]++;
+ }
+ if(offset < commonsize){
+ print("Copying from %d to %d\n", j, commonsize*i+offset);
+ memcpy(
+ result->rawdata + (i * commonsize + offset) * datasizes[a->type],
+ a->rawdata + j * datasizes[a->type], datasizes[a->type]);
+ if(a->type == AtypeArray)
+ incref(a->arraydata[j]);
+ offset++;
+ index[commonrank-1]++;
+ }
+ }
+ }
+ freearray(fill);
+ }
+ free(index);
+ free(commonshape);
+ return result;
+}
+
+Array *
+fnSplit(Array *right)
+{
+ Rune *code = L"0≡≢⍴⍵: ⍵ ⋄ (⊂⍵)⌷⍨¨⍳≢⍵";
+ return rundfn(code, nil, right);
+}
+
+Array *
fnEnclose(Array *right)
{
incref(right);
@@ -565,6 +678,66 @@ fnMatch(Array *left, Array *right)
}
Array *
+fnTake(Array *left, Array *right)
+{
+ if(left->type != AtypeInt || left->rank > 1 || left->size > right->rank){
+ print("Invalid left arg to ↑\n");
+ exits(nil);
+ }
+
+ int i;
+ if(left->size == right->rank)
+ left = fnSame(left);
+ else{
+ Array *old = left;
+ left = fnShape(right);
+ for(i = 0; i < old->size; i++)
+ left->intdata[i] = old->intdata[i];
+ }
+
+ if(right->rank == 0){
+ Array *leftshape = fnShape(left);
+ right = fnReshape(leftshape, right);
+ freearray(leftshape);
+ }
+ right = fnSame(right);
+
+ int *shape = malloc(sizeof(int) * left->size);
+ int size = 1;
+ for(i = 0; i < left->size; i++){
+ int s = left->intdata[i];
+ shape[i] = s < 0 ? -s : s;
+ size *= shape[i];
+ }
+
+ Array *result = allocarray(right->type, right->rank, size);
+ for(i = 0; i < right->rank; i++)
+ result->shape[i] = shape[i];
+
+ int *index = mallocz(sizeof(int) * left->size, 1);
+ int offset;
+ for(i = 0, offset = 0; offset < size; i++){
+ for(int j = left->size-1; index[j] == shape[j]; j--){
+ index[j] = 0;
+ index[j-1]++;
+ }
+ print("Result Index: ");
+ for(int j = 0; j < left->size; j++)
+ print("%d ", index[j]);
+ print("\n");
+
+ /* if index is part of left vector, select those places */
+
+ offset++;
+ index[left->size-1]++;
+ }
+
+ freearray(left);
+ freearray(right);
+ return result;
+}
+
+Array *
fnIndex(Array *left, Array *right)
{
int io = currentsymtab->io;
diff --git a/lexer.c b/lexer.c
index 3fd708d..b2990c8 100644
--- a/lexer.c
+++ b/lexer.c
@@ -14,6 +14,7 @@ lexline(Rune *line)
Statement *stmt = emalloc(sizeof(Statement));
stmt->ntoks = 0;
stmt->toks = mallocz(sizeof(Datum) * MAX_LINE_TOKENS, 1);
+ stmt->guard = nil;
stmt->next = nil;
while(offset < len){
@@ -21,10 +22,8 @@ lexline(Rune *line)
if(isspacerune(line[offset])){
offset++;
continue;
- }else if(runestrchr(L"[]←⋄⍝⍬", line[offset])){
+ }else if(runestrchr(L"←⋄⍝⍬", line[offset])){
switch(line[offset]){
- case '[': stmt->toks[stmt->ntoks].tag = LBracketTag; break;
- case ']': stmt->toks[stmt->ntoks].tag = RBracketTag; break;
case L'←': stmt->toks[stmt->ntoks].tag = ArrowTag; break;
case L'⋄': stmt->next = lexline(&line[offset+1]); goto end;
case L'⍝': goto end;
@@ -35,6 +34,18 @@ lexline(Rune *line)
break;
}
offset++;
+ }else if(line[offset] == ':'){
+ Rune buf[MAX_LINE_LENGTH];
+ Rune *p = buf;
+ offset++;
+ while(line[offset] != L'⋄' && offset < len){
+ *p = line[offset];
+ p++;
+ offset++;
+ }
+ *p = 0;
+ stmt->guard = lexline(buf);
+ stmt->ntoks--;
}else if(line[offset] == '{'){
Rune buf[MAX_LINE_LENGTH];
Rune *p = buf;
diff --git a/print.c b/print.c
index da60c7b..9a924d4 100644
--- a/print.c
+++ b/print.c
@@ -37,8 +37,6 @@ ppdatum(Datum d)
break;
case LParTag: result = runestrdup(L"("); break;
case RParTag: result = runestrdup(L")"); break;
- case LBracketTag: result = runestrdup(L"["); break;
- case RBracketTag: result = runestrdup(L"]"); break;
case ArrowTag: result = runestrdup(L"←"); break;
case AssignmentTag: result = runesmprint("%S←", d.symbol->name); break;
case NameTag: result = runestrdup(d.symbol->name); break;
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-13 10:56:19 +0000