diff --git a/minproto.leg b/minproto.leg index 61a2710..7dea560 100644 --- a/minproto.leg +++ b/minproto.leg @@ -1,6 +1,6 @@ # minproto.leg -- minimal prototype langauge for semantic experiments # -# last edited: 2024-05-30 18:02:51 by piumarta on zora +# last edited: 2024-06-02 17:15:37 by piumarta on m1mbp %{ ; @@ -108,9 +108,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) _(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) _(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) _(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) _(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,7 +128,7 @@ enum typecode { doTypes(makeProto); #undef makeProto -#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) +#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) _(owner) #define declareProp(NAME) oop prop_##NAME = 0; doProperties(declareProp); @@ -188,7 +188,7 @@ struct Symbol { enum type type; char *name; oop value; enum typecode typec #else // !TYPECODES struct Symbol { enum type type; char *name; oop value; }; #endif -struct Primitive { enum type type; oop name; prim_t function; int index; }; +struct Primitive { enum type type; oop name; prim_t function; void *cookie; int index; }; #if PRIMCLOSURE struct Lambda { enum type type; oop parameters, body; }; struct Closure { enum type type; oop fixed, function, environment; }; @@ -546,7 +546,7 @@ oop newSymbol(char *name) char *stringValue(oop obj, char *who) { int type = getType(obj); - if (type == String) return _get(obj, String,value); + if (type == String) return String_content(obj); if (type == Symbol) return _get(obj, Symbol,name); typeError(who, "non-string operand", obj); return 0; @@ -571,6 +571,7 @@ oop newPrimitive(prim_t function, oop name) oop obj = make(Primitive); _set(obj, Primitive,name, name); _set(obj, Primitive,function, function); + _set(obj, Primitive,cookie, 0); _set(obj, Primitive,index, _get(primitives, Object,isize)); Object_put(primitives, obj, newInteger(_get(primitives, Object,isize))); Object_push(primitives, obj); @@ -742,6 +743,47 @@ oop *Object_ref(oop obj, oop key) return 0; } +oop Object_getOwner(oop obj, oop key, oop *ownerp) +{ + oop o; + switch (getType(obj)) { + 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 ); + o = pClosure; + break; +# endif + case Object: { + ssize_t ind = Object_find(obj, key); + if (ind >= 0) { *ownerp = obj; return _get(obj, Object,properties)[ind].val; } + o = _getDelegate(obj); + if (nil == o) o = pObject; + break; + } + } + if (key == prop_delegate) return o; + while (is(Object, o)) { + ssize_t ind = Object_find(o, key); + if (ind >= 0) { *ownerp = o; return _get(o, Object,properties)[ind].val; } + o = _getDelegate(o); + } + keyError("Object.", "undefined property", obj, key); + return nil; +} + oop Object_get(oop obj, oop key) { oop o; @@ -1033,7 +1075,15 @@ oop clone(oop obj) // shallow copy { switch (getType(obj)) { case String: return newStringLen(_get(obj, String,value), _get(obj, String,length)); - case Object:{ + case Primitive: { + oop clone = make(Primitive); + _set(clone, Primitive,name, _get(obj, Primitive,name )); + _set(clone, Primitive,function, _get(obj, Primitive,function)); + _set(clone, Primitive,cookie, _get(obj, Primitive,cookie )); + _set(clone, Primitive,index, _get(obj, Primitive,index )); + return clone; + } + case Object: { oop clone = new(_getDelegate(obj)); oop *elts = _get(obj, Object,indexed); int size = _get(obj, Object,isize); @@ -1101,7 +1151,7 @@ oop reversed(oop obj, char *who) return 0; } -oop apply(oop func, oop self, oop args, oop env); +oop apply(oop func, oop self, oop args, oop env, oop owner); void codeParametersOn(oop str, oop object, char *begin, char *end) { @@ -1157,10 +1207,11 @@ oop codeOn(oop str, oop obj, int indent) } #endif case Object: { - oop evaluator = Object_get(obj, prop_codeon); + oop owner = nil; + oop evaluator = Object_getOwner(obj, prop_codeon, &owner); oop args = new(pObject); Object_push(args, str); - apply(evaluator, obj, args, nil); + apply(evaluator, obj, args, nil, owner); break; } default: @@ -1943,7 +1994,7 @@ oop newApply(oop function, oop arguments) oop symbol = Object_get(function, sym_name); assert(is(Symbol, symbol)); oop macro = Object_getLocal(macros, symbol); - if (nil != macro) return apply(macro, nil, arguments, nil); + if (nil != macro) return apply(macro, nil, arguments, nil, nil); } return newCall(function, arguments); } @@ -1962,7 +2013,7 @@ oop Call_eval(oop exp, oop env) oop cfunc = eval (Object_get(exp, sym_function ), env); oop cargs = Object_get(exp, sym_arguments); if (!isFixed(cfunc)) cargs = evargs(cargs, env); - return apply(cfunc, nil, cargs, env); + return apply(cfunc, nil, cargs, env, nil); } void codeArgumentsOn(oop str, oop object, char *begin, char *end) @@ -1993,6 +2044,32 @@ void Call_codeOn(oop exp, oop str, oop env) codeArgumentsOn(str, Object_get(exp, sym_arguments), "(", ")"); } +oop newSuper(oop method, oop arguments) +{ + oop o = new(pSuper); + Object_put(o, sym_method , method ); + Object_put(o, sym_arguments, arguments); + return o; +} + +oop Super_eval(oop exp, oop env) +{ + oop meth = Object_get(exp, sym_method); + oop args = Object_get(exp, sym_arguments); + oop self = Object_get(env, sym_self); + oop owner = Object_get(env, prop_owner); + oop iargs = evargs(args, env); + oop ifunc = Object_getOwner(_getDelegate(owner), meth, &owner); // fails if property not defined + return apply(ifunc, self, iargs, env, owner); +} + +void Super_codeOn(oop exp, oop str, oop env) +{ + String_appendAll(str, "super."); + printOn(str, Object_get(exp, sym_method ), 0); + codeArgumentsOn(str, Object_get(exp, sym_arguments), "(", ")"); +} + oop newInvoke(oop self, oop method, oop arguments) { oop o = new(pInvoke); @@ -2005,10 +2082,11 @@ oop newInvoke(oop self, oop method, oop arguments) oop Invoke_eval(oop exp, oop env) { oop self = eval (Object_get(exp, sym_self ), env); - oop meth = Object_get(exp, sym_method ) ; + oop meth = Object_get(exp, sym_method); oop iargs = evargs(Object_get(exp, sym_arguments), env); - oop ifunc = Object_get(self, meth); // fails if property not defined - return apply(ifunc, self, iargs, env); + oop owner = nil; + oop ifunc = Object_getOwner(self, meth, &owner); // fails if property not defined + return apply(ifunc, self, iargs, env, owner); } void Invoke_codeOn(oop exp, oop str, oop env) @@ -3272,7 +3350,8 @@ prefix = PPLUS p:prefix { $$ = newBinop(opPreAdd, lvalue | COMMAT e:expr { $$ = newUnyop(opUnquote, e) } | postfix -postfix = p:primary +postfix = SUPER DOT i:id a:args { $$ = newSuper(i, a) } + | 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) } @@ -3388,6 +3467,7 @@ ENSURE = "ensure" !ALNUM - RAISE = "raise" !ALNUM - GLOBAL = "global" !ALNUM - LOCAL = "local" !ALNUM - +SUPER = "super" !ALNUM - BQUOTE = "`" - COMMAT = "@" - @@ -3458,7 +3538,7 @@ oop Point_magnitude(oop func, oop self, oop args, oop env) return newFloat(sqrt(x * x + y * y)); } -oop apply(oop func, oop self, oop args, oop env) +oop apply(oop func, oop self, oop args, oop env, oop owner) { int functype = getType(func); if (Primitive == functype) @@ -3485,6 +3565,7 @@ oop apply(oop func, oop self, oop args, oop env) // inherit from closure's captured environment _setDelegate(args, environment); Object_put(args, sym_self, self); + Object_put(args, prop_owner, owner); int nparam = _get(parameters, Object,isize); oop *pparam = _get(parameters, Object,indexed); int nargs = _get(args, Object,isize); @@ -3569,8 +3650,9 @@ static inline oop evalobj(oop exp, oop env) } # endif // TYPECODES - oop evaluator = Object_get(exp, prop_eval); - return apply(evaluator, exp, new(pObject), env); + oop owner = nil; + oop evaluator = Object_getOwner(exp, prop_eval, &owner); + return apply(evaluator, exp, new(pObject), env, owner); } long evaluations = 0; @@ -3613,12 +3695,20 @@ oop evargs(oop list, oop env) return newObjectWith(isize, indexed2, psize, props2); } -oop prim_new(oop func, oop self, oop args, oop env) +oop prim_Object_new(oop func, oop self, oop args, oop env) { assert(is(Object, args)); _setDelegate(args, self); + oop owner = nil; + oop ifunc = Object_getOwner(args, sym_initialise, &owner); + apply(ifunc, args, new(pObject), env, owner); return args; } +oop prim_Object_initialise(oop func, oop self, oop args, oop env) +{ + return self; +} + oop prim_Object_push(oop func, oop self, oop args, oop env) { assert(is(Object, args)); int argc = _get(args, Object,isize); assert(is(Object, self)); @@ -3638,7 +3728,10 @@ oop prim_Object_pop(oop func, oop self, oop args, oop env) oop prim_String_new(oop func, oop self, oop args, oop env) { - return newStringLen(0, 0); + int nargs = _get(args, Object,isize); + if (nargs == 0) return newStringLen(0, 0); + int len = _integerValue(getArgType(args, 0, Integer, "String.new")); + return newStringLen(calloc(1, len), len); } oop prim_String_escaped(oop func, oop self, oop args, oop env) @@ -3831,6 +3924,15 @@ oop prim_String_compareFrom(oop func, oop self, oop args, oop env) return newInteger(strncmp(myval + off, qqval, qqlen)); } +oop prim_String_intAt(oop func, oop self, oop args, oop env) +{ + int index = _integerValue(getArgType(args, 0, Integer, "String.intAt")); + int size = _get(self, String,length); + if (index < 0 || index + sizeof(int) > size) + rangeError("String.intAt", "index out of bounds", self, index); + return newInteger(*(int *)(_get(self, String,value) + index)); +} + oop prim_Object_includes(oop func, oop self, oop args, oop env) { assert(is(Object, args)); if (!is(Object, self)) return nil; @@ -4157,6 +4259,203 @@ oop prim_Symbol_allInstances(oop func, oop self, oop args, oop env) return result; } +#include +#include + +void *pointerValue(oop obj, char *who) +{ + switch (getType(obj)) { + case Integer: return (void *)(intptr_t)_integerValue(obj); + case String: return String_content(obj), _get(obj, String,value); + case Symbol: return &_get(obj, Symbol,name); + default: valueError(who, "cannot convert to pointer", obj); + } + return 0; +} + +ffi_type *sig2type(int sig) +{ + switch (sig) { + case 'v': return &ffi_type_void; + case 'c': return &ffi_type_schar; + case 'C': return &ffi_type_uchar; + case 's': return &ffi_type_sshort; + case 'S': return &ffi_type_ushort; + case 'i': return &ffi_type_sint; + case 'I': return &ffi_type_uint; + case 'l': return &ffi_type_slong; + case 'L': return &ffi_type_ulong; + case 'z': return &ffi_type_slong; + case 'Z': return &ffi_type_ulong; + case 'f': return &ffi_type_float; + case 'd': return &ffi_type_double; + case 'p': + case '*': return &ffi_type_pointer; + } + valueError("__extern__", "illegal type code", newInteger(sig)); + return 0; +} + +struct ffi_t { + char *name; + ffi_cif *cif; + char *signature; + void *function; + int arity; +}; + +oop primitiveExternalCall = 0; + +void *dlprobe(char *dir, char *prefix, char *name, char *suffix, int mode) +{ + oop path = newStringLen(0, 0); + String_appendAll(path, dir); + String_appendAll(path, prefix); + String_appendAll(path, name); + String_appendAll(path, suffix); + char *cpath = String_content(path); + if (opt_d) printf("dlprobe %s\n", cpath); + return dlopen(cpath, mode); +} + +void *dlfind(char *name, int mode) +{ + static char *dirs[] = { "", "/usr/lib/", "/lib/", "/usr/local/lib/", "/opt/local/lib/", 0 }; + static char *prefixes[] = { "lib", "", 0 }; + static char *suffixes[] = { ".so", ".dylib", ".dll", 0 }; + for (char **dir = dirs; *dir; ++dir) + for (char **prefix = prefixes; *prefix; ++prefix) + for (char **suffix = suffixes; *suffix; ++suffix) { + void *hnd = dlprobe(*dir, *prefix, name, *suffix, mode); + if (hnd) { + if (opt_d) printf("-> %p\n", hnd); + return hnd; + } + } + return 0; +} + +void *xdlopen(oop obj) +{ + if (nil == obj) return dlopen(0, RTLD_GLOBAL | RTLD_LAZY); + void *hnd = dlfind(stringValue(obj, "__extern__"), RTLD_GLOBAL | RTLD_LAZY); + if (!hnd) valueError("__extern__", "library not found", obj); + return hnd; +} + +void *xdlsym(void *handle, char *name) +{ + void *addr = dlsym(handle, name); + if (!addr) valueError("__extern__", dlerror(), newString(name)); + return addr; +} + +oop prim_extern(oop func, oop self, oop args, oop env) +{ + int nargs = _get(args, Object,isize); + oop *pargs = _get(args, Object,indexed); + switch (nargs) { + case 0: { + return mkptr(xdlopen(nil)); + } + case 1: { // extern("libname") + return mkptr(xdlopen(pargs[0])); + } + case 2: { // extern("libname"/handle, "name") + void *hnd = 0; + if (isInteger(pargs[0])) hnd = (void *)(intptr_t)_integerValue(pargs[0]); + else hnd = xdlopen(pargs[0]); + return mkptr(xdlsym(hnd, stringValue(pargs[1], "__extern__"))); + } + } + // extern("libname"/handle", "name", "signature") + void *hnd = 0; + if (isInteger(pargs[0])) hnd = (void *)(intptr_t)_integerValue(pargs[0]); + else hnd = xdlopen(pargs[0]); + char *sym = stringValue(pargs[1], "__extern__"); + void *adr = xdlsym(hnd, sym); + char *sig = stringValue(pargs[2], "__extern__"); + int argc = strlen(sig); + ffi_cif *cif = calloc(1, sizeof(ffi_cif)); + ffi_type **argv = calloc(argc, sizeof(*argv)); + for (int i = 0; i < argc; ++i) argv[i] = sig2type(sig[i]); + ffi_prep_cif(cif, FFI_DEFAULT_ABI, argc - 1, argv[0], argv + 1); + struct ffi_t *ffi = xmalloc(sizeof(*ffi)); + ffi->name = sym; + ffi->cif = cif; + ffi->signature = sig; + ffi->function = adr; + ffi->arity = argc; + oop result = clone(primitiveExternalCall); + _set(result, Primitive,cookie, ffi); + return result; +} + +union arg_t { + signed char c; + unsigned char C; + signed short s; + unsigned short S; + signed int i; + unsigned int I; + signed long l; + unsigned long L; + ssize_t z; + size_t Z; + float f; + double d; + void *p; + intptr_t P; +}; + +oop prim_externalCall(oop func, oop self, oop args, oop env) +{ + struct ffi_t *ffi = _get(func, Primitive,cookie); assert(ffi); + int argc = ffi->arity; + union arg_t vals[argc]; + void *argv[argc]; + for (int i = 1; i < argc; ++i) { + switch (ffi->signature[i]) { + case 'c': vals[i].c = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'C': vals[i].C = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 's': vals[i].s = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'S': vals[i].S = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'i': vals[i].i = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'I': vals[i].I = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'l': vals[i].l = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'L': vals[i].L = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'z': vals[i].z = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'Z': vals[i].Z = integerValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'f': vals[i].f = floatValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'd': vals[i].d = floatValue(getArg(args, i-1, ffi->name), ffi->name); break; + case 'p': + case '*': vals[i].p = pointerValue(getArg(args, i-1, ffi->name), ffi->name); break; + default: valueError(ffi->name, "illegal argument type code", newInteger(ffi->signature[i])); + } + argv[i] = vals + i; + } + ffi_call(ffi->cif, FFI_FN(ffi->function), vals, argv+1); + switch (ffi->signature[0]) { + case 'v': return nil; + case 'c': return newInteger(vals[0].c); + case 'C': return newInteger(vals[0].C); + case 's': return newInteger(vals[0].s); + case 'S': return newInteger(vals[0].S); + case 'i': return newInteger(vals[0].i); + case 'I': return newInteger(vals[0].I); + case 'l': return newInteger(vals[0].l); + case 'L': return newInteger(vals[0].L); + case 'z': return newInteger(vals[0].z); + case 'Z': return newInteger(vals[0].Z); + case 'f': return newFloat (vals[0].f); + case 'd': return newFloat (vals[0].d); + case 'p': + case '*': return mkptr (vals[0].p); + } + valueError(ffi->name, "illegal return type code", newInteger(ffi->signature[0])); + return 0; +} + oop replFile(FILE *in) { int oldline = lineno; @@ -4320,12 +4619,16 @@ int main(int argc, char **argv) prim(exit , prim_exit); prim(error , prim_error); prim(defined , prim_defined); + prim(__extern__ , prim_extern); # undef prim + primitiveExternalCall = newPrimitive(prim_externalCall, newString("externalCall")); + # define method(CLASS, NAME, FUNC) Object_put(p##CLASS, intern(#NAME), newPrimitive(FUNC, newString(#CLASS"."#NAME))) - method(Object,new, prim_new ); + method(Object,new, prim_Object_new ); + method(Object,initialise, prim_Object_initialise ); method(Object,push, prim_Object_push ); method(Object,pop, prim_Object_pop ); method(Object,length, prim_length ); @@ -4351,6 +4654,7 @@ int main(int argc, char **argv) method(String,bitTest, prim_String_bitTest ); method(String,charClass, prim_String_charClass ); method(String,compareFrom, prim_String_compareFrom ); + method(String,intAt, prim_String_intAt ); method(Symbol,asString, prim_Symbol_asString ); method(Symbol,setopt, prim_Symbol_setopt ); method(Symbol,getopt, prim_Symbol_getopt );