All fields of Lambda and Closure are accessible via Object_{get,put}.

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	// <ast>.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 <math.h>
@@ -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, "<lambda>");						break;
-	case Closure:	String_appendAll(buf, "<closure>");						break;
+	case Lambda: {
+	    String_appendAll(buf, "<<Lambda>>");
+	    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, "<<Closure>>");
+	    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);