@ -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 <dlfcn.h>
#include <ffi.h>
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 );
