diff --git a/minproto.leg b/minproto.leg index 110dcd0..41668f3 100644 --- a/minproto.leg +++ b/minproto.leg @@ -1,27 +1,27 @@ # minproto.leg -- minimal prototype langauge for semantic experiments # -# last edited: 2024-05-07 23:23:22 by piumarta on m1mbp +# last edited: 2024-05-09 10:09:56 by piumarta on zora-1034.local %{ ; #ifndef GC -# define GC 1 +# define GC 1 // do not fill memory with unreachable junk #endif #ifndef TAGS -# define TAGS 1 +# define TAGS 1 // Integer and Float are immediate values encoded in their object "pointer" #endif -#ifndef TYPECODES -# define TYPECODES 0 +#ifndef TYPECODES // .eval() dispatches using switch(), instead of invoking a method +# define TYPECODES 0 // (approx. 210% performance increase, because no dynamic dispatch in eval()) #endif -#ifndef PRIMCLOSURE -# define PRIMCLOSURE 1 +#ifndef PRIMCLOSURE // Lambda and Closure are primitive types, not subtypes of Object +# define PRIMCLOSURE 0 // (approx. 6% performance decrease, because every Object_get() is slower) #endif -#ifndef DELOPT -# define DELOPT 0 +#ifndef DELOPT // delegate is a member of Object structure, not a normal property +# define DELOPT 0 // (approx. 60% performance increase, becase no associative lookup of __delegate__) #endif #include @@ -114,7 +114,7 @@ doTypes(makeProto); doProperties(declareProp); #undef declareProp -#define doSymbols(_) _(t) _(name) _(expr) _(function) _(arguments) _(object) _(index) _(key) _(value) _(self) _(method) _(parameters) _(body) _(lambda) _(environment) _(operation) _(full) _(condition) _(consequent) _(alternate) _(expression) _(identifier) _(initialise) _(update) _(first) _(last) +#define doSymbols(_) _(t) _(name) _(expr) _(function) _(arguments) _(object) _(index) _(key) _(value) _(self) _(method) _(parameters) _(body) _(lambda) _(environment) _(operation) _(full) _(condition) _(consequent) _(alternate) _(expression) _(identifier) _(initialise) _(update) _(first) _(last) _(fixed) #define declareSym(NAME) oop sym_##NAME = 0; doSymbols(declareSym); @@ -133,7 +133,7 @@ struct Symbol { enum type type; char *name; oop value; }; struct Primitive { enum type type; oop name; prim_t function; }; #if PRIMCLOSURE struct Lambda { enum type type; oop parameters, body; }; -struct Closure { enum type type; int fixed; oop lambda, environment; }; +struct Closure { enum type type; int fixed; oop function, environment; }; #endif struct Object { enum type type; int isize, icap, psize; # if DELOPT @@ -424,14 +424,16 @@ oop newLambda(oop parameters, oop body) return obj; } -oop newClosure(oop lambda, oop environment) +oop newClosure(oop function, oop environment) { oop obj = make(Closure); - _set(obj, Closure,lambda, lambda); + _set(obj, Closure,function, function); _set(obj, Closure,environment, environment); return obj; } +int isClosure(oop obj) { return is(Closure, obj); } + #endif oop macros = 0; @@ -530,36 +532,40 @@ char *storeString(oop obj, int indent); oop Object_get(oop obj, oop key) { - oop o = obj; - while (is(Object, o)) { - ssize_t ind = Object_find(o, key); - if (ind >= 0) return _get(o, Object,properties)[ind].val; - o = _getDelegate(o); - } -# define makeCase(NAME) case NAME: o = p##NAME; break; + oop o; switch (getType(obj)) { - doTypes(makeCase); - case Object: break; + case Undefined: o = pUndefined; break; + case Integer: o = pInteger; break; + case Float: o = pFloat; break; + case String: o = pString; break; + case Symbol: o = pSymbol; break; + case Primitive: o = pPrimitive; break; +# if PRIMCLOSURE + case Lambda: + if (key == sym_parameters) return _get(obj, Lambda,parameters); + if (key == sym_body ) return _get(obj, Lambda,body ); + o = pLambda; + break; + case Closure: + if (key == sym_function ) return _get(obj, Closure,function ); + if (key == sym_environment) return _get(obj, Closure,environment); + if (key == sym_fixed ) return _get(obj, Closure,fixed) ? sym_t : nil; + o = pClosure; + break; +# endif + case Object: { + ssize_t ind = Object_find(obj, key); + if (ind >= 0) return _get(obj, Object,properties)[ind].val; + o = _getDelegate(obj); + break; + } } -# undef makeCase -# if !DELOPT - if (key == prop_delegate) return o; // implicit delegate of atomic object -# endif + if (key == prop_delegate) return o; while (is(Object, o)) { ssize_t ind = Object_find(o, key); if (ind >= 0) return _get(o, Object,properties)[ind].val; o = _getDelegate(o); } -# if DELOPT - if (key == prop_delegate) { -# define makeCase(NAME) case NAME: return p##NAME; - switch (getType(obj)) { - doTypes(makeCase); - case Object: return _getDelegate(obj); - } -# undef makeCase - } -# endif fatal("%s.%s is undefined", storeString(obj, 0), storeString(key, 0)); return nil; } @@ -586,6 +592,20 @@ oop setvar(oop obj, oop key, oop val) oop Object_put(oop obj, oop key, oop val) { +# if PRIMCLOSURE + switch (getType(obj)) { + case Lambda: + if (key == sym_parameters ) { _set(obj, Lambda,parameters, val); return val; } + if (key == sym_body ) { _set(obj, Lambda,body, val); return val; } + break; + case Closure: + if (key == sym_fixed ) { _set(obj, Closure,fixed, nil != val); return val; } + if (key == sym_function ) { _set(obj, Closure,function, val); return val; } + if (key == sym_environment) { _set(obj, Closure,environment, val); return val; } + default: + break; + } +# endif ssize_t ind = Object_find(obj, key); struct property *kvs = _get(obj, Object,properties); if (ind < 0) { @@ -723,8 +743,37 @@ oop printOn(oop buf, oop obj, int indent) break; } #if PRIMCLOSURE - case Lambda: String_appendAll(buf, ""); break; - case Closure: String_appendAll(buf, ""); break; + case Lambda: { + String_appendAll(buf, "<>"); + if (!indent) break; + + String_append(buf, '\n'); + for (int j = indent; j--;) String_appendAll(buf, " | "); + String_appendAll(buf, " body: "); + 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); + break; + } + case Closure: { + String_appendAll(buf, "<>"); + if (!indent) 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); + + String_append(buf, '\n'); + for (int j = indent; j--;) String_appendAll(buf, " | "); + String_appendAll(buf, " function: "); + printOn(buf, _get(obj, Closure,function), indent+1); + break; + break; + } #endif case Object: { int level = 0; @@ -1144,7 +1193,11 @@ oop newApply(oop function, oop arguments) int isFixed(oop func) { +# if PRIMCLOSURE return is(Closure, func) && _get(func, Closure,fixed); +# else + return Object_getLocal(func, sym_fixed) != nil; +# endif } oop Call_eval(oop exp, oop env) @@ -1220,6 +1273,19 @@ oop newLambda(oop parameters, oop body) return o; } +oop newClosure(oop function, oop environment) +{ + oop o = new(pClosure); + Object_put(o, sym_function , function ); + Object_put(o, sym_environment, environment); + return o; +} + +int isClosure(oop obj) +{ + return is(Object, obj) && pClosure == _getDelegate(obj); +} + oop Lambda_eval(oop exp, oop env) { return newClosure(exp, env); @@ -1231,14 +1297,6 @@ void Lambda_codeOn(oop exp, oop str, oop env) codeBlockOn(str, Object_get(exp, sym_body)); } -oop newClosure(oop lambda, oop environment) -{ - oop o = new(pClosure); - Object_put(o, sym_lambda , lambda ); - Object_put(o, sym_environment, environment); - return o; -} - oop Closure_eval(oop exp, oop env) { return exp; @@ -1445,9 +1503,10 @@ oop quasiclone(oop exp, oop env) struct property *kvs = _get(exp, Object,properties); int psize = _get(exp, Object,psize); for (int i = 0; i < psize; ++i) - Object_put(clone, kvs[i].key, quasiclone(kvs[i].val, env)); + if (kvs[i].key != prop_delegate) + Object_put(clone, kvs[i].key, quasiclone(kvs[i].val, env)); oop delegate = _getDelegate(exp); - if (nil != delegate) + if (nil != delegate) // always shallow copied Object_put(clone, prop_delegate, delegate); return clone; } @@ -2031,14 +2090,14 @@ oop apply(oop func, oop self, oop args, oop env) #if PRIMCLOSURE if (Closure != functype) fatal("cannot %s %s", (nil == self ? "call" : "invoke"), storeString(func, 0)); - oop lambda = _get(func, Closure,lambda); + oop lambda = _get(func, Closure,function); oop environment = _get(func, Closure,environment); oop parameters = _get(lambda, Lambda,parameters); oop body = _get(lambda, Lambda,body); #else if (Object != functype || pClosure != _getDelegate(func)) fatal("cannot %s %s", (nil == self ? "call" : "invoke"), storeString(func, 0)); - oop lambda = Object_get(func, sym_lambda); + oop lambda = Object_get(func, sym_function); oop environment = Object_get(func, sym_environment); oop parameters = Object_get(lambda, sym_parameters); oop body = Object_get(lambda, sym_body); @@ -2091,20 +2150,22 @@ enum typecode getTypecode(oop exp) return NAME##_eval(exp, env); \ } +doProtos(defineEval) + +#undef defineEval + +#endif // !TYPECODES + #define defineCodeOn(NAME) \ static inline oop prim_##NAME##_codeOn(oop func, oop exp, oop args, oop env) { \ NAME##_codeOn(exp, getArgType(args, 0, String, #NAME".codeOn"), env); \ return exp; \ } \ -doProtos(defineEval) doProtos(defineCodeOn) -#undef defineEval #undef defineCodeOn -#endif // !TYPECODES - static inline oop evalobj(oop exp, oop env) { # if !TYPECODES @@ -2117,7 +2178,7 @@ static inline oop evalobj(oop exp, oop env) enum typecode type = getTypecode(exp); -# define defineEval(NAME) case t##NAME: NAME##_eval(exp, env); break; +# define defineEval(NAME) case t##NAME: return NAME##_eval(exp, env); switch (type) { doProtos(defineEval); } @@ -2196,13 +2257,31 @@ oop prim_length(oop func, oop self, oop args, oop env) oop prim_keys(oop func, oop self, oop args, oop env) { oop keys = new(pObject); - if (is(Object, self)) { - int size = _get(self, Object,psize); - struct property *kvs = _get(self, Object,properties); -# if DELOPT - if (nil != _getDelegate(self)) Object_push(keys, prop_delegate); +# 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); + 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 - for (int i = 0; i < size; ++i) Object_push(keys, kvs[i].key); } return keys; } @@ -2219,21 +2298,8 @@ oop prim_makeForm(oop func, oop self, oop args, oop env) oop result = nil; for (int i = 0; i < argc; ++i) { result = indexed[i]; - if (!is(Closure, result)) fatal("makeForm: argument must be closure"); - _set(result, Closure,fixed, 1); - } - return result; -} - -oop prim_makeMacro(oop func, oop self, oop args, oop env) -{ - int argc = _get(args, Object,isize); - oop *indexed = _get(args, Object,indexed); - oop result = nil; - for (int i = 0; i < argc; ++i) { - result = indexed[i]; - if (!is(Closure, result)) fatal("makeForm: argument must be closure"); - _set(result, Closure,fixed, 1); + if (!isClosure(result)) fatal("makeForm: argument must be closure"); + Object_put(result, sym_fixed, sym_t); } return result; } @@ -2439,11 +2505,16 @@ int main(int argc, char **argv) # undef defineProto #if TYPECODES + + Object_put(pObject, prop_eval, newPrimitive(prim_env)); // inherited by all objects + # define defineEvaluator(NAME) \ _set(intern(#NAME), Symbol,typecode, t##NAME); #else // !TYPECODES + # define defineEvaluator(NAME) \ Object_put(p##NAME, prop_eval, newPrimitive(prim_##NAME##_eval)); + #endif // !TYPECODES doProtos(defineEvaluator);