@ -1,6 +1,6 @@
# minproto.leg -- minimal prototype langauge for semantic experiments
#
# last edited: 2024-06-02 17:15:37 by piumarta on m1mbp
# last edited: 2024-06-13 14:47:05 by piumarta on zora
%{
;
@ -19,7 +19,7 @@
#endif
#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)
# define PRIMCLOSURE 1 // (approx. 6% performance decrease, because every Object_get() is slower)
#endif
#ifndef DELOPT // delegate is a member of Object structure, not a normal property
@ -42,6 +42,10 @@
# define FOLDCONST 1
#endif
#ifndef PROFILE // include profiling support
# define PROFILE 0
#endif
#include <math.h>
#include <stdint.h>
#include <stdio.h>
@ -72,6 +76,7 @@ void fatal(char *fmt, ...);
int opt_O = 0;
int opt_d = 0;
int opt_p = 0;
int opt_v = 0;
union object;
@ -108,9 +113,9 @@ oop printOn(oop buf, oop obj, int indent);
#endif
#if PRIMCLOSURE
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure)_(Raise)_(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal)
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _( Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure)_(Raise)_(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal)
#else
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure) _(Raise) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure)
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _( Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure) _(Raise) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure)
#endif
#define declareProto(NAME) oop p##NAME = 0;
@ -128,13 +133,13 @@ enum typecode {
doTypes(makeProto);
#undef makeProto
#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) _(owner)
#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) _(owner) _(profile)
#define declareProp(NAME) oop prop_##NAME = 0;
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) _(fixed) _(keyvals) _(__namespaces__) _(O) _(d) _(v) _(statement) _(handler) _(kind) _(message) _(operand1) _(operand2)
#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) _(keyvals) _(__namespaces__) _(O) _(d) _(p) _( v) _(statement) _(handler) _(kind) _(message) _(operand1) _(operand2) _(profile) _(parent) _(count) _(stamp) _(time) _(start) _(stop)
#define declareSym(NAME) oop sym_##NAME = 0;
doSymbols(declareSym);
@ -188,9 +193,13 @@ struct Symbol { enum type type; char *name; oop value; enum typecode typec
#else // !TYPECODES
struct Symbol { enum type type; char *name; oop value; };
#endif
#if PROFILE
struct Primitive { enum type type; oop name; prim_t function; void *cookie; oop profile; int index; };
#else
struct Primitive { enum type type; oop name; prim_t function; void *cookie; int index; };
#endif
#if PRIMCLOSURE
struct Lambda { enum type type; oop parameters, body; };
struct Lambda { enum type type; oop parameters, body, parent, name ; };
struct Closure { enum type type; oop fixed, function, environment; };
#endif
struct Object { enum type type; int isize, icap, psize;
@ -532,6 +541,28 @@ oop String_push(oop obj, oop val) // val is String OR Integer
return val;
}
void getSliceRange(oop obj, oop ostart, oop ostop, int len, int *pstart, int *pstop)
{
int start = (nil == ostart) ? 0 : integerValue(ostart, "[:]");
int stop = (nil == ostop ) ? len : integerValue(ostop, "[:]");
if (start < 0) start += len;
if (start < 0 || start >= len) rangeError("[:]", "start index out of bounds", obj, start);
if (stop < 0) stop += len;
if (stop < 0 || stop > len) rangeError("[:]", "end index out of bounds", obj, stop);
*pstart = start;
*pstop = stop;
}
void print(oop obj, int indent);
oop String_slice(oop obj, oop ostart, oop ostop)
{
int len = _get(obj, String,length), start, stop;
getSliceRange(obj, ostart, ostop, len, &start, &stop);
if (start >= stop) return newStringLen(0, 0);
return newStringLen(_get(obj, String,value) + start, stop - start);
}
oop newSymbol(char *name)
{
oop obj = make(Symbol);
@ -561,6 +592,20 @@ int stringLength(oop obj, char *who)
return 0;
}
oop intern(char *name);
oop Symbol_slice(oop obj, oop ostart, oop ostop)
{
char *name = _get(obj, Symbol,name);
int len = strlen(name), start, stop;
getSliceRange(obj, ostart, ostop, len, &start, &stop);
if (start >= stop) return intern(""); // ?!?
char buf[stop - start + 1];
strncpy(buf, name + start, stop - start);
buf[stop - start] = 0;
return intern(buf);
}
oop Object_put(oop obj, oop key, oop val);
oop Object_push(oop obj, oop val);
@ -572,6 +617,9 @@ oop newPrimitive(prim_t function, oop name)
_set(obj, Primitive,name, name);
_set(obj, Primitive,function, function);
_set(obj, Primitive,cookie, 0);
# if PROFILE
_set(obj, Primitive,profile, nil);
# endif
_set(obj, Primitive,index, _get(primitives, Object,isize));
Object_put(primitives, obj, newInteger(_get(primitives, Object,isize)));
Object_push(primitives, obj);
@ -580,11 +628,16 @@ oop newPrimitive(prim_t function, oop name)
#if PRIMCLOSURE
oop newLambda(oop parameters, oop body)
oop newLambda(oop parameters, oop body, oop parent, oop name )
{
oop obj = make(Lambda);
_set(obj, Lambda,parameters, parameters);
_set(obj, Lambda,body, body);
# if PROFILE
_set(obj, Lambda,profile, 0);
# endif
_set(obj, Lambda,parent, parent);
_set(obj, Lambda,name, name);
return obj;
}
@ -716,6 +769,8 @@ oop *Object_ref(oop obj, oop key)
case Lambda:
if (key == sym_parameters) return &_get(obj, Lambda,parameters);
if (key == sym_body ) return &_get(obj, Lambda,body );
if (key == sym_parent ) return &_get(obj, Lambda,parent );
if (key == sym_name ) return &_get(obj, Lambda,name );
o = pLambda;
break;
case Closure:
@ -757,6 +812,8 @@ oop Object_getOwner(oop obj, oop key, oop *ownerp)
case Lambda:
if (key == sym_parameters) return _get(obj, Lambda,parameters);
if (key == sym_body ) return _get(obj, Lambda,body );
if (key == sym_parent ) return _get(obj, Lambda,parent );
if (key == sym_name ) return _get(obj, Lambda,name );
o = pLambda;
break;
case Closure:
@ -798,6 +855,8 @@ oop Object_get(oop obj, oop key)
case Lambda:
if (key == sym_parameters) return _get(obj, Lambda,parameters);
if (key == sym_body ) return _get(obj, Lambda,body );
if (key == sym_parent ) return _get(obj, Lambda,parent );
if (key == sym_name ) return _get(obj, Lambda,name );
o = pLambda;
break;
case Closure:
@ -884,6 +943,8 @@ oop Object_put(oop obj, oop key, oop val)
case Lambda:
if (key == sym_parameters ) { _set(obj, Lambda,parameters, val); return val; }
if (key == sym_body ) { _set(obj, Lambda,body, val); return val; }
if (key == sym_parent ) { _set(obj, Lambda,parent, val); return val; }
if (key == sym_name ) { _set(obj, Lambda,name, val); return val; }
break;
case Closure:
if (key == sym_fixed ) { _set(obj, Closure,fixed, val); return val; }
@ -942,6 +1003,15 @@ oop newObjectWith(int isize, oop *indexed, int psize, struct property *propertie
return obj;
}
oop Object_slice(oop obj, oop ostart, oop ostop)
{
oop *indexed = _get(obj, Object,indexed);
int len = _get(obj, Object,isize), start, stop;
getSliceRange(obj, ostart, ostop, len, &start, &stop);
oop result = new(_getDelegate(obj));
for (int i = start; i < stop; ++i) Object_push(result, indexed[i]);
return result;
}
#if EXCEPTIONS
@ -1008,6 +1078,8 @@ oop keys(oop self, int all)
case Lambda: {
Object_push(keys, sym_parameters);
Object_push(keys, sym_body);
Object_push(keys, sym_parent);
Object_push(keys, sym_name);
break;
}
case Closure: {
@ -1980,6 +2052,39 @@ void SetArray_codeOn(oop exp, oop str, oop env)
codeOn(str, Object_get(exp, sym_value), 0);
}
oop newGetSlice(oop object, oop start, oop stop)
{
oop o = new(pGetSlice);
Object_put(o, sym_object, object);
Object_put(o, sym_start, start );
Object_put(o, sym_stop, stop );
return o;
}
oop GetSlice_eval(oop exp, oop env)
{
oop obj = eval(Object_get(exp, sym_object), env);
oop start = eval(Object_get(exp, sym_start ), env);
oop stop = eval(Object_get(exp, sym_stop ), env);
switch (getType(obj)) {
case String: return String_slice(obj, start, stop);
case Symbol: return Symbol_slice(obj, start, stop);
case Object: return Object_slice(obj, start, stop);
default: typeError("[:]", "non-indexable object", obj);
}
return nil;
}
void GetSlice_codeOn(oop exp, oop str, oop env)
{
codeOn(str, Object_get(exp, sym_object), 0);
String_appendAll(str, "[");
codeOn(str, Object_get(exp, sym_start ), 0);
String_appendAll(str, ":");
codeOn(str, Object_get(exp, sym_stop ), 0);
String_appendAll(str, "]");
}
oop newCall(oop function, oop arguments)
{
oop o = new(pCall);
@ -2273,11 +2378,16 @@ void Raise_codeOn(oop exp, oop str, oop env)
#if !PRIMCLOSURE
oop newLambda(oop parameters, oop body)
oop newLambda(oop parameters, oop body, oop parent, oop name )
{
oop o = new(pLambda);
Object_put(o, sym_parameters, parameters);
Object_put(o, sym_body , body );
Object_put(o, sym_parameters, parameters );
Object_put(o, sym_body , body );
# if PROFILE
Object_put(o, sym_profile , nil );
# endif
Object_put(o, sym_parent , parent );
Object_put(o, sym_name , name );
return o;
}
@ -2289,11 +2399,6 @@ oop newClosure(oop function, oop 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);
@ -2315,6 +2420,11 @@ void Closure_codeOn(oop exp, oop str, oop env)
printOn(str, exp, 0);
}
int isClosure(oop obj)
{
return is(Object, obj) && pClosure == _getDelegate(obj);
}
#endif // !PRIMCLOSURE
#define doBinops(_) \
@ -3275,10 +3385,10 @@ stmt = WHILE LPAREN c:expr RPAREN s:stmt { $$ = newWhile(c, s) }
| ENSURE e:stmt { $$ = newTryEnsure(t, e) }
)
| RAISE e:expr EOS { $$ = newRaise(e) }
| LOCAL i:id p:params b:block { $$ = newSetLocal (i, newLambda(p, b)) }
| GLOBAL i:id p:params b:block { $$ = newSetGlobal(i, newLambda(p, b)) }
| i:id p:params b:block { $$ = newSetVar (i, newLambda(p, b)) }
| v:proto DOT i:id p:params b:block { $$ = newSetProp(v, i, newLambda(p, b)) }
| LOCAL i:id p:params b:block { $$ = newSetLocal (i, newLambda(p, b, nil, i )) }
| GLOBAL i:id p:params b:block { $$ = newSetGlobal(i, newLambda(p, b, nil, i )) }
| i:id p:params b:block { $$ = newSetVar (i, newLambda(p, b, nil, i )) }
| v:proto DOT i:id p:params b:block { $$ = newSetProp(v, i, newLambda(p, b, v, i )) }
| b:block { $$ = newBlock(b) }
| e:expr EOS { $$ = e }
@ -3352,7 +3462,16 @@ prefix = PPLUS p:prefix { $$ = newBinop(opPreAdd, lvalue
postfix = SUPER DOT i:id a:args { $$ = newSuper(i, a) }
| p:primary
( LBRAK e:expr RBRAK { p = newGetArray(p, e) }
( LBRAK
( COLON ( RBRAK { p = newGetSlice(p, nil, nil) }
| e:xexpr RBRAK { p = newGetSlice(p, nil, e) }
)
| s:xexpr ( COLON ( RBRAK { p = newGetSlice(p, s, nil) }
| e:xexpr RBRAK { p = newGetSlice(p, s, e) }
)
| RBRAK { p = newGetArray(p, s) }
)
)
| DOT i:id ( a:args !LBRACE { p = newInvoke(p, i, a) }
| { p = newGetProp(p, i) }
)
@ -3383,9 +3502,9 @@ params = LPAREN p:mkobj
mkobj = { $$ = new(pObject) }
primary = nil | number | string | symbol | var | lambda | subexpr | literal
primary = nil | number | string | symbol | var | lambda | subexpr | literal # | regex
lambda = p:params b:block { $$ = newLambda(p, b) }
lambda = p:params b:block { $$ = newLambda(p, b, nil, nil ) }
subexpr = LPAREN e:expr RPAREN { $$ = e }
| b:block { $$ = newBlock(b) }
@ -3434,6 +3553,33 @@ var = LOCAL i:id { $$ = newGetLocal (i) }
id = < LETTER ALNUM* > - { $$ = intern(yytext) }
# regex = SLASH a:alts SLASH { $$ = a }
# alts = s:seq ( OR t:seq { s = Alt_append(t) }
# )* { $$ = s }
# seq = p:pre ( q:pre { s = Seq_append(t) }
# )* { $$ = s }
# elt = action | pre
# action = b:block { $$ = newAction(b) }
# pre = PLING p:pre { $$ = newNot(p) }
# | AND p:pre { $$ = newAnd(p) }
# | post
# post = a:atom ( STAR { a = newMany(a) }
# | PLUS { a = newMore(a) }
# | QUERY { a = newMore(a) }
# )? { $$ = a }
# atom = DOT { $$ = newDot() }
# | "[" ( !"]" "\\"? . )* "]" - { $$ = newClass(yytext) }
# | '"' xxxxxx
# class = LBRAK
BIGIT = [0-1]
OIGIT = [0-7]
DIGIT = [0-9]
@ -3520,29 +3666,97 @@ error = - < (!EOL .)* >
xexpr = expr | error @{ expected("expression", yytext) }
%%;
%%
;
#if PROFILE
#define SEND(RCV, MSG) ({ \
oop _rcv = RCV; \
oop _fun = Object_get(_rcv, sym_##MSG); \
get(_fun, Primitive,function)(_fun, _rcv, nil, nil); \
})
oop *profiles = 0;
int nprofiles = 0;
oop profileInit(oop function)
{
profiles = xrealloc(profiles, sizeof(*profiles) * (nprofiles + 1));
oop p = profiles[nprofiles++] = new(pObject);
Object_put(p, sym_function, function);
Object_put(p, sym_count, newInteger(0));
Object_put(p, sym_stamp, newInteger(0));
Object_put(p, sym_time, newInteger(0));
return p;
}
#include <time.h>
long uclock(void)
{
struct rusage ru;
getrusage(RUSAGE_SELF, &ru);
return ru.ru_utime.tv_sec * 1000000 + ru.ru_utime.tv_usec;
}
void profileTick(oop p)
{
oop *ref = Object_refLocal(p, sym_count); if (!ref) fatal("profile data lost: count");
long count = _integerValue(*ref);
*ref = newInteger(count + 1);
ref = Object_refLocal(p, sym_stamp); if (!ref) fatal("profile data lost: stamp");
//*ref = newInteger(clock());
*ref = newInteger(uclock());
}
oop sym_x = 0;
oop sym_y = 0;
void profileTock(oop p)
{
//long ticks = clock() - _integerValue(Object_getLocal(p, sym_stamp));
long ticks = uclock() - _integerValue(Object_getLocal(p, sym_stamp));
oop *timep = Object_refLocal(p, sym_time ); if (!timep) fatal("profile data lost: time");
ticks += _integerValue(*timep);
*timep = newInteger(ticks);
}
oop Point_magnitude(oop func, oop self, oop args, oop env)
void profileReport(void )
{
double x = floatValue(Object_get(self, sym_x), "Point.magnitude");
double y = floatValue(Object_get(self, sym_y), "Point.magnitude");
return newFloat(sqrt(x * x + y * y));
printf("%7s %7s function\n", "count", "msecs");
for (int i = 0; i < nprofiles; ++i) {
oop prof = profiles[i];
oop func = Object_getLocal(prof, sym_function);
long count = _integerValue(Object_getLocal(prof, sym_count ));
long ticks = _integerValue(Object_getLocal(prof, sym_time ));
printf("%7ld ", count);
//printf("%7ld ", (long)(1000. * ticks / CLOCKS_PER_SEC));
printf("%7ld ", ticks);
if (is(Primitive, func)) {
printf("%s\n", printString(func, 0));
continue;
}
oop parent = Object_getLocal(func, sym_parent);
oop name = Object_getLocal(func, sym_name);
if (nil != parent) printf("%s.", codeString (parent, 0));
if (nil != name ) printf("%s", printString(name, 0));
else printf("[anonymous function]");
printf("\n");
}
}
#endif
oop apply(oop func, oop self, oop args, oop env, oop owner)
{
int functype = getType(func);
if (Primitive == functype)
return _get(func, Primitive,function)(func, self, args, env);
if (Primitive == functype) {
# if PROFILE
oop profile = nil;
if (opt_p) {
profile = _get(func, Primitive,profile);
if (nil == profile) profile = _set(func, Primitive,profile, profileInit(func));
profileTick(profile);
}
# endif
oop result = _get(func, Primitive,function)(func, self, args, env);
# if PROFILE
if (opt_p) profileTock(profile);
# endif
return result;
}
#if PRIMCLOSURE
if (Closure != functype)
valueError(nil == self ? "()" : ".()", "cannot apply", func);
@ -3557,6 +3771,14 @@ oop apply(oop func, oop self, oop args, oop env, oop owner)
oop environment = Object_get(func, sym_environment);
oop parameters = Object_get(lambda, sym_parameters);
oop body = Object_get(lambda, sym_body);
# if PROFILE
oop profile = nil;
if (opt_p) {
profile = Object_getLocal(lambda, sym_profile);
if (nil == profile) profile = Object_put(lambda, sym_profile, profileInit(lambda));
profileTick(profile);
}
# endif
#endif
oop *exprs = get(body, Object,indexed);
int size = _get(body, Object,isize);
@ -3591,6 +3813,9 @@ oop apply(oop func, oop self, oop args, oop env, oop owner)
result = eval(exprs[i], args);
# if NONLOCAL
nlrPop();
# endif
# if PROFILE
if (opt_p) profileTock(profile);
# endif
return result;
}
@ -3621,6 +3846,7 @@ enum typecode getTypecode(oop exp)
#define defineEval(NAME) \
static inline oop prim_##NAME##_eval(oop func, oop exp, oop args, oop env) { \
if (_get(args,Object,isize) >= 1) env = Object_at(args, 0); \
return NAME##_eval(exp, env); \
}
@ -3652,7 +3878,9 @@ static inline oop evalobj(oop exp, oop env)
oop owner = nil;
oop evaluator = Object_getOwner(exp, prop_eval, &owner);
return apply(evaluator, exp, new(pObject), env, owner);
oop args = new(pObject);
Object_push(args, env);
return apply(evaluator, exp, args, env, owner);
}
long evaluations = 0;
@ -4070,7 +4298,7 @@ oop prim_print(oop func, oop self, oop args, oop env)
int indent = isInteger(full) ? _integerValue(full) : nil != full;
for (int i = 0; i < argc; ++i) print(result = indexed[i], indent);
fflush(stdout);
return nil ;
return result ;
}
oop prim_codeString(oop func, oop self, oop args, oop env)
@ -4212,6 +4440,7 @@ oop prim_Symbol_setopt(oop func, oop self, oop args, oop env)
int optval = _integerValue(val);
if (sym_O == self) opt_O = optval;
else if (sym_d == self) opt_d = optval;
else if (sym_p == self) opt_p = optval;
else if (sym_v == self) opt_v = optval;
else valueError("Symbol.setopt", "unknown option", val);
return val;
@ -4221,6 +4450,7 @@ oop prim_Symbol_getopt(oop func, oop self, oop args, oop env)
{ assert(is(Symbol, self));
if (sym_O == self) return newInteger(opt_O);
else if (sym_d == self) return newInteger(opt_d);
else if (sym_p == self) return newInteger(opt_p);
else if (sym_v == self) return newInteger(opt_v);
else valueError("Symbol.getopt", "unknown option", self);
return 0;
@ -4544,7 +4774,12 @@ oop replPath(char *path)
return result;
}
void cleanup(void)
{
# if PROFILE
if (opt_p) profileReport();
# endif
}
int main(int argc, char **argv)
{
@ -4683,6 +4918,7 @@ int main(int argc, char **argv)
switch (*arg) {
case 'O': ++opt_O; continue;
case 'd': ++opt_d, ++opt_v; continue;
case 'p': ++opt_p; continue;
case 'v': ++opt_v; continue;
default: fatal("unknown command-line option '%c'", *arg);
}
@ -4693,6 +4929,8 @@ int main(int argc, char **argv)
for (int i = argn; i < argc; ++i)
Object_push(args, newString(argv[i]));
atexit(cleanup);
if (argn == argc)
replFile(stdin);
else
