diff --git a/minproto.leg b/minproto.leg index 274cebf..57e4956 100644 --- a/minproto.leg +++ b/minproto.leg @@ -1,9 +1,11 @@ # minproto.leg -- minimal prototype langauge for semantic experiments # -# last edited: 2024-05-14 12:14:06 by piumarta on zora +# last edited: 2024-05-15 19:13:04 by piumarta on debian %{ ; +//#define YY_DEBUG 1 + #ifndef GC # define GC 1 // do not fill memory with unreachable junk #endif @@ -470,10 +472,10 @@ int stringLength(oop obj, char *who) return 0; } -oop newPrimitive(prim_t function) +oop newPrimitive(prim_t function, oop name) { oop obj = make(Primitive); - _set(obj, Primitive,name, 0); + _set(obj, Primitive,name, name); _set(obj, Primitive,function, function); return obj; } @@ -783,6 +785,119 @@ oop newObjectWith(int isize, oop *indexed, int psize, struct property *propertie return obj; } +int isSpecial(oop key) +{ + return is(Symbol, key) && !strncmp("__", _get(key, Symbol,name), 2); +} + +oop keys(oop self, int all) +{ + oop keys = new(pObject); +# if DELOPT + if (all && nil != _getDelegate(self)) Object_push(keys, prop_delegate); +# endif + switch (getType(self)) { + case Undefined: case Integer: case Float: case String: case Symbol: case Primitive: + break; +# if PRIMCLOSURE + case Lambda: { + Object_push(keys, sym_parameters); + Object_push(keys, sym_body); + break; + } + case Closure: { + Object_push(keys, sym_fixed); + Object_push(keys, sym_lambda); + Object_push(keys, sym_environment); + break; + } +# endif + case Object: { + int size = _get(self, Object,psize); + struct property *kvs = _get(self, Object,properties); + for (int i = 0; i < size; ++i) { + oop key = kvs[i].key; + if (all || !isSpecial(key)) Object_push(keys, key); + } + break; + } + } + return keys; +} + +intptr_t cmp(oop l, oop r, char *who) +{ + int tl = getType(l), tr = getType(r); + if (Integer == tl && Integer == tr) return _integerValue(l) - _integerValue(r); + if (Float == tl || Float == tr) return floatValue(l, who) - floatValue(r, who); + if (String == tl && String == tr) { + int ll = _get(l, String,length), rr = _get(r, String,length); + if (ll == rr) return strncmp(_get(l, String,value), _get(r, String,value), ll); + return ll - rr; + } + if (Symbol == tl && Symbol == tr) return strcmp(stringValue(l, who), stringValue(r, who)); + return (intptr_t)l - (intptr_t)r; +} + +#if defined (__linux__) +int objcmp(const void *a, const void *b, void *who) { return cmp(*(oop *)a, *(oop *)b, who); } +#else +int objcmp(void *who, const void *a, const void *b) { return cmp(*(oop *)a, *(oop *)b, who); } +#endif + +oop sortObject(oop obj, char *who) +{ assert(is(Object, obj)); +# if defined(__linux__) + qsort_r(_get(obj, Object,indexed), _get(obj, Object,isize), sizeof(oop), objcmp, "sort"); +# else + qsort_r(_get(obj, Object,indexed), _get(obj, Object,isize), sizeof(oop), "sort", objcmp); +# endif + return obj; +} + +int chrcmp(const void *a, const void *b) { return *(char *)a - *(char *)b; } + +oop sortString(oop obj) +{ assert(is(String, obj)); + qsort(_get(obj, String,value), _get(obj, String,length), 1, chrcmp); + return obj; +} + +oop clone(oop obj) // shallow copy +{ + switch (getType(obj)) { + case String: return newStringLen(_get(obj, String,value), _get(obj, String,length)); + case Object:{ + oop clone = new(_getDelegate(obj)); + oop *elts = _get(obj, Object,indexed); + int size = _get(obj, Object,isize); + for (int i = 0; i < size; ++i) Object_push(clone, elts[i]); + struct property *kvs = _get(obj, Object,properties); + size = _get(obj, Object,psize); + for (int i = 0; i < size; ++i) { + oop key = kvs[i].key; + if (prop_delegate == key) continue; + Object_put(clone, key, kvs[i].val); + } + return clone; + } + default: break; + } + return obj; +} + + +oop sorted(oop obj, char *who) +{ + switch (getType(obj)) { + case String: return sortString(clone(obj)); + case Object: return sortObject(clone(obj), who); + default: break; + } + fatal("sort: cannot sort %s", getTypeName(obj)); + return 0; +} + oop apply(oop func, oop self, oop args, oop env); void codeParametersOn(oop str, oop object, char *begin, char *end) @@ -822,7 +937,7 @@ oop codeOn(oop str, oop obj, int indent) case Symbol: String_format(str, "#%s", _get(obj, Symbol,name)); break; case Primitive: { String_appendAll(str, "'); break; @@ -851,17 +966,97 @@ oop codeOn(oop str, oop obj, int indent) return str; } +void indentOn(oop buf, int indent) +{ + if (indent < 1) return; + String_append(buf, '\n'); + for (int i = indent; i--;) String_appendAll(buf, " | "); + String_appendAll(buf, " "); +} + +void printObjectNameOn(oop buf, oop obj, int indent) +{ + int level = 0; + oop proto = obj; + oop name = nil; + do { + ++level; + name = Object_getLocal(proto, prop_name); + if (nil != name) break; + proto = _getDelegate(proto); + } while (is(Object, proto)); + for (int i = level; i--;) String_append(buf, '<'); + if (name != nil) printOn(buf, name, 0); + else String_appendAll(buf, "?"); + for (int i = level; i--;) String_append(buf, '>'); +} + +enum { + NO_DELEGATE = -1, + NO_SPECIALS = -2, +}; + +int printObjectPropertiesOn(oop buf, oop obj, int indent) +{ + oop names = sortObject(keys(obj, indent > 0), "print"); + int nkeys = _get(names, Object,isize); + oop *elts = _get(names, Object,indexed); + int i = 0; + for (i = 0; i < nkeys; ++i) { + if (i && indent < 1) String_appendAll(buf, ", "); + oop key = elts[i]; + if (prop_delegate == key) continue; + indentOn(buf, indent); + printOn(buf, key, 0); + String_appendAll(buf, ": "); + printOn(buf, Object_getLocal(obj, key), indent + (indent >= 0)); + } + return i; +} + oop printOn(oop buf, oop obj, int indent) { switch (getType(obj)) { - case Undefined: String_appendAll(buf, "nil"); break; - case Integer: String_format(buf, "%ld", _integerValue(obj)); break; - case Float: String_format(buf, "%f" , _floatValue(obj)); break; - case String: String_format(buf, "%.*s", (int)_get(obj, String,length), _get(obj, String,value)); break; - case Symbol: String_appendAll(buf, _get(obj, Symbol,name)); break; + case Undefined: String_appendAll(buf, "nil"); break; + case Integer: String_format(buf, "%ld", _integerValue(obj)); break; + case Float: String_format(buf, "%f" , _floatValue(obj)); break; + case String: { + char *str = _get(obj, String,value); + int len = _get(obj, String,length); + if (indent && indent != 1) { + String_append(buf, '"'); + while (len--) { + int c = *str++; + if (c >= ' ' && c <= '~') String_append(buf, c); + else if (c == '"') String_appendAll(buf, "\\\""); + else if (c == '\\') String_appendAll(buf, "\\\\"); + else { + switch (c) { + case '\a': c = 'a'; break; + case '\b': c = 'b'; break; + case '\f': c = 'f'; break; + case '\n': c = 'n'; break; + case '\r': c = 'r'; break; + case '\t': c = 't'; break; + case '\v': c = 'v'; break; + defalt: String_format(buf, "\\%03o", c); continue; + } + String_format(buf, "\\%c", c); + } + } + String_append(buf, '"'); + return buf; + } + String_format(buf, "%.*s", len, str); + break; + } + case Symbol: + if (indent < 0) String_append(buf, '#'); + String_appendAll(buf, _get(obj, Symbol,name)); + break; case Primitive: { String_appendAll(buf, "'); break; @@ -869,65 +1064,40 @@ oop printOn(oop buf, oop obj, int indent) #if PRIMCLOSURE case Lambda: { String_appendAll(buf, "<>"); - if (!indent) break; + if (indent < 1) break; - String_append(buf, '\n'); - for (int j = indent; j--;) String_appendAll(buf, " | "); + indentOn(buf, indent); String_appendAll(buf, " body: "); - printOn(buf, _get(obj, Lambda,body), indent+1); + printOn(buf, _get(obj, Lambda,body), indent + 1); String_append(buf, '\n'); for (int j = indent; j--;) String_appendAll(buf, " | "); String_appendAll(buf, " parameters: "); - printOn(buf, _get(obj, Lambda,parameters), indent+1); + printOn(buf, _get(obj, Lambda,parameters), indent + 1); break; } case Closure: { String_appendAll(buf, "<>"); - if (!indent) break; + if (indent < 1) break; String_append(buf, '\n'); for (int j = indent; j--;) String_appendAll(buf, " | "); String_appendAll(buf, " environment: "); - printOn(buf, _get(obj, Closure,environment), indent+1); + printOn(buf, _get(obj, Closure,environment), indent + 1); String_append(buf, '\n'); for (int j = indent; j--;) String_appendAll(buf, " | "); String_appendAll(buf, " function: "); - printOn(buf, _get(obj, Closure,function), indent+1); + printOn(buf, _get(obj, Closure,function), indent + 1); break; break; } #endif case Object: { - int level = 0; - oop proto = obj; - oop name = nil; - do { - ++level; - name = Object_getLocal(proto, prop_name); - if (nil != name) break; - proto = _getDelegate(proto); - } while (is(Object, proto)); - for (int i = level; i--;) String_append(buf, '<'); - if (name != nil) - printOn(buf, name, indent); - else - String_appendAll(buf, "?"); - for (int i = level; i--;) String_append(buf, '>'); + printObjectNameOn(buf, obj, indent); if (!indent) break; for (;;) { - int psize = _get(obj, Object,psize); - struct property *props = _get(obj, Object,properties); - for (int i = 0; i < psize; ++i) { - if (prop_delegate == props[i].key) continue; - String_append(buf, '\n'); - for (int j = indent; j--;) String_appendAll(buf, " | "); - String_appendAll(buf, " "); - printOn(buf, props[i].key, indent+1); - String_appendAll(buf, ": "); - printOn(buf, props[i].val, indent+1); - } + printObjectPropertiesOn(buf, obj, indent); int isize = _get(obj, Object,isize); oop *indexed = _get(obj, Object,indexed); for (int i = 0; i < isize; ++i) { @@ -1170,18 +1340,18 @@ oop GetVar_eval(oop exp, oop env) { return getvar(env, Object_get( void GetVar_codeOn(oop exp, oop str, oop env) { printOn(str, Object_get(exp, sym_name), 0); } -oop newSetVar(oop name, oop expr) +oop newSetVar(oop name, oop value) { oop o = new(pSetVar); - Object_put(o, sym_name, name); - Object_put(o, sym_expr, expr); + Object_put(o, sym_name, name); + Object_put(o, sym_value, value); return o; } oop SetVar_eval(oop exp, oop env) { - oop key = Object_get(exp, sym_name) ; - oop val = eval(Object_get(exp, sym_expr), env); + oop key = Object_get(exp, sym_name ) ; + oop val = eval(Object_get(exp, sym_value), env); return setvar(env, key, val); } @@ -1189,7 +1359,7 @@ void SetVar_codeOn(oop exp, oop str, oop env) { printOn(str, Object_get(exp, sym_name), 0); String_appendAll(str, " = "); - codeOn(str, Object_get(exp, sym_expr), 0); + codeOn(str, Object_get(exp, sym_value), 0); } oop newRefProp(oop object, oop key) @@ -1618,6 +1788,7 @@ void Closure_codeOn(oop exp, oop str, oop env) _(Add, +) _(Sub, -) \ _(Mul, *) _(Div, /) _(Mod, %) \ _(PostAdd, ++) _(PostDec, --) \ + _(PreSet, =) \ _(PreOr, |=) _(PreXor, ^=) _(PreAnd, &=) \ _(PreShl, >>=) _(PreShr, <<=) \ _(PreAdd, +=) _(PreSub, -=) \ @@ -1675,20 +1846,6 @@ binop(binBitAnd, &); #undef binop -intptr_t cmp(oop l, oop r, char *who) -{ - int tl = getType(l), tr = getType(r); - if (Integer == tl && Integer == tr) return _integerValue(l) - _integerValue(r); - if (Float == tl || Float == tr) return floatValue(l, who) - floatValue(r, who); - if (String == tl && String == tr) { - int ll = _get(l, String,length), rr = _get(r, String,length); - if (ll == rr) return strncmp(_get(l, String,value), _get(r, String,value), ll); - return ll - rr; - } - if (Symbol == tl && Symbol == tr) return strcmp(stringValue(l, who), stringValue(r, who)); - return (intptr_t)l - (intptr_t)r; -} - #define newBoolean(TF) ((TF) ? sym_t : nil) #define binop(NAME, OP) \ @@ -1735,6 +1892,12 @@ oop binPostDec(oop lhs, oop rhs) return value; } +oop binPreSet(oop lhs, oop rhs) +{ assert(isInteger(lhs)); + oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs)); + return *ref = rhs; +} + #define binop(NAME, OP) \ oop NAME(oop lhs, oop rhs) \ { assert(isInteger(lhs)); \ @@ -1914,6 +2077,10 @@ oop Binop_eval(oop exp, oop env) } return value; } + case opPreSet: { assert(isInteger(lhs)); // ref + oop *ref = (oop *)(intptr_t)_integerValue(lhs); + return *ref = rhs; + } case opPreOr ... opPreMod: { assert(isInteger(lhs)); // ref oop *ref = (oop *)(intptr_t)_integerValue(lhs); oop val = *ref; assert(isInteger(rhs)); // delta @@ -2482,6 +2649,31 @@ void Literal_codeOn(oop exp, oop str, oop env) # endif } +oop lvalue(oop rval) +{ + if (!is(Object,rval)) fatal("cannot assign to: %s", codeString(rval, 0)); + oop kind = _getDelegate(rval); + if (kind == pGetVar ) kind = pRefVar; + else if (kind == pGetProp ) kind = pRefProp; + else if (kind == pGetArray) kind = pRefArray; + else fatal("cannot assign to: %s", codeString(rval, 0)); + _setDelegate(rval, kind); + return rval; +} + +oop assign(oop rval, oop value) +{ + if (!is(Object,rval)) fatal("cannot assign to: %s", codeString(rval, 0)); + oop kind = _getDelegate(rval); + if (kind == pGetVar ) kind = pSetVar; + else if (kind == pGetProp ) kind = pSetProp; + else if (kind == pGetArray) kind = pSetArray; + else fatal("cannot assign to: %s", codeString(rval, 0)); + _setDelegate(rval, kind); + Object_put(rval, sym_value, value); + return rval; +} + %} @@ -2521,23 +2713,19 @@ proto = v:var ( DOT j:id !LPAREN { v = newGetProp(v, j) } EOS = SEMI+ | &RBRACE | &ELSE -expr = p:postfix - ( DOT i:id ASSIGN e:expr { $$ = newSetProp(p, i, e) } - | LBRAK i:expr RBRAK ASSIGN e:expr { $$ = newSetArray(p, i, e) } - ) - | i:id ASSIGN e:expr { $$ = newSetVar(i, e) } - | l:lvalue ( PLUSEQ r:expr { $$ = newBinop(opPreAdd, l, r) } - | MINUSEQ r:expr { $$ = newBinop(opPreSub, l, r) } - | STAREQ r:expr { $$ = newBinop(opPreMul, l, r) } - | SLASHEQ r:expr { $$ = newBinop(opPreDiv, l, r) } - | PCENTEQ r:expr { $$ = newBinop(opPreMod, l, r) } - | SHLEQ r:expr { $$ = newBinop(opPreShl, l, r) } - | SHREQ r:expr { $$ = newBinop(opPreShr, l, r) } - | ANDEQ r:expr { $$ = newBinop(opPreAnd, l, r) } - | XOREQ r:expr { $$ = newBinop(opPreXor, l, r) } - | OREQ r:expr { $$ = newBinop(opPreOr, l, r) } - ) - | logor +expr = i:id ASSIGN e:expr { $$ = newSetVar(i, e) } + | l:logor ( ASSIGN r:expr { l = assign(l, r) } + | PLUSEQ r:expr { l = newBinop(opPreAdd, lvalue(l), r) } + | MINUSEQ r:expr { l = newBinop(opPreSub, lvalue(l), r) } + | STAREQ r:expr { l = newBinop(opPreMul, lvalue(l), r) } + | SLASHEQ r:expr { l = newBinop(opPreDiv, lvalue(l), r) } + | PCENTEQ r:expr { l = newBinop(opPreMod, lvalue(l), r) } + | SHLEQ r:expr { l = newBinop(opPreShl, lvalue(l), r) } + | SHREQ r:expr { l = newBinop(opPreShr, lvalue(l), r) } + | ANDEQ r:expr { l = newBinop(opPreAnd, lvalue(l), r) } + | XOREQ r:expr { l = newBinop(opPreXor, lvalue(l), r) } + | OREQ r:expr { l = newBinop(opPreOr, lvalue(l), r) } + )? { $$ = l } logor = l:logand ( BARBAR r:logand { l = newBinop(opLogOr, l, r) } )* { $$ = l } @@ -2577,8 +2765,8 @@ prod = l:prefix ( STAR r:prefix { l = newBinop(opMul, l, r) } | PCENT r:prefix { l = newBinop(opMod, l, r) } )* { $$ = l } -prefix = PPLUS l:lvalue { $$ = newBinop(opPreAdd, l, newInteger(1)) } - | MMINUS l:lvalue { $$ = newBinop(opPreSub, l, newInteger(1)) } +prefix = PPLUS p:prefix { $$ = newBinop(opPreAdd, lvalue(p), newInteger(1)) } + | MMINUS p:prefix { $$ = newBinop(opPreSub, lvalue(p), newInteger(1)) } | PLING p:prefix { $$ = newUnyop(opNot, p) } | MINUS p:prefix { $$ = newUnyop(opNeg, p) } | TILDE p:prefix { $$ = newUnyop(opCom, p) } @@ -2586,41 +2774,35 @@ prefix = PPLUS l:lvalue { $$ = newBinop(opPreAdd, l, new | COMMAT e:expr { $$ = newUnyop(opUnquote, e) } | postfix -lvalue = - l:primary - ( LBRAK e:expr RBRAK &(DOT | LBRAK | LPAREN) { l = newGetArray(l, e) } - | DOT i:id a:args &(DOT | LBRAK | LPAREN) { l = newInvoke(l, i, a) } - | DOT i:id &(DOT | LBRAK | LPAREN) { l = newGetProp(l, i) } - | a:args &(DOT | LBRAK | LPAREN) { l = newApply(l, a) } +postfix = p:primary + ( LBRAK e:expr RBRAK { p = newGetArray(p, e) } + | DOT i:id ( a:args !LBRACE { p = newInvoke(p, i, a) } + | { p = newGetProp(p, i) } + ) + | a:args !LBRACE { p = newApply(p, a) } )* - ( LBRAK e:expr RBRAK { l = newRefArray(l, e) } - | DOT i:id { l = newRefProp(l, i) } - ) { $$ = l } - | - i:id { $$ = newRefVar(i) } - -postfix = l:lvalue ( PPLUS { $$ = newBinop(opPostAdd, l, newInteger( 1)) } - | MMINUS { $$ = newBinop(opPostAdd, l, newInteger(-1)) } - ) - | p:primary - ( LBRAK e:expr RBRAK !ASSIGN { p = newGetArray(p, e) } - | DOT i:id a:args !ASSIGN !LBRACE { p = newInvoke(p, i, a) } - | DOT i:id !ASSIGN { p = newGetProp(p, i) } - | a:args !ASSIGN !LBRACE { p = newApply(p, a) } - )* { $$ = p } + ( PPLUS { p = newBinop(opPostAdd, lvalue(p), newInteger( 1)) } + | MMINUS { p = newBinop(opPostAdd, lvalue(p), newInteger(-1)) } + )? { $$ = p } args = LPAREN a:mkobj - ( ( k:id COLON e:expr { Object_put(a, k, e) } - | e:expr { Object_push(a, e) } + ( RPAREN + | ( k:id COLON e:expr { Object_put(a, k, e) } + | e:expr { Object_push(a, e) } ) - ( COMMA ( k:id COLON e:expr { Object_put(a, k, e) } - | e:expr { Object_push(a, e) } - ) )* )? RPAREN { $$ = a } + ( COMMA ( k:id COLON e:expr { Object_put(a, k, e) } + | e:expr { Object_push(a, e) } + ) )* RPAREN ) { $$ = a } params = LPAREN p:mkobj - ( i:id { Object_push(p, i) } - ( COMMA i:id { Object_push(p, i) } - )* )? RPAREN { $$ = p } + ( RPAREN + | i:id ( COLON e:expr { Object_put(p, i, e) } + | { Object_push(p, i) } + ) + ( COMMA i:id ( COLON e:expr { Object_put(p, i, e) } + | { Object_push(p, i) } + ) + )* RPAREN ) { $$ = p } mkobj = { $$ = new(pObject) } @@ -2632,11 +2814,12 @@ subexpr = LPAREN e:expr RPAREN { $$ = e } | b:block { $$ = newBlock(b) } literal = LBRAK o:mkobj - ( ( i:id COLON e:expr { Object_put(o, i, e) } - | e:expr { Object_push(o, e) } - ) ( COMMA ( i:id COLON e:expr { Object_put(o, i, e) } - | e:expr { Object_push(o, e) } - ) )* )? RBRAK { $$ = newLiteral(o) } + ( RBRAK + | ( ( i:id COLON e:expr { Object_put(o, i, e) } + | e:expr { Object_push(o, e) } + ) ( COMMA ( i:id COLON e:expr { Object_put(o, i, e) } + | e:expr { Object_push(o, e) } + ) )* )? RBRAK ) { $$ = newLiteral(o) } block = LBRACE b:mkobj ( e:stmt { Object_push(b, e) } @@ -2644,9 +2827,9 @@ block = LBRACE b:mkobj nil = NIL { $$ = nil } -number = "-" u:unsign { $$ = neg(u) } - | "+" n:number { $$ = u } - | u:unsign { $$ = u } +number = "-" n:unsign { $$ = neg(n) } + | "+" n:number { $$ = n } + | n:unsign { $$ = n } unsign = < DIGIT+ '.' DIGIT* EXP? > - { $$ = newFloat(strtod(yytext, 0)) } | < DIGIT* '.' DIGIT+ EXP? > - { $$ = newFloat(strtod(yytext, 0)) } @@ -2655,8 +2838,14 @@ unsign = < DIGIT+ '.' DIGIT* EXP? > - { $$ = newFloat(strtod(yytext, 0 | "0" < OIGIT* > - { $$ = newInteger(strtol(yytext, 0, 8)) } | < DIGIT+ > - { $$ = newInteger(strtol(yytext, 0, 10)) } -string = '"' < ( !'"' . )* > '"' - { $$ = newStringEscaped(yytext) } - | "'" < ( !"'" . )* > "'" - { $$ = newStringEscaped(yytext) } +string = '"' < ( !'"' char )* > '"' - { $$ = newStringEscaped(yytext) } + | "'" < ( !"'" char )* > "'" - { $$ = newStringEscaped(yytext) } + +char = "\\" ( ["'\\abfnrtv] + | [xX] HIGIT* + | [0-7][0-7]?[0-7]? + ) + | . symbol = HASH i:id { $$ = i } @@ -2794,8 +2983,15 @@ oop apply(oop func, oop self, oop args, oop env) case NLR_RETURN: return nlrPop(); } # endif + // positional args -> named parameters for (int i = 0; i < nparam; ++i) Object_put(args, pparam[i], i < nargs ? pargs[i] : nil); + // keyword defaults + int nkeywd = _get(parameters, Object,psize); + struct property *pkeywd = _get(parameters, Object,properties); + for (int i = 0; i < nkeywd; ++i) + if (Object_find(args, pkeywd[i].key) < 0) + Object_put(args, pkeywd[i].key, eval(pkeywd[i].val, args)); for (int i = 0; i < size; ++i) result = eval(exprs[i], args); # if NONLOCAL @@ -2930,57 +3126,23 @@ oop prim_length(oop func, oop self, oop args, oop env) return newInteger(_get(self, Object,isize)); } -oop sortObject(oop obj, char *who) +oop prim_keys(oop func, oop self, oop args, oop env) { - int limit = _get(obj, Object,isize); - oop *elts = _get(obj, Object,indexed); - for (int i = 0; i < limit - 1; ++i) { - int mindex = i; - oop minobj = elts[i]; - for (int j = i + 1; j < limit; ++j) { - oop newobj = elts[j]; - if (cmp(newobj, minobj, who) < 0) mindex = j, minobj = newobj; - } - if (mindex != i) { - oop tmpobj = elts[i]; - elts[i] = minobj; - elts[mindex] = tmpobj; - } - } - return obj; + return keys(self, 0); } -oop prim_keys(oop func, oop self, oop args, oop env) +oop prim_allKeys(oop func, oop self, oop args, oop env) { - oop keys = new(pObject); -# if DELOPT - if (nil != _getDelegate(self)) Object_push(keys, prop_delegate); -# endif - switch (getType(self)) { - case Undefined: case Integer: case Float: case String: case Symbol: case Primitive: - break; - case Object: { - int size = _get(self, Object,psize); - struct property *kvs = _get(self, Object,properties); - for (int i = 0; i < size; ++i) Object_push(keys, kvs[i].key); - sortObject(keys, "keys"); - break; - } -# if PRIMCLOSURE - case Lambda: { - Object_push(keys, sym_parameters); - Object_push(keys, sym_body); - break; - } - case Closure: { - Object_push(keys, sym_fixed); - Object_push(keys, sym_lambda); - Object_push(keys, sym_environment); - break; - } -# endif + return keys(self, 1); +} + +oop prim_sorted(oop func, oop self, oop args, oop env) +{ assert(is(Object, args)); + if (self == nil) { + if (_get(args, Object,isize) != 1) fatal("sorted: one argument expected"); + self = _get(args, Object,indexed)[0]; } - return keys; + return sorted(self, "sorted"); } oop prim_env(oop func, oop self, oop args, oop env) @@ -3007,8 +3169,8 @@ oop prim_print(oop func, oop self, oop args, oop env) int argc = _get(args, Object,isize); oop *indexed = _get(args, Object,indexed); oop result = nil; - int indent = 0; - if (nil != Object_getLocal(args, sym_full)) indent = 1; + oop full = Object_getLocal(args, sym_full); + int indent = isInteger(full) ? _integerValue(full) : nil != full; for (int i = 0; i < argc; ++i) print(result = indexed[i], indent); fflush(stdout); return nil; @@ -3137,7 +3299,7 @@ oop prim_exit(oop func, oop self, oop args, oop env) oop replFile(FILE *in) { int oldline = lineno; - lineno = 0; + lineno = 1; input = newInput(); readFile(in, &input->text, &input->size); oop result = nil; @@ -3203,7 +3365,7 @@ int main(int argc, char **argv) # undef defineProto - Object_put(pObject, prop_eval, newPrimitive(prim___eval__)); // inherited by all objects + Object_put(pObject, prop_eval, newPrimitive(prim___eval__, newString("Object.__eval__"))); // inherited by all objects #if TYPECODES @@ -3212,7 +3374,7 @@ int main(int argc, char **argv) #else // !TYPECODES # define defineEvaluator(NAME) \ - Object_put(p##NAME, prop_eval, newPrimitive(prim_##NAME##_eval)); + Object_put(p##NAME, prop_eval, newPrimitive(prim_##NAME##_eval, newString(#NAME".__eval__"))); #endif // !TYPECODES @@ -3221,7 +3383,7 @@ int main(int argc, char **argv) # undef defineEvaluator # define defineCodeOn(NAME) \ - Object_put(p##NAME, prop_codeon, newPrimitive(prim_##NAME##_codeOn)); + Object_put(p##NAME, prop_codeon, newPrimitive(prim_##NAME##_codeOn, newString(#NAME".codeOn"))); doProtos(defineCodeOn); @@ -3229,26 +3391,36 @@ int main(int argc, char **argv) macros = Object_put(pSymbol, intern("macros"), new(pObject)); - _set(intern("__env__" ), Symbol,value, newPrimitive(prim_env)); - _set(intern("eval" ), Symbol,value, newPrimitive(prim_eval)); - _set(intern("print" ), Symbol,value, newPrimitive(prim_print)); - _set(intern("codeString" ), Symbol,value, newPrimitive(prim_codeString)); - _set(intern("sqrt" ), Symbol,value, newPrimitive(prim_sqrt)); - _set(intern("round" ), Symbol,value, newPrimitive(prim_round)); - _set(intern("truncate" ), Symbol,value, newPrimitive(prim_truncate)); - _set(intern("cputime" ), Symbol,value, newPrimitive(prim_cputime)); - _set(intern("evaluations"), Symbol,value, newPrimitive(prim_evaluations)); - _set(intern("len" ), Symbol,value, newPrimitive(prim_len)); - _set(intern("ord" ), Symbol,value, newPrimitive(prim_ord)); - _set(intern("chr" ), Symbol,value, newPrimitive(prim_chr)); - _set(intern("readfile" ), Symbol,value, newPrimitive(prim_readfile)); - _set(intern("exit" ), Symbol,value, newPrimitive(prim_exit)); - - Object_put(pObject, intern("new"), newPrimitive(prim_new )); - Object_put(pObject, intern("push"), newPrimitive(prim_push )); - Object_put(pObject, intern("pop"), newPrimitive(prim_pop )); - Object_put(pObject, intern("length"), newPrimitive(prim_length)); - Object_put(pObject, intern("keys"), newPrimitive(prim_keys )); +# define prim(NAME, FUNC) _set(intern(#NAME), Symbol,value, newPrimitive(FUNC, newString(#NAME))) + + prim(__env__ , prim_env); + prim(eval , prim_eval); + prim(print , prim_print); + prim(codeString , prim_codeString); + prim(sqrt , prim_sqrt); + prim(round , prim_round); + prim(truncate , prim_truncate); + prim(cputime , prim_cputime); + prim(evaluations, prim_evaluations); + prim(len , prim_len); + prim(ord , prim_ord); + prim(chr , prim_chr); + prim(readfile , prim_readfile); + prim(exit , prim_exit); + +# undef prim + +# define method(CLASS, NAME, FUNC) Object_put(p##CLASS, intern(#NAME), newPrimitive(FUNC, newString(#CLASS"."#NAME))) + + method(Object,new, prim_new ); + method(Object,push, prim_push ); + method(Object,pop, prim_pop ); + method(Object,length, prim_length ); + method(Object,keys, prim_keys ); + method(Object,allKeys, prim_allKeys); + method(Object,sorted, prim_sorted ); + +# undef method _set(sym___globals__, Symbol,value, nil);