Ви не можете вибрати більше 25 тем
Теми мають розпочинатися з літери або цифри, можуть містити дефіси (-) і не повинні перевищувати 35 символів.
2617 рядки
72 KiB
2617 рядки
72 KiB
# minproto.leg -- minimal prototype langauge for semantic experiments
|
|
#
|
|
# last edited: 2024-05-09 13:59:36 by piumarta on zora-1034.local
|
|
|
|
%{
|
|
;
|
|
#ifndef GC
|
|
# define GC 1 // do not fill memory with unreachable junk
|
|
#endif
|
|
|
|
#ifndef TAGS
|
|
# define TAGS 1 // Integer and Float are immediate values encoded in their object "pointer"
|
|
#endif
|
|
|
|
#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 // 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 // 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>
|
|
#include <stdint.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
#include <ctype.h>
|
|
#include <assert.h>
|
|
#include <stdarg.h>
|
|
#include <sys/errno.h>
|
|
#include <sys/resource.h> // getrusage()
|
|
|
|
#if GC
|
|
# include <gc.h>
|
|
# define xmalloc(N) (GC_malloc(N))
|
|
# define xmallocAtomic(N) (GC_malloc_atomic(N))
|
|
# define xrealloc(P, N) (GC_realloc(P, N))
|
|
#else
|
|
# define GC_INIT()
|
|
# define xmalloc(N) (calloc(1, N))
|
|
# define xmallocAtomic(N) (calloc(1, N))
|
|
# define xrealloc(P, N) (realloc(P, N))
|
|
#endif
|
|
|
|
#define indexableSize(A) (sizeof(A) / sizeof(*(A)))
|
|
|
|
void fatal(char *fmt, ...);
|
|
|
|
int opt_O = 0;
|
|
int opt_d = 0;
|
|
int opt_v = 0;
|
|
|
|
union object;
|
|
typedef union object *oop;
|
|
|
|
#if PRIMCLOSURE
|
|
#define doTypes(_) \
|
|
_(Undefined) _(Integer) _(Float) _(String) _(Symbol) _(Primitive) \
|
|
_(Lambda) _(Closure)
|
|
#else
|
|
#define doTypes(_) \
|
|
_(Undefined) _(Integer) _(Float) _(String) _(Symbol) _(Primitive)
|
|
#endif
|
|
|
|
#define makeType(X) X,
|
|
enum type { doTypes(makeType) makeType(Object) };
|
|
#undef makeType
|
|
|
|
#define makeType(X) #X,
|
|
char *typeNames[] = { doTypes(makeType) makeType(Object) };
|
|
#undef makeType
|
|
|
|
typedef oop (*prim_t)(oop func, oop self, oop args, oop env);
|
|
|
|
#if TAGS
|
|
# define TAGBITS 2
|
|
# define TAGMASK 3
|
|
# define TAGINT Integer // 1
|
|
# define TAGFLT Float // 2
|
|
#endif
|
|
|
|
#if PRIMCLOSURE
|
|
#define doProtos(_) _(Object) _(GetVar) _(SetVar) _(GetProp) _(SetProp) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Binop) _(Unyop) _(Let) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal)
|
|
#else
|
|
#define doProtos(_) _(Object) _(GetVar) _(SetVar) _(GetProp) _(SetProp) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Binop) _(Unyop) _(Let) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure)
|
|
#endif
|
|
|
|
#define declareProto(NAME) oop p##NAME = 0;
|
|
doProtos(declareProto);
|
|
#undef declareProto
|
|
|
|
#if TYPECODES
|
|
|
|
#define declareTypecode(NAME) t##NAME,
|
|
enum typecode {
|
|
doProtos(declareTypecode)
|
|
};
|
|
#undef declareTypecode
|
|
|
|
#endif // TYPECODES
|
|
|
|
#define makeProto(NAME) oop p##NAME = 0;
|
|
doTypes(makeProto);
|
|
#undef makeProto
|
|
|
|
#define doProperties(_) _(name) _(eval) _(delegate) _(codeon)
|
|
|
|
#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)
|
|
|
|
#define declareSym(NAME) oop sym_##NAME = 0;
|
|
doSymbols(declareSym);
|
|
#undef declareSym
|
|
|
|
struct property { oop key, val; };
|
|
|
|
struct Integer { enum type type; long _value; };
|
|
struct Float { enum type type; double _value; };
|
|
struct String { enum type type; int length; char *value; };
|
|
#if TYPECODES
|
|
struct Symbol { enum type type; char *name; oop value; enum typecode typecode; };
|
|
#else // !TYPECODES
|
|
struct Symbol { enum type type; char *name; oop value; };
|
|
#endif
|
|
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 function, environment; };
|
|
#endif
|
|
struct Object { enum type type; int isize, icap, psize;
|
|
# if DELOPT
|
|
oop delegate;
|
|
# endif
|
|
oop *indexed; struct property *properties; };
|
|
|
|
union object
|
|
{
|
|
enum type type;
|
|
struct Integer Integer;
|
|
struct Float Float;
|
|
struct String String;
|
|
struct Symbol Symbol;
|
|
struct Primitive Primitive;
|
|
#if PRIMCLOSURE
|
|
struct Lambda Lambda;
|
|
struct Closure Closure;
|
|
#endif
|
|
struct Object Object;
|
|
};
|
|
|
|
union object _nil = { Undefined };
|
|
|
|
#define nil (&_nil)
|
|
|
|
#define UNDEFINED 0
|
|
|
|
enum type getType(oop obj)
|
|
{
|
|
# if TAGS
|
|
if ((intptr_t)obj & TAGMASK) return ((intptr_t)obj & TAGMASK);
|
|
# endif
|
|
return obj->type;
|
|
}
|
|
|
|
char *getTypeName(oop obj)
|
|
{
|
|
int type = getType(obj); assert(0 <= type && type <= indexableSize(typeNames));
|
|
return typeNames[type];
|
|
}
|
|
|
|
int is(enum type type, oop obj) { return type == getType(obj); }
|
|
|
|
oop _checkType(oop obj, enum type type, char *file, int line)
|
|
{
|
|
if (getType(obj) != type) fatal("%s:%d: expected type %d, got %d\n", file, line, type, getType(obj));
|
|
return obj;
|
|
}
|
|
|
|
#define get(OBJ, TYPE,FIELD) (_checkType(OBJ, TYPE, __FILE__, __LINE__)->TYPE.FIELD)
|
|
#define set(OBJ, TYPE,FIELD, VAL) (_checkType(OBJ, TYPE, __FILE__, __LINE__)->TYPE.FIELD = VAL)
|
|
|
|
#ifdef NDEBUG
|
|
# define _get(OBJ, TYPE,FIELD) ((OBJ)->TYPE.FIELD)
|
|
# define _set(OBJ, TYPE,FIELD, VAL) ((OBJ)->TYPE.FIELD = VAL)
|
|
#else
|
|
# define _get(OBJ, TYPE,FIELD) get(OBJ, TYPE,FIELD)
|
|
# define _set(OBJ, TYPE,FIELD, VAL ) set(OBJ, TYPE,FIELD, VAL)
|
|
#endif
|
|
|
|
#define make(TYPE) make_(sizeof(struct TYPE), TYPE)
|
|
|
|
oop make_(size_t size, enum type type)
|
|
{
|
|
oop obj = xmalloc(size);
|
|
obj->type = type;
|
|
return obj;
|
|
}
|
|
|
|
oop newInteger(long value)
|
|
{
|
|
# if TAGS
|
|
return (oop)((intptr_t)value << TAGBITS | TAGINT);
|
|
# else
|
|
oop obj = make(Integer);
|
|
_set(obj, Integer,_value, value);
|
|
return obj;
|
|
# endif
|
|
}
|
|
|
|
#define isInteger(obj) is(Integer, obj)
|
|
|
|
long _integerValue(oop obj)
|
|
{
|
|
# if TAGS
|
|
return (intptr_t)obj >> TAGBITS;
|
|
# else
|
|
return _get(obj, Integer,_value);
|
|
# endif
|
|
}
|
|
|
|
long integerValue(oop obj, char *op)
|
|
{
|
|
if (!isInteger(obj)) fatal("%s: non-integer operand", op);
|
|
return _integerValue(obj);
|
|
}
|
|
|
|
oop newFloat(double value)
|
|
{
|
|
# if TAGS
|
|
union { intptr_t ptr; double dbl; } bits = { .dbl = value };
|
|
return (oop)((bits.ptr & ~TAGMASK) | TAGFLT);
|
|
# else
|
|
oop obj = make(Float);
|
|
_set(obj, Float,_value, value);
|
|
return obj;
|
|
# endif
|
|
}
|
|
|
|
double _floatValue(oop obj)
|
|
{
|
|
# if TAGS
|
|
union { intptr_t ptr; double dbl; } bits = { .ptr = (intptr_t)obj };
|
|
return bits.dbl;
|
|
# else
|
|
return _get(obj, Float,_value);
|
|
# endif
|
|
}
|
|
|
|
double floatValue(oop obj, char *op)
|
|
{
|
|
switch (getType(obj)) {
|
|
case Integer: return (double)_integerValue(obj);
|
|
case Float: return (double)_floatValue(obj);
|
|
default: fatal("%s: non-numeric operand", op);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
oop newStringLen(char *value, int length)
|
|
{
|
|
oop obj = make(String);
|
|
char *str = xmallocAtomic(length+1);
|
|
memcpy(str, value, length);
|
|
str[length] = 0;
|
|
_set(obj, String,length, length);
|
|
_set(obj, String,value, str);
|
|
return obj;
|
|
}
|
|
|
|
oop newString(char *value)
|
|
{
|
|
return newStringLen(value, strlen(value));
|
|
}
|
|
|
|
int digitValue(int digit, int base)
|
|
{
|
|
if ('a' <= digit && digit <= 'z') digit -= 'a' - 10;
|
|
else if ('A' <= digit && digit <= 'Z') digit -= 'A' - 10;
|
|
else if (digit < '0' || digit > '9') return -1;
|
|
return (digit < base) ? digit : -1;
|
|
}
|
|
|
|
int readCharValue(char **stringp, int base, int limit)
|
|
{
|
|
char *string = *stringp;
|
|
int value = 0, d = 0;
|
|
while (limit-- && *string && (d = digitValue(*string, base)) >= 0) {
|
|
++string;
|
|
value = value * base + d;
|
|
}
|
|
*stringp = string;
|
|
return value;
|
|
}
|
|
|
|
int String_length(oop str) { return get(str, String,length); }
|
|
oop String_reset (oop str) { set(str, String,length, 0); return str; }
|
|
|
|
void String_clear(oop str)
|
|
{
|
|
set(str, String,length, 0);
|
|
set(str, String,value, 0);
|
|
}
|
|
|
|
oop String_append(oop str, int c)
|
|
{
|
|
int length = get(str, String,length);
|
|
char *value = get(str, String,value);
|
|
value = xrealloc(value, length + 1);
|
|
set(str, String,value, value);
|
|
set(str, String,length, length+1);
|
|
value[length] = c;
|
|
return str;
|
|
}
|
|
|
|
oop String_appendAllLen(oop str, char *s, int len)
|
|
{
|
|
int length = get(str, String,length);
|
|
char *value = get(str, String,value);
|
|
value = xrealloc(value, length + len);
|
|
memcpy(value + length, s, len);
|
|
set(str, String,value, value);
|
|
set(str, String,length, length+len);
|
|
return str;
|
|
}
|
|
|
|
oop String_appendAll(oop str, char *s)
|
|
{
|
|
return String_appendAllLen(str, s, strlen(s));
|
|
}
|
|
|
|
oop String_format(oop str, char *fmt, ...)
|
|
{
|
|
size_t len = 0, cap = 16;
|
|
int length = get(str, String,length);
|
|
char *value = get(str, String,value);
|
|
for (;;) {
|
|
value = xrealloc(value, length + cap);
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
len = vsnprintf(value + length, cap, fmt, ap);
|
|
va_end(ap);
|
|
if (len < cap) break;
|
|
cap += len;
|
|
}
|
|
set(str, String,value, value);
|
|
set(str, String,length, length+len);
|
|
return str;
|
|
}
|
|
|
|
char *String_content(oop str)
|
|
{
|
|
String_append(str, 0);
|
|
_get(str, String,length) -= 1;
|
|
return _get(str, String,value);
|
|
}
|
|
|
|
oop newStringEscaped(char *string)
|
|
{
|
|
oop buf = newStringLen(0, 0);
|
|
while (*string) {
|
|
int c = *string++;
|
|
if ('\\' == c && *string) {
|
|
c = *string++; assert(c != 0);
|
|
switch (c) {
|
|
case '\"': c = '\"'; break;
|
|
case '\'': c = '\''; break;
|
|
case '\\': c = '\\'; break;
|
|
case 'a' : c = '\a'; break;
|
|
case 'b' : c = '\b'; break;
|
|
case 'f' : c = '\f'; break;
|
|
case 'n' : c = '\n'; break;
|
|
case 'r' : c = '\r'; break;
|
|
case 't' : c = '\t'; break;
|
|
case 'v' : c = '\v'; break;
|
|
case 'X' :
|
|
case 'x' : c = readCharValue(&string, 16, -1); break;
|
|
case '0' : c = readCharValue(&string, 8, 3); break;
|
|
default : fatal("illegal character escape sequence"); break;
|
|
}
|
|
}
|
|
String_append(buf, c);
|
|
}
|
|
return buf;
|
|
}
|
|
|
|
oop newSymbol(char *name)
|
|
{
|
|
oop obj = make(Symbol);
|
|
_set(obj, Symbol,name, strdup(name));
|
|
_set(obj, Symbol,value, UNDEFINED);
|
|
return obj;
|
|
}
|
|
|
|
char *stringValue(oop obj, char *who)
|
|
{
|
|
int type = getType(obj);
|
|
if (type == String) return _get(obj, String,value);
|
|
if (type == Symbol) return _get(obj, Symbol,name);
|
|
fatal("%s: non-string operand", who);
|
|
return 0;
|
|
}
|
|
|
|
oop newPrimitive(prim_t function)
|
|
{
|
|
oop obj = make(Primitive);
|
|
_set(obj, Primitive,name, 0);
|
|
_set(obj, Primitive,function, function);
|
|
return obj;
|
|
}
|
|
|
|
#if PRIMCLOSURE
|
|
|
|
oop newLambda(oop parameters, oop body)
|
|
{
|
|
oop obj = make(Lambda);
|
|
_set(obj, Lambda,parameters, parameters);
|
|
_set(obj, Lambda,body, body);
|
|
return obj;
|
|
}
|
|
|
|
oop newClosure(oop function, oop environment)
|
|
{
|
|
oop obj = make(Closure);
|
|
_set(obj, Closure,function, function);
|
|
_set(obj, Closure,environment, environment);
|
|
return obj;
|
|
}
|
|
|
|
int isClosure(oop obj) { return is(Closure, obj); }
|
|
|
|
#endif
|
|
|
|
oop macros = 0;
|
|
oop *symbols = 0;
|
|
size_t nsymbols = 0;
|
|
|
|
oop intern(char *name)
|
|
{
|
|
ssize_t lo = 0, hi = nsymbols - 1;
|
|
while (lo <= hi) {
|
|
ssize_t mid = (lo + hi) / 2;
|
|
oop sym = symbols[mid];
|
|
int cmp = strcmp(name, _get(sym, Symbol,name));
|
|
if (cmp < 0) hi = mid - 1;
|
|
else if (cmp > 0) lo = mid + 1;
|
|
else return sym;
|
|
}
|
|
symbols = xrealloc(symbols, sizeof(*symbols) * ++nsymbols);
|
|
memmove(symbols + lo + 1, symbols + lo, sizeof(*symbols) * (nsymbols - 1 - lo));
|
|
return symbols[lo] = newSymbol(name);
|
|
}
|
|
|
|
oop Object_at(oop obj, size_t index)
|
|
{
|
|
size_t size = get(obj, Object,isize);
|
|
if (index >= size) fatal("index %zd out of range (%zd)", index, size);
|
|
return _get(obj, Object,indexed)[index];
|
|
}
|
|
|
|
oop Object_atPut(oop obj, size_t index, oop val)
|
|
{
|
|
size_t size = get(obj, Object,isize);
|
|
if (index >= size) fatal("index %zd out of range (%zd)", index, size);
|
|
return _get(obj, Object,indexed)[index] = val;
|
|
}
|
|
|
|
oop Object_push(oop obj, oop val)
|
|
{
|
|
size_t size = get(obj, Object,isize);
|
|
size_t cap = _get(obj, Object,icap );
|
|
oop *indexed = _get(obj, Object,indexed);
|
|
if (size >= cap) {
|
|
cap = cap ? cap * 2 : 4;
|
|
indexed = xrealloc(indexed, sizeof(*indexed) * cap);
|
|
_set(obj, Object,icap, cap);
|
|
_set(obj, Object,indexed, indexed);
|
|
}
|
|
indexed[size++] = val;
|
|
_set(obj, Object,isize, size);
|
|
return val;
|
|
}
|
|
|
|
oop Object_pop(oop obj)
|
|
{
|
|
size_t size = get(obj, Object,isize);
|
|
if (!size) fatal("pop: object is empty");
|
|
oop *indexed = _get(obj, Object,indexed);
|
|
oop result = indexed[--size];
|
|
_set(obj, Object,isize, size);
|
|
return result;
|
|
}
|
|
|
|
ssize_t Object_find(oop obj, oop key)
|
|
{
|
|
ssize_t hi = get(obj, Object,psize) - 1; // asserts obj is Object
|
|
if (hi < 0) return -1;
|
|
struct property *kvs = _get(obj, Object,properties);
|
|
ssize_t lo = 0;
|
|
while (lo <= hi) {
|
|
ssize_t mid = (lo + hi) / 2;
|
|
oop midkey = kvs[mid].key;
|
|
if (key < midkey) hi = mid - 1;
|
|
else if (key > midkey) lo = mid + 1;
|
|
else return mid;
|
|
}
|
|
return -1 - lo;
|
|
}
|
|
|
|
oop Object_getLocal(oop obj, oop key)
|
|
{
|
|
if (!is(Object, obj)) return nil;
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) return _get(obj, Object,properties)[ind].val;
|
|
return nil;
|
|
}
|
|
|
|
#if DELOPT
|
|
# define _getDelegate(OBJ) _get(OBJ, Object,delegate)
|
|
# define _setDelegate(OBJ, VAL) _set(OBJ, Object,delegate, VAL)
|
|
#else
|
|
# define _getDelegate(OBJ) Object_getLocal(OBJ, prop_delegate)
|
|
# define _setDelegate(OBJ, VAL) Object_put(OBJ, prop_delegate, VAL)
|
|
#endif
|
|
|
|
char *storeString(oop obj, int indent);
|
|
|
|
oop Object_get(oop obj, oop key)
|
|
{
|
|
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) ? 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;
|
|
}
|
|
}
|
|
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);
|
|
}
|
|
fatal("undefined property: %s.%s", storeString(obj, 0), storeString(key, 0));
|
|
return nil;
|
|
}
|
|
|
|
oop getvar(oop obj, oop key)
|
|
{
|
|
while (is(Object, obj)) {
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) return _get(obj, Object,properties)[ind].val;
|
|
obj = _getDelegate(obj);
|
|
}
|
|
oop value = _get(key, Symbol,value); // asserts is(Symbol,key)
|
|
if (!value) fatal("undefined variable: %s", storeString(key, 0));
|
|
return value;
|
|
}
|
|
|
|
oop setvar(oop obj, oop key, oop val)
|
|
{
|
|
while (is(Object, obj)) {
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) return _get(obj, Object,properties)[ind].val = val;
|
|
obj = _getDelegate(obj);
|
|
}
|
|
return is(Symbol, key) ? _set(key, Symbol,value, val) : nil;
|
|
}
|
|
|
|
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) {
|
|
# if DELOPT
|
|
if (key == prop_delegate) return _setDelegate(obj, val);
|
|
# endif
|
|
int size = _get(obj, Object,psize);
|
|
ind = -1 - ind; assert(0 <= ind && ind <= size);
|
|
kvs = xrealloc(kvs, sizeof(*kvs) * ++size);
|
|
_set(obj, Object,properties, kvs);
|
|
_set(obj, Object,psize, size);
|
|
memmove(kvs + ind + 1, kvs + ind, sizeof(*kvs) * (size - 1 - ind));
|
|
kvs[ind].key = key;
|
|
} assert(ind < _get(obj, Object,psize));
|
|
assert(kvs[ind].key == key);
|
|
return kvs[ind].val = val;
|
|
}
|
|
|
|
oop new(oop delegate)
|
|
{
|
|
oop obj = make(Object);
|
|
_set(obj, Object,isize, 0);
|
|
_set(obj, Object,icap, 0);
|
|
_set(obj, Object,indexed, 0);
|
|
# if DELOPT
|
|
_set(obj, Object,psize, 0);
|
|
_setDelegate(obj, delegate);
|
|
# else
|
|
_set(obj, Object,psize, 1);
|
|
_set(obj, Object,properties, xmalloc(sizeof(struct property)))
|
|
[0] = (struct property) { prop_delegate, delegate };
|
|
# endif
|
|
return obj;
|
|
}
|
|
|
|
oop newObjectWith(int isize, oop *indexed, int psize, struct property *properties)
|
|
{
|
|
oop obj = make(Object);
|
|
_set(obj, Object,isize, isize);
|
|
_set(obj, Object,icap, isize);
|
|
_set(obj, Object,psize, psize);
|
|
_set(obj, Object,indexed, indexed);
|
|
_set(obj, Object,properties, properties);
|
|
# if DELOPT
|
|
_setDelegate(obj, nil);
|
|
# endif
|
|
return obj;
|
|
}
|
|
|
|
oop apply(oop func, oop self, oop args, oop env);
|
|
|
|
oop codeOn(oop buf, oop obj, int indent);
|
|
oop storeOn(oop buf, oop obj, int indent);
|
|
oop printOn(oop buf, oop obj, int indent);
|
|
|
|
void codeParametersOn(oop str, oop object, char *begin, char *end)
|
|
{
|
|
String_appendAll(str, begin);
|
|
oop *indexed = _get(object, Object,indexed);
|
|
int isize = _get(object, Object,isize);
|
|
int i;
|
|
for (i = 0; i < isize; ++i) {
|
|
if (i) String_appendAll(str, ", ");
|
|
printOn(str, indexed[i], 0);
|
|
}
|
|
String_appendAll(str, end);
|
|
}
|
|
|
|
void codeBlockOn(oop str, oop object)
|
|
{
|
|
String_appendAll(str, "{");
|
|
oop *indexed = _get(object, Object,indexed);
|
|
int isize = _get(object, Object,isize);
|
|
int i;
|
|
for (i = 0; i < isize; ++i) {
|
|
if (i) String_appendAll(str, "; "); else String_appendAll(str, " ");
|
|
codeOn(str, indexed[i], 0);
|
|
}
|
|
if (isize) String_appendAll(str, " ");
|
|
String_appendAll(str, "}");
|
|
}
|
|
|
|
oop codeOn(oop str, oop obj, int indent)
|
|
{
|
|
switch (getType(obj)) {
|
|
case Undefined: String_appendAll(str, "nil"); break;
|
|
case Integer: String_format(str, "%ld", _integerValue(obj)); break;
|
|
case Float: String_format(str, "%f" , _floatValue(obj)); break;
|
|
case String: storeOn(str, obj, 0); break;
|
|
case Symbol: String_format(str, "#%s", _get(obj, Symbol,name)); break;
|
|
case Primitive: {
|
|
String_appendAll(str, "<primitive ");
|
|
if (_get(obj, Primitive,name)) codeOn(str, _get(obj, Primitive,name), indent);
|
|
else String_format(str, "%p", _get(obj, Primitive,function));
|
|
String_append(str, '>');
|
|
break;
|
|
}
|
|
#if PRIMCLOSURE
|
|
case Lambda: {
|
|
codeParametersOn(str, _get(obj, Lambda,parameters), "(", ")");
|
|
codeBlockOn(str, _get(obj, Lambda,body));
|
|
break;
|
|
}
|
|
case Closure: {
|
|
String_appendAll(str, "<closure>");
|
|
break;
|
|
}
|
|
#endif
|
|
case Object: {
|
|
oop evaluator = Object_get(obj, prop_codeon);
|
|
oop args = new(pObject);
|
|
Object_push(args, str);
|
|
apply(evaluator, obj, args, nil);
|
|
break;
|
|
}
|
|
default:
|
|
assert(!"this cannot happen");
|
|
}
|
|
return str;
|
|
}
|
|
|
|
oop printOn(oop buf, oop obj, int indent)
|
|
{
|
|
switch (getType(obj)) {
|
|
case Undefined: String_appendAll(buf, "nil"); break;
|
|
case Integer: String_format(buf, "%ld", _integerValue(obj)); break;
|
|
case Float: String_format(buf, "%f" , _floatValue(obj)); break;
|
|
case String: String_format(buf, "%.*s", (int)_get(obj, String,length), _get(obj, String,value)); break;
|
|
case Symbol: String_appendAll(buf, _get(obj, Symbol,name)); break;
|
|
case Primitive: {
|
|
String_appendAll(buf, "<primitive ");
|
|
if (_get(obj, Primitive,name)) printOn(buf, _get(obj, Primitive,name), indent);
|
|
else String_format(buf, "%p", _get(obj, Primitive,function));
|
|
String_append(buf, '>');
|
|
break;
|
|
}
|
|
#if PRIMCLOSURE
|
|
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;
|
|
oop proto = obj;
|
|
oop name = nil;
|
|
do {
|
|
++level;
|
|
name = Object_getLocal(proto, prop_name);
|
|
if (nil != name) break;
|
|
proto = _getDelegate(proto);
|
|
} while (is(Object, proto));
|
|
for (int i = level; i--;) String_append(buf, '<');
|
|
if (name != nil)
|
|
printOn(buf, name, indent);
|
|
else
|
|
String_appendAll(buf, "?");
|
|
for (int i = level; i--;) String_append(buf, '>');
|
|
if (!indent) break;
|
|
for (;;) {
|
|
int psize = _get(obj, Object,psize);
|
|
struct property *props = _get(obj, Object,properties);
|
|
for (int i = 0; i < psize; ++i) {
|
|
if (prop_delegate == props[i].key) continue;
|
|
String_append(buf, '\n');
|
|
for (int j = indent; j--;) String_appendAll(buf, " | ");
|
|
String_appendAll(buf, " ");
|
|
printOn(buf, props[i].key, indent+1);
|
|
String_appendAll(buf, ": ");
|
|
printOn(buf, props[i].val, indent+1);
|
|
}
|
|
int isize = _get(obj, Object,isize);
|
|
oop *indexed = _get(obj, Object,indexed);
|
|
for (int i = 0; i < isize; ++i) {
|
|
String_append(buf, '\n');
|
|
for (int j = indent; j--;) String_appendAll(buf, " | ");
|
|
String_format(buf, " %d: ", i);
|
|
printOn(buf, indexed[i], indent+1);
|
|
}
|
|
oop delegate = _getDelegate(obj);
|
|
if (nil == delegate) break;
|
|
if (nil != Object_getLocal(delegate, prop_name)) break;
|
|
obj = delegate;
|
|
// ++indent;
|
|
String_appendAll(buf, " =>");
|
|
}
|
|
break;
|
|
}
|
|
default:
|
|
assert(!"this cannot happen");
|
|
}
|
|
return buf;
|
|
}
|
|
|
|
oop storeOn(oop buf, oop obj, int indent)
|
|
{
|
|
switch (getType(obj)) {
|
|
case String: {
|
|
String_append(buf, '"');
|
|
char *str = _get(obj, String,value);
|
|
int len = _get(obj, String,length);
|
|
for (int i = 0; i < len; ++i) {
|
|
int c = str[i];
|
|
switch (c) {
|
|
case '\a': String_appendAll(buf, "\\a"); break;
|
|
case '\b': String_appendAll(buf, "\\b"); break;
|
|
case '\f': String_appendAll(buf, "\\f"); break;
|
|
case '\n': String_appendAll(buf, "\\n"); break;
|
|
case '\r': String_appendAll(buf, "\\r"); break;
|
|
case '\t': String_appendAll(buf, "\\t"); break;
|
|
case '\v': String_appendAll(buf, "\\v"); break;
|
|
case '"': String_appendAll(buf, "\\\""); break;
|
|
case '\\': String_appendAll(buf, "\\\\"); break;
|
|
default:
|
|
if (c < ' ' || c > '~') String_format(buf, "\\%04o", c);
|
|
else String_append(buf, c);
|
|
break;
|
|
}
|
|
}
|
|
String_append(buf, '"');
|
|
break;
|
|
}
|
|
default: printOn(buf, obj, indent);
|
|
}
|
|
return buf;
|
|
}
|
|
|
|
char *codeString(oop obj, int indent)
|
|
{
|
|
oop str = newStringLen(0, 0);
|
|
codeOn(str, obj, indent);
|
|
return String_content(str);
|
|
}
|
|
|
|
void code(oop obj, int indent)
|
|
{
|
|
printf("%s", codeString(obj, indent));
|
|
}
|
|
|
|
void codeln(oop obj, int indent)
|
|
{
|
|
code(obj, indent);
|
|
printf("\n");
|
|
}
|
|
|
|
char *printString(oop obj, int indent)
|
|
{
|
|
oop buf = newStringLen(0, 0);
|
|
printOn(buf, obj, indent);
|
|
return String_content(buf);
|
|
}
|
|
|
|
void print(oop obj, int indent)
|
|
{
|
|
printf("%s", printString(obj, indent));
|
|
}
|
|
|
|
void println(oop obj, int indent)
|
|
{
|
|
print(obj, indent);
|
|
printf("\n");
|
|
}
|
|
|
|
char *storeString(oop obj, int indent)
|
|
{
|
|
oop buf = newStringLen(0, 0);
|
|
storeOn(buf, obj, indent);
|
|
return String_content(buf);
|
|
}
|
|
|
|
void store(oop obj, int indent)
|
|
{
|
|
printf("%s", storeString(obj, indent));
|
|
}
|
|
|
|
void storeln(oop obj, int indent)
|
|
{
|
|
store(obj, indent);
|
|
printf("\n");
|
|
}
|
|
|
|
char *filename = "<stdin>";
|
|
int lineno = 1;
|
|
|
|
oop trace = nil;
|
|
|
|
void fatal(char *fmt, ...)
|
|
{
|
|
fflush(stdout);
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
fprintf(stderr, "\n%s:%d: ", filename, lineno);
|
|
vfprintf(stderr, fmt, ap);
|
|
fprintf(stderr, "\n");
|
|
va_end(ap);
|
|
if (is(Object, trace)) {
|
|
int w = 1 + log10(_get(trace, Object,isize));
|
|
for (int i = _get(trace, Object,isize); i--;) {
|
|
printf("%*d: ", w, i);
|
|
codeln(_get(trace, Object,indexed)[i], 1);
|
|
}
|
|
}
|
|
exit(1);
|
|
}
|
|
|
|
#include <signal.h>
|
|
|
|
void sigint(int sig)
|
|
{
|
|
fatal("keyboard interrupt");
|
|
}
|
|
|
|
typedef struct Input {
|
|
struct Input *next;
|
|
char *text;
|
|
int size;
|
|
int position;
|
|
} Input;
|
|
|
|
Input *newInput(void)
|
|
{
|
|
return xmalloc(sizeof(Input));
|
|
}
|
|
|
|
Input *input = 0;
|
|
|
|
Input *makeInput(void)
|
|
{
|
|
return xmalloc(sizeof(Input));
|
|
}
|
|
|
|
#define YYSTYPE oop
|
|
|
|
#define YY_MALLOC(C, N) GC_malloc(N)
|
|
#define YY_REALLOC(C, P, N) GC_realloc(P, N)
|
|
#define YY_FREE(C, P) GC_free(P)
|
|
|
|
#define YY_INPUT(buf, result, max_size) \
|
|
{ \
|
|
result= (input->position >= input->size) \
|
|
? 0 \
|
|
: ((*(buf)= input->text[input->position++]), 1); \
|
|
/* printf("<%c>", *(buf)); */ \
|
|
}
|
|
|
|
YYSTYPE yysval = 0;
|
|
|
|
oop eval(oop exp, oop env);
|
|
oop evargs(oop list, oop env);
|
|
|
|
oop Object_eval(oop exp, oop env) { return exp; }
|
|
|
|
void Object_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
storeOn(str, exp, 0);
|
|
}
|
|
|
|
oop newGetVar(oop name)
|
|
{
|
|
oop o = new(pGetVar);
|
|
Object_put(o, sym_name, name);
|
|
return o;
|
|
}
|
|
|
|
oop GetVar_eval(oop exp, oop env) { return getvar(env, Object_get(exp, sym_name)); }
|
|
|
|
void GetVar_codeOn(oop exp, oop str, oop env) { printOn(str, Object_get(exp, sym_name), 0); }
|
|
|
|
oop newSetVar(oop name, oop expr)
|
|
{
|
|
oop o = new(pSetVar);
|
|
Object_put(o, sym_name, name);
|
|
Object_put(o, sym_expr, expr);
|
|
return o;
|
|
}
|
|
|
|
oop SetVar_eval(oop exp, oop env)
|
|
{
|
|
oop key = Object_get(exp, sym_name) ;
|
|
oop val = eval(Object_get(exp, sym_expr), env);
|
|
return setvar(env, key, val);
|
|
}
|
|
|
|
void SetVar_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
printOn(str, Object_get(exp, sym_name), 0);
|
|
String_appendAll(str, " = ");
|
|
codeOn(str, Object_get(exp, sym_expr), 0);
|
|
}
|
|
|
|
oop newGetProp(oop object, oop key)
|
|
{
|
|
oop o = new(pGetProp);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_key , key );
|
|
return o;
|
|
}
|
|
|
|
oop GetProp_eval(oop exp, oop env)
|
|
{
|
|
oop obj = eval(Object_get(exp, sym_object), env);
|
|
oop key = Object_get(exp, sym_key ) ;
|
|
return Object_get(obj, key);
|
|
}
|
|
|
|
void GetProp_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeOn(str, Object_get(exp, sym_object), 0);
|
|
String_appendAll(str, ".");
|
|
printOn(str, Object_get(exp, sym_key ), 0);
|
|
}
|
|
|
|
oop newSetProp(oop object, oop key, oop value)
|
|
{
|
|
oop o = new(pSetProp);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_key , key );
|
|
Object_put(o, sym_value , value );
|
|
return o;
|
|
}
|
|
|
|
oop SetProp_eval(oop exp, oop env)
|
|
{
|
|
oop obj = eval(Object_get(exp, sym_object), env);
|
|
oop key = Object_get(exp, sym_key ) ;
|
|
oop val = eval(Object_get(exp, sym_value ), env);
|
|
return Object_put(obj, key, val);
|
|
}
|
|
|
|
void SetProp_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeOn(str, Object_get(exp, sym_object), 0);
|
|
oop key = Object_get(exp, sym_key);
|
|
if (is(Symbol,key)) {
|
|
String_appendAll(str, ".");
|
|
printOn(str, key, 0);
|
|
}
|
|
else {
|
|
String_appendAll(str, "[");
|
|
codeOn(str, key, 0);
|
|
String_appendAll(str, "]");
|
|
}
|
|
String_appendAll(str, " = ");
|
|
codeOn(str, Object_get(exp, sym_value ), 0);
|
|
}
|
|
|
|
oop newGetArray(oop object, oop index)
|
|
{
|
|
oop o = new(pGetArray);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_index , index );
|
|
return o;
|
|
}
|
|
|
|
void oob(oop obj, int index)
|
|
{
|
|
fatal("[]: index %d out of bounds in %s", index, storeString(obj, 0));
|
|
}
|
|
|
|
char *String_aref(oop obj, int index)
|
|
{
|
|
if (index >= _get(obj, String,length)) oob(obj, index);
|
|
return _get(obj, String,value) + index;
|
|
}
|
|
|
|
char *Symbol_aref(oop obj, int index)
|
|
{
|
|
if (index >= strlen(_get(obj, Symbol,name))) oob(obj, index);
|
|
return _get(obj, Symbol,name) + index;
|
|
}
|
|
|
|
oop *Object_aref(oop obj, int index)
|
|
{
|
|
if (index >= _get(obj, Object,isize)) oob(obj, index);
|
|
return _get(obj, Object,indexed) + index;
|
|
}
|
|
|
|
oop GetArray_eval(oop exp, oop env)
|
|
{
|
|
oop obj = eval(Object_get(exp, sym_object), env);
|
|
oop ind = eval(Object_get(exp, sym_index ), env);
|
|
if (isInteger(ind)) {
|
|
int index = _integerValue(ind);
|
|
switch (getType(obj)) {
|
|
case String: return newInteger(*String_aref(obj, index));
|
|
case Symbol: return newInteger(*Symbol_aref(obj, index));
|
|
case Object: return *Object_aref(obj, index);
|
|
default: fatal("[]: %s is not indexable", storeString(obj, 0));
|
|
}
|
|
}
|
|
if (!is(Object, obj)) fatal("[]: %s is not an object", storeString(obj, 0));
|
|
return Object_getLocal(obj, ind);
|
|
}
|
|
|
|
void GetArray_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeOn(str, Object_get(exp, sym_object), 0);
|
|
String_appendAll(str, "[");
|
|
codeOn(str, Object_get(exp, sym_index), 0);
|
|
String_appendAll(str, "]");
|
|
}
|
|
|
|
oop newSetArray(oop object, oop index, oop value)
|
|
{
|
|
oop o = new(pSetArray);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_index , index );
|
|
Object_put(o, sym_value , value );
|
|
return o;
|
|
}
|
|
|
|
oop SetArray_eval(oop exp, oop env)
|
|
{
|
|
oop obj = eval(Object_get(exp, sym_object), env);
|
|
oop ind = eval(Object_get(exp, sym_index ), env);
|
|
oop val = eval(Object_get(exp, sym_value ), env);
|
|
if (isInteger(ind)) {
|
|
int index = _integerValue(ind);
|
|
switch (getType(obj)) {
|
|
case String: *String_aref(obj, index) = integerValue(val, "[]="); break;
|
|
case Symbol: *Symbol_aref(obj, index) = integerValue(val, "[]="); break;
|
|
case Object: *Object_aref(obj, index) = val; break;
|
|
default: fatal("[]=: %s is not indexable", storeString(obj, 0));
|
|
}
|
|
return val;
|
|
}
|
|
if (!is(Object, obj)) fatal("[]=: %s is not an object", storeString(obj, 0));
|
|
return Object_put(obj, ind, val);
|
|
}
|
|
|
|
void SetArray_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeOn(str, Object_get(exp, sym_object), 0);
|
|
String_appendAll(str, "[");
|
|
codeOn(str, Object_get(exp, sym_index), 0);
|
|
String_appendAll(str, "] = ");
|
|
codeOn(str, Object_get(exp, sym_value), 0);
|
|
}
|
|
|
|
oop newCall(oop function, oop arguments)
|
|
{
|
|
oop o = new(pCall);
|
|
Object_put(o, sym_function , function );
|
|
Object_put(o, sym_arguments, arguments);
|
|
return o;
|
|
}
|
|
|
|
oop newApply(oop function, oop arguments)
|
|
{
|
|
if (_getDelegate(function) == pGetVar) {
|
|
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);
|
|
}
|
|
return newCall(function, 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)
|
|
{
|
|
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);
|
|
}
|
|
|
|
void codeArgumentsOn(oop str, oop object, char *begin, char *end)
|
|
{
|
|
String_appendAll(str, begin);
|
|
oop *indexed = _get(object, Object,indexed);
|
|
int isize = _get(object, Object,isize);
|
|
int i;
|
|
for (i = 0; i < isize; ++i) {
|
|
if (i) String_appendAll(str, ", ");
|
|
codeOn(str, indexed[i], 0);
|
|
}
|
|
struct property *kvs = _get(object, Object,properties);
|
|
int psize = _get(object, Object,psize);
|
|
for (int j = 0; j < psize; ++j) {
|
|
if (prop_delegate == kvs[j].key && pObject == kvs[j].val) continue;
|
|
if (i++) String_appendAll(str, ", ");
|
|
printOn(str, kvs[j].key, 0);
|
|
String_appendAll(str, ": ");
|
|
codeOn(str, kvs[j].val, 0);
|
|
}
|
|
String_appendAll(str, end);
|
|
}
|
|
|
|
void Call_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeOn(str, Object_get(exp, sym_function ), 0);
|
|
codeArgumentsOn(str, Object_get(exp, sym_arguments), "(", ")");
|
|
}
|
|
|
|
oop newInvoke(oop self, oop method, oop arguments)
|
|
{
|
|
oop o = new(pInvoke);
|
|
Object_put(o, sym_self , self );
|
|
Object_put(o, sym_method , method );
|
|
Object_put(o, sym_arguments, arguments);
|
|
return o;
|
|
}
|
|
|
|
oop Invoke_eval(oop exp, oop env)
|
|
{
|
|
oop self = eval (Object_get(exp, sym_self ), env);
|
|
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);
|
|
}
|
|
|
|
void Invoke_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeOn(str, Object_get(exp, sym_self ), 0);
|
|
String_appendAll(str, ".");
|
|
printOn(str, Object_get(exp, sym_method ), 0);
|
|
codeArgumentsOn(str, Object_get(exp, sym_arguments), "(", ")");
|
|
}
|
|
|
|
#if !PRIMCLOSURE
|
|
|
|
oop newLambda(oop parameters, oop body)
|
|
{
|
|
oop o = new(pLambda);
|
|
Object_put(o, sym_parameters, parameters);
|
|
Object_put(o, sym_body , 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);
|
|
}
|
|
|
|
void Lambda_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeParametersOn(str, Object_get(exp, sym_parameters), "(", ")");
|
|
codeBlockOn(str, Object_get(exp, sym_body));
|
|
}
|
|
|
|
oop Closure_eval(oop exp, oop env)
|
|
{
|
|
return exp;
|
|
}
|
|
|
|
void Closure_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
assert(!"this cannot happen");
|
|
}
|
|
|
|
#endif // !PRIMCLOSURE
|
|
|
|
#define doBinops(_) \
|
|
_(opLogOr, ||) \
|
|
_(opLogAnd, &&) \
|
|
_(opBitOr, |) \
|
|
_(opBitXor, ^) \
|
|
_(opBitAnd, &) \
|
|
_(opEq, ==) _(opNotEq, !=) \
|
|
_(opLess, < ) _(opLessEq, <=) _(opGrtr, >=) _(opGrtrEq, > ) \
|
|
_(opShl, <<) _(opShr, >>) \
|
|
_(opAdd, +) _(opSub, -) \
|
|
_(opMul, *) _(opDiv, /) _(opMod, %)
|
|
|
|
#define defineBinop(NAME, OP) NAME,
|
|
enum binop {
|
|
doBinops(defineBinop)
|
|
};
|
|
#undef defineBinop
|
|
|
|
#define nameBinop(NAME, OP) #OP,
|
|
char *binopNames[] = {
|
|
doBinops(nameBinop)
|
|
};
|
|
#undef nameBinop
|
|
|
|
oop newBinop(int operation, oop lhs, oop rhs)
|
|
{
|
|
oop o = new(pBinop);
|
|
Object_put(o, sym_operation, newInteger(operation));
|
|
Object_push(o, lhs);
|
|
Object_push(o, rhs);
|
|
return o;
|
|
}
|
|
|
|
intptr_t cmp(oop l, oop r, char *who)
|
|
{
|
|
int tl = getType(l), tr = getType(r);
|
|
if (Integer == tl && Integer == tr) return _integerValue(l) - _integerValue(r);
|
|
if (Float == tl || Float == tr) return floatValue(l, who) - floatValue(r, who);
|
|
if (String == tl || String == tr) return strcmp(stringValue(l, who), stringValue(r, who));
|
|
if (Symbol == tl || Symbol == tr) return strcmp(stringValue(l, who), stringValue(r, who));
|
|
return (intptr_t)l - (intptr_t)r;
|
|
}
|
|
|
|
oop shl(oop l, oop r)
|
|
{
|
|
int tl = getType(l), tr = getType(r);
|
|
if (Integer == tl && Integer == tr)
|
|
return newInteger(_integerValue(l) << _integerValue(r));
|
|
fatal("<<: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
|
|
return 0;
|
|
}
|
|
|
|
oop shr(oop l, oop r)
|
|
{
|
|
int tl = getType(l), tr = getType(r);
|
|
if (Integer == tl && Integer == tr)
|
|
return newInteger(_integerValue(l) >> _integerValue(r));
|
|
fatal(">>: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
|
|
return 0;
|
|
}
|
|
|
|
#define binop(NAME, OP) \
|
|
oop NAME(oop l, oop r) \
|
|
{ \
|
|
int tl = getType(l), tr = getType(r); \
|
|
if (Integer == tl && Integer == tr) return newInteger(_integerValue(l ) OP _integerValue(r )); \
|
|
if (Float == tl || Float == tr) return newFloat ( floatValue(l, #OP) OP floatValue(r, #OP)); \
|
|
fatal(#OP": illegal operand types %s and %s", getTypeName(l), getTypeName(r)); \
|
|
return 0; \
|
|
}
|
|
|
|
binop(add, +);
|
|
binop(sub, -);
|
|
binop(mul, *);
|
|
|
|
#undef binop
|
|
|
|
oop quo(oop l, oop r)
|
|
{
|
|
int tl = getType(l), tr = getType(r);
|
|
if (Integer == tl && Integer == tr) {
|
|
long vl = _integerValue(l), vr = _integerValue(r);
|
|
ldiv_t qr = ldiv(vl, vr);
|
|
if (!qr.rem) return newInteger(qr.quot); // division was exact
|
|
return newFloat((double)vl / (double)vr);
|
|
}
|
|
if (Float == tl || Float == tr) return newFloat (floatValue(l, "/") / floatValue(r, "/"));
|
|
fatal("/: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
|
|
return 0;
|
|
}
|
|
|
|
oop rem(oop l, oop r)
|
|
{
|
|
int tl = getType(l), tr = getType(r);
|
|
if (Integer == tl && Integer == tr) return newInteger( _integerValue(l) % _integerValue(r ) );
|
|
if (Float == tl || Float == tr) return newFloat (fmod(floatValue(l, "%"), floatValue(r, "%")));
|
|
fatal("/: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
|
|
return 0;
|
|
}
|
|
|
|
#define newBoolean(TF) ((TF) ? sym_t : nil)
|
|
|
|
oop Binop_eval(oop exp, oop env)
|
|
{ assert(_get(exp, Object,isize) == 2);
|
|
oop op = Object_get(exp, sym_operation);
|
|
oop lhs = _get(exp, Object,indexed)[0];
|
|
oop rhs = _get(exp, Object,indexed)[1];
|
|
enum binop code = integerValue(op, "Binop.operation");
|
|
lhs = eval(lhs, env);
|
|
switch (code) {
|
|
case opLogOr: return nil != lhs ? lhs : eval(rhs, env);
|
|
case opLogAnd: return nil == lhs ? lhs : eval(rhs, env);
|
|
default: break;
|
|
}
|
|
rhs = eval(rhs, env);
|
|
switch (code) {
|
|
case opBitOr: return newInteger(integerValue(lhs, "|") | integerValue(rhs, "|"));
|
|
case opBitXor: return newInteger(integerValue(lhs, "^") ^ integerValue(rhs, "^"));
|
|
case opBitAnd: return newInteger(integerValue(lhs, "&") & integerValue(rhs, "&"));
|
|
case opEq: return newBoolean(cmp(lhs, rhs, "==") == 0);
|
|
case opNotEq: return newBoolean(cmp(lhs, rhs, "!=") != 0);
|
|
case opLess: return newBoolean(cmp(lhs, rhs, "<" ) < 0);
|
|
case opLessEq: return newBoolean(cmp(lhs, rhs, "<=") <= 0);
|
|
case opGrtrEq: return newBoolean(cmp(lhs, rhs, ">=") >= 0);
|
|
case opGrtr: return newBoolean(cmp(lhs, rhs, ">" ) > 0);
|
|
case opShl: return shl(lhs, rhs);
|
|
case opShr: return shr(lhs, rhs);
|
|
case opAdd: return add(lhs, rhs);
|
|
case opSub: return sub(lhs, rhs);
|
|
case opMul: return mul(lhs, rhs);
|
|
case opDiv: return quo(lhs, rhs);
|
|
case opMod: return rem(lhs, rhs);
|
|
default: break;
|
|
}
|
|
fatal("illegal binary operation %d", code);
|
|
return 0;
|
|
}
|
|
|
|
void Binop_codeOn(oop exp, oop str, oop env)
|
|
{ assert(_get(exp, Object,isize) == 2);
|
|
oop op = Object_get(exp, sym_operation);
|
|
oop lhs = _get(exp, Object,indexed)[0];
|
|
oop rhs = _get(exp, Object,indexed)[1];
|
|
codeOn(str, lhs, 0);
|
|
enum binop code = integerValue(op, "Binop.operation");
|
|
assert(0 <= code && code <= indexableSize(binopNames));
|
|
String_format(str, " %s ", binopNames[code]);
|
|
codeOn(str, rhs, 0);
|
|
}
|
|
|
|
#define doUnyops(_) \
|
|
_(opNot, !) _(opCom, ~) _(opNeg, -) _(opQuasiquote, `) _(opUnquote, @)
|
|
|
|
#define defineUnyop(NAME, OP_) NAME,
|
|
|
|
enum unyop {
|
|
doUnyops(defineUnyop)
|
|
};
|
|
|
|
#undef defineUnyop
|
|
|
|
#define nameUnyop(NAME, OP) #OP,
|
|
|
|
char *unyopNames[] = {
|
|
doUnyops(nameUnyop)
|
|
};
|
|
|
|
#undef nameUnyop
|
|
|
|
oop newUnyop(int operation, oop value)
|
|
{
|
|
oop o = new(pUnyop);
|
|
Object_put(o, sym_operation, newInteger(operation));
|
|
Object_push(o, value);
|
|
return o;
|
|
}
|
|
|
|
oop quasiclone(oop exp, oop env)
|
|
{
|
|
if (is(Object, exp)) {
|
|
if (pUnyop == _getDelegate(exp)) {
|
|
oop op = Object_get(exp, sym_operation);
|
|
oop value = _get(exp, Object,indexed)[0];
|
|
enum unyop code = integerValue(op, "Unyop.operation");
|
|
if (code == opUnquote) return eval(value, env);
|
|
}
|
|
oop clone = new(_getDelegate(exp));
|
|
oop *indexed = _get(exp, Object,indexed);
|
|
int isize = _get(exp, Object,isize);
|
|
for (int i = 0; i < isize; ++i)
|
|
Object_push(clone, quasiclone(indexed[i], env));
|
|
struct property *kvs = _get(exp, Object,properties);
|
|
int psize = _get(exp, Object,psize);
|
|
for (int i = 0; i < psize; ++i)
|
|
if (kvs[i].key != prop_delegate)
|
|
Object_put(clone, kvs[i].key, quasiclone(kvs[i].val, env));
|
|
oop delegate = _getDelegate(exp);
|
|
if (nil != delegate) // always shallow copied
|
|
Object_put(clone, prop_delegate, delegate);
|
|
return clone;
|
|
}
|
|
return exp;
|
|
}
|
|
|
|
oop neg(oop n)
|
|
{
|
|
int tn = getType(n);
|
|
switch (tn) {
|
|
case Integer: return newInteger(-_integerValue(n));
|
|
case Float: return newFloat (-_floatValue (n));
|
|
default: break;
|
|
}
|
|
fatal("-: illegal operand type %s", getTypeName(n));
|
|
return 0;
|
|
}
|
|
|
|
oop com(oop n)
|
|
{
|
|
int tn = getType(n);
|
|
switch (tn) {
|
|
case Integer: return newInteger(~_integerValue(n));
|
|
default: break;
|
|
}
|
|
fatal("~: illegal operand type %s", getTypeName(n));
|
|
return 0;
|
|
}
|
|
|
|
oop Unyop_eval(oop exp, oop env)
|
|
{ assert(_get(exp, Object,isize) == 1);
|
|
oop op = Object_get(exp, sym_operation);
|
|
oop value = _get(exp, Object,indexed)[0];
|
|
enum unyop code = integerValue(op, "Unyop.operation");
|
|
if (code == opQuasiquote) return quasiclone(value, env);
|
|
if (code == opUnquote ) fatal("@ outside quasiquotation");
|
|
value = eval(value, env);
|
|
switch (code) {
|
|
case opNot: return newBoolean(value == nil);
|
|
case opNeg: return neg(value);
|
|
case opCom: return com(value);
|
|
default: break;
|
|
}
|
|
fatal("illegal unary operation %d", code);
|
|
return 0;
|
|
}
|
|
|
|
void Unyop_codeOn(oop exp, oop str, oop env)
|
|
{ assert(_get(exp, Object,isize) == 1);
|
|
oop op = Object_get(exp, sym_operation);
|
|
oop value = _get(exp, Object,indexed)[0];
|
|
enum unyop code = integerValue(op, "Unyop.operation");
|
|
assert(0 <= (int)code && (int)code <= indexableSize(unyopNames));
|
|
String_appendAll(str, unyopNames[code]);
|
|
codeOn(str, value, 0);
|
|
}
|
|
|
|
oop newLet(void)
|
|
{
|
|
oop o = new(pLet);
|
|
Object_put(o, sym_keyvals, new(pObject));
|
|
return o;
|
|
}
|
|
|
|
oop Let_append(oop let, oop key, oop value)
|
|
{
|
|
oop keyvals = Object_getLocal(let, sym_keyvals);
|
|
Object_push(keyvals, key);
|
|
Object_push(keyvals, value);
|
|
return let;
|
|
}
|
|
|
|
oop Let_eval(oop exp, oop env)
|
|
{
|
|
oop keyvals = Object_getLocal(exp, sym_keyvals);
|
|
oop *indexed = get(keyvals, Object,indexed);
|
|
int isize = _get(keyvals, Object,isize);
|
|
oop result = nil;
|
|
for (int i = 0; i < isize - 1; i += 2)
|
|
Object_put(env, indexed[i], (result = eval(indexed[i+1], env)));
|
|
return result;
|
|
}
|
|
|
|
void Let_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
oop keyvals = Object_getLocal(exp, sym_keyvals);
|
|
oop *indexed = get(keyvals, Object,indexed);
|
|
int isize = _get(keyvals, Object,isize);
|
|
String_appendAll(str, "let ");
|
|
for (int i = 0; i < isize - 1; i += 2) {
|
|
if (i) String_appendAll(str, ", ");
|
|
codeOn(str, indexed[i], 0);
|
|
String_appendAll(str, " = ");
|
|
codeOn(str, indexed[i+1], 0);
|
|
}
|
|
}
|
|
|
|
oop newIf(oop condition, oop consequent, oop alternate)
|
|
{
|
|
oop o = new(pIf);
|
|
Object_put(o, sym_condition, condition );
|
|
Object_put(o, sym_consequent, consequent);
|
|
Object_put(o, sym_alternate, alternate );
|
|
return o;
|
|
}
|
|
|
|
oop If_eval(oop exp, oop env)
|
|
{
|
|
oop condition = eval(Object_get(exp, sym_condition ), env);
|
|
oop consequent = Object_get(exp, sym_consequent) ;
|
|
oop alternate = Object_get(exp, sym_alternate ) ;
|
|
return eval(nil != condition ? consequent : alternate, env);
|
|
}
|
|
|
|
void If_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
oop condition = Object_get(exp, sym_condition );
|
|
oop consequent = Object_get(exp, sym_consequent);
|
|
oop alternate = Object_get(exp, sym_alternate );
|
|
String_appendAll(str, "if (");
|
|
codeOn(str, condition, 0);
|
|
String_appendAll(str, ") ");
|
|
codeOn(str, consequent, 0);
|
|
if (nil != alternate) {
|
|
String_appendAll(str, " else ");
|
|
codeOn(str, alternate, 0);
|
|
}
|
|
}
|
|
|
|
oop newWhile(oop condition, oop body)
|
|
{
|
|
oop o = new(pWhile);
|
|
Object_put(o, sym_condition, condition );
|
|
Object_put(o, sym_body, body );
|
|
return o;
|
|
}
|
|
|
|
oop While_eval(oop exp, oop env)
|
|
{
|
|
oop condition = Object_get(exp, sym_condition);
|
|
oop body = Object_get(exp, sym_body );
|
|
oop result = nil;
|
|
while (nil != eval(condition, env)) result = eval(body, env);
|
|
return result;
|
|
}
|
|
|
|
void While_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
oop condition = Object_get(exp, sym_condition);
|
|
oop body = Object_get(exp, sym_body );
|
|
String_appendAll(str, "while (");
|
|
codeOn(str, condition, 0);
|
|
String_appendAll(str, ") ");
|
|
codeOn(str, body, 0);
|
|
if (pBlock != _getDelegate(body)) String_appendAll(str, ";");
|
|
}
|
|
|
|
oop newBlock(oop body)
|
|
{
|
|
oop o = new(pBlock);
|
|
Object_put(o, sym_body, body);
|
|
return o;
|
|
}
|
|
|
|
oop Block_eval(oop exp, oop env)
|
|
{
|
|
oop body = Object_get(exp, sym_body);
|
|
oop *indexed = _get(body, Object,indexed);
|
|
int size = _get(body, Object,isize);
|
|
oop result = nil;
|
|
oop env2 = new(pObject);
|
|
_setDelegate(env2, env);
|
|
for (int i = 0; i < size; ++i) result = eval(indexed[i], env2);
|
|
return result;
|
|
}
|
|
|
|
void Block_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeBlockOn(str, Object_get(exp, sym_body));
|
|
}
|
|
|
|
oop newFor(oop initialise, oop condition, oop update, oop body)
|
|
{
|
|
oop o = new(pFor);
|
|
Object_put(o, sym_initialise, initialise);
|
|
Object_put(o, sym_condition, condition);
|
|
Object_put(o, sym_update, update);
|
|
Object_put(o, sym_body, body);
|
|
return o;
|
|
}
|
|
|
|
oop For_eval(oop exp, oop env)
|
|
{
|
|
oop initialise = Object_get(exp, sym_initialise);
|
|
oop condition = Object_get(exp, sym_condition);
|
|
oop update = Object_get(exp, sym_update);
|
|
oop body = Object_get(exp, sym_body);
|
|
oop env2 = new(pObject);
|
|
_setDelegate(env2, env);
|
|
oop result = eval(initialise, env2);
|
|
while (nil != eval(condition, env2)) {
|
|
result = eval(body, env2);
|
|
eval(update, env2);
|
|
}
|
|
return result;
|
|
}
|
|
|
|
void For_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
oop initialise = Object_get(exp, sym_initialise);
|
|
oop condition = Object_get(exp, sym_condition);
|
|
oop update = Object_get(exp, sym_update);
|
|
oop body = Object_get(exp, sym_body);
|
|
String_appendAll(str, "for (");
|
|
codeOn(str, initialise, 0);
|
|
String_appendAll(str, "; ");
|
|
codeOn(str, condition, 0);
|
|
String_appendAll(str, "; ");
|
|
codeOn(str, update, 0);
|
|
String_appendAll(str, ") ");
|
|
codeOn(str, body, 0);
|
|
}
|
|
|
|
oop newForIn(oop identifier, oop expression, oop body)
|
|
{
|
|
oop o = new(pForIn);
|
|
Object_put(o, sym_identifier, identifier);
|
|
Object_put(o, sym_expression, expression);
|
|
Object_put(o, sym_body, body);
|
|
return o;
|
|
}
|
|
|
|
oop ForIn_eval(oop exp, oop env)
|
|
{
|
|
oop identifier = Object_get(exp, sym_identifier);
|
|
oop expression = Object_get(exp, sym_expression);
|
|
oop body = Object_get(exp, sym_body);
|
|
oop result = nil;
|
|
oop vals = eval(expression, env);
|
|
oop env2 = new(pObject);
|
|
_setDelegate(env2, env);
|
|
if (isInteger(vals)) {
|
|
long limit = _integerValue(vals);
|
|
for (long i = 0; i < limit; ++i) {
|
|
Object_put(env2, identifier, newInteger(i));
|
|
result = eval(body, env2);
|
|
}
|
|
return result;
|
|
}
|
|
if (is(String, vals)) {
|
|
int len = _get(vals, String,length);
|
|
char *val = _get(vals, String,value);
|
|
for (int i = 0; i < len; ++i) {
|
|
Object_put(env2, identifier, newInteger(val[i]));
|
|
result = eval(body, env2);
|
|
}
|
|
return result;
|
|
}
|
|
if (!is(Object, vals)) fatal("for: non-object sequence %s", storeString(vals, 0));
|
|
oop *indexed = _get(vals, Object,indexed);
|
|
int size = _get(vals, Object,isize);
|
|
for (int i = 0; i < size; ++i) {
|
|
Object_put(env2, identifier, indexed[i]);
|
|
result = eval(body, env2);
|
|
}
|
|
return result;
|
|
}
|
|
|
|
void ForIn_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
oop identifier = Object_get(exp, sym_identifier);
|
|
oop expression = Object_get(exp, sym_expression);
|
|
oop body = Object_get(exp, sym_body);
|
|
String_appendAll(str, "for (");
|
|
printOn(str, identifier, 0);
|
|
String_appendAll(str, " in ");
|
|
codeOn(str, expression, 0);
|
|
String_appendAll(str, ") ");
|
|
codeOn(str, body, 0);
|
|
}
|
|
|
|
oop newForFromTo(oop identifier, oop first, oop last, oop body)
|
|
{
|
|
oop o = new(pForFromTo);
|
|
Object_put(o, sym_identifier, identifier);
|
|
Object_put(o, sym_first, first);
|
|
Object_put(o, sym_last, last);
|
|
Object_put(o, sym_body, body);
|
|
return o;
|
|
}
|
|
|
|
oop ForFromTo_eval(oop exp, oop env)
|
|
{
|
|
oop identifier = Object_get(exp, sym_identifier);
|
|
oop first = Object_get(exp, sym_first);
|
|
oop last = Object_get(exp, sym_last);
|
|
oop body = Object_get(exp, sym_body);
|
|
oop env2 = new(pObject);
|
|
_setDelegate(env2, env);
|
|
long start = integerValue(first, "for");
|
|
long stop = integerValue(last, "for");
|
|
long step = start < stop ? 1 : -1;
|
|
oop result = nil;
|
|
for (;;) {
|
|
Object_put(env2, identifier, newInteger(start));
|
|
result = eval(body, env2);
|
|
if (start == stop) break;
|
|
start += step;
|
|
}
|
|
return result;
|
|
}
|
|
|
|
void ForFromTo_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
oop identifier = Object_get(exp, sym_identifier);
|
|
oop first = Object_get(exp, sym_first);
|
|
oop last = Object_get(exp, sym_last);
|
|
oop body = Object_get(exp, sym_body);
|
|
String_appendAll(str, "for (");
|
|
printOn(str, identifier, 0);
|
|
String_appendAll(str, " from ");
|
|
codeOn(str, first, 0);
|
|
String_appendAll(str, " to ");
|
|
codeOn(str, last, 0);
|
|
String_appendAll(str, ") ");
|
|
codeOn(str, body, 0);
|
|
}
|
|
|
|
oop newLiteral(oop object)
|
|
{
|
|
oop o = new(pLiteral);
|
|
Object_put(o, sym_object, object);
|
|
return o;
|
|
}
|
|
|
|
#if DELOPT
|
|
|
|
oop Literal_eval(oop exp, oop env)
|
|
{
|
|
oop object = Object_get(exp, sym_object);
|
|
oop clone = new(pObject);
|
|
oop *indexed = _get(object, Object,indexed);
|
|
int isize = _get(object, Object,isize);
|
|
for (int i = 0; i < isize; ++i)
|
|
Object_push(clone, eval(indexed[i], env));
|
|
struct property *kvs = _get(object, Object,properties);
|
|
int psize = _get(object, Object,psize);
|
|
for (int i = 0; i < psize; ++i)
|
|
Object_put(clone, kvs[i].key, eval(kvs[i].val, env));
|
|
oop delegate = _getDelegate(object);
|
|
if (nil != delegate)
|
|
Object_put(clone, prop_delegate, eval(delegate, env));
|
|
return clone;
|
|
}
|
|
|
|
#else // !DELOPT
|
|
|
|
oop Literal_eval(oop exp, oop env)
|
|
{
|
|
oop object = Object_get(exp, sym_object);
|
|
oop clone = new(pObject);
|
|
oop *indexed = _get(object, Object,indexed);
|
|
int isize = _get(object, Object,isize);
|
|
for (int i = 0; i < isize; ++i)
|
|
Object_push(clone, eval(indexed[i], env));
|
|
struct property *kvs = _get(object, Object,properties);
|
|
int psize = _get(object, Object,psize);
|
|
for (int i = 0; i < psize; ++i)
|
|
Object_put(clone, kvs[i].key, eval(kvs[i].val, env));
|
|
return clone;
|
|
}
|
|
|
|
#endif // !DELOPT
|
|
|
|
void Literal_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
oop object = Object_get(exp, sym_object);
|
|
oop *indexed = _get(object, Object,indexed);
|
|
int isize = _get(object, Object,isize);
|
|
String_appendAll(str, "[");
|
|
int i;
|
|
for (i = 0; i < isize; ++i) {
|
|
if (i) String_appendAll(str, ", ");
|
|
codeOn(str, indexed[i], 0);
|
|
}
|
|
struct property *kvs = _get(object, Object,properties);
|
|
int psize = _get(object, Object,psize);
|
|
for (int j = 0; j < psize; ++j) {
|
|
if (i++) String_appendAll(str, ", ");
|
|
codeOn(str, kvs[j].key, 0);
|
|
String_appendAll(str, ": ");
|
|
codeOn(str, kvs[j].val, 0);
|
|
}
|
|
String_appendAll(str, "]");
|
|
}
|
|
|
|
%}
|
|
|
|
|
|
start = - ( s:stmt { yysval = s }
|
|
| !. { yysval = 0 }
|
|
| < (!EOL .)* > { fatal("syntax error near: %s", yytext) }
|
|
)
|
|
|
|
stmt = LET l:mklet k:id ASSIGN v:expr { Let_append(l, k, v) }
|
|
( COMMA k:id ASSIGN v:expr { Let_append(l, k, v) }
|
|
)* SEMI { $$ = l }
|
|
| WHILE LPAREN c:expr RPAREN s:stmt { $$ = newWhile(c, s) }
|
|
| IF LPAREN c:expr RPAREN s:stmt
|
|
( ELSE t:stmt { $$ = newIf(c, s, t ) }
|
|
| { $$ = newIf(c, s, nil) }
|
|
)
|
|
| FOR LPAREN i:id IN e:expr RPAREN
|
|
s:stmt { $$ = newForIn(i, e, s) }
|
|
| FOR LPAREN i:id FROM a:expr
|
|
TO b:expr RPAREN s:stmt { $$ = newForFromTo(i, a, b, s) }
|
|
| FOR LPAREN i:expr SEMI c:expr SEMI
|
|
u:expr RPAREN s:stmt { $$ = newFor(i, c, u, s) }
|
|
| 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)) }
|
|
| b:block { $$ = newBlock(b) }
|
|
| e:expr EOS { $$ = e }
|
|
|
|
mklet = { $$ = newLet() }
|
|
|
|
proto = v:var ( DOT j:id !LPAREN { v = newGetProp(v, j) }
|
|
)* { $$ = v }
|
|
|
|
EOS = SEMI+ | &RBRACE | &ELSE
|
|
|
|
expr = p:postfix
|
|
( DOT i:id ASSIGN e:expr { $$ = newSetProp(p, i, e) }
|
|
| LBRAK i:expr RBRAK ASSIGN e:expr { $$ = newSetArray(p, i, e) }
|
|
)
|
|
| i:id ASSIGN e:expr { $$ = newSetVar(i, e) }
|
|
| logor
|
|
|
|
logor = l:logand ( BARBAR r:logand { l = newBinop(opLogOr, l, r) }
|
|
)* { $$ = l }
|
|
|
|
logand = l:bitor ( ANDAND r:bitor { l = newBinop(opLogAnd, l, r) }
|
|
)* { $$ = l }
|
|
|
|
bitor = l:bitxor ( OR r:bitxor { l = newBinop(opBitOr, l, r) }
|
|
)* { $$ = l }
|
|
|
|
bitxor = l:bitand ( XOR r:bitand { l = newBinop(opBitXor, l, r) }
|
|
)* { $$ = l }
|
|
|
|
bitand = l:eq ( AND r:eq { l = newBinop(opBitAnd, l, r) }
|
|
)* { $$ = l }
|
|
|
|
eq = l:ineq ( EQ r:ineq { l = newBinop(opEq, l, r) }
|
|
| NOTEQ r:ineq { l = newBinop(opNotEq, l, r) }
|
|
)* { $$ = l }
|
|
|
|
ineq = l:shift ( LESS r:shift { l = newBinop(opLess, l, r) }
|
|
| LESSEQ r:shift { l = newBinop(opLessEq, l, r) }
|
|
| GRTREQ r:shift { l = newBinop(opGrtrEq, l, r) }
|
|
| GRTR r:shift { l = newBinop(opGrtr, l, r) }
|
|
)* { $$ = l }
|
|
|
|
shift = l:sum ( SHL r:sum { l = newBinop(opShl, l, r) }
|
|
| SHR r:sum { l = newBinop(opShr, l, r) }
|
|
)* { $$ = l }
|
|
|
|
sum = l:prod ( PLUS r:prod { l = newBinop(opAdd, l, r) }
|
|
| MINUS r:prod { l = newBinop(opSub, l, r) }
|
|
)* { $$ = l }
|
|
|
|
prod = l:prefix ( STAR r:prefix { l = newBinop(opMul, l, r) }
|
|
| SLASH r:prefix { l = newBinop(opDiv, l, r) }
|
|
| PCENT r:prefix { l = newBinop(opMod, l, r) }
|
|
)* { $$ = l }
|
|
|
|
prefix = PLING p:prefix { $$ = newUnyop(opNot, p) }
|
|
| MINUS p:prefix { $$ = newUnyop(opNeg, p) }
|
|
| TILDE p:prefix { $$ = newUnyop(opCom, p) }
|
|
| BQUOTE s:stmt { $$ = newUnyop(opQuasiquote, s) }
|
|
| COMMAT e:expr { $$ = newUnyop(opUnquote, e) }
|
|
| postfix
|
|
|
|
postfix = p:primary
|
|
( LBRAK e:expr RBRAK !ASSIGN { p = newGetArray(p, e) }
|
|
| DOT i:id a:args !ASSIGN !LBRACE { p = newInvoke(p, i, a) }
|
|
| DOT i:id !ASSIGN { p = newGetProp(p, i) }
|
|
| a:args !ASSIGN !LBRACE { p = newApply(p, a) }
|
|
)* { $$ = p }
|
|
|
|
args = LPAREN a:mkobj
|
|
( ( k:id COLON e:expr { Object_put(a, k, e) }
|
|
| e:expr { Object_push(a, e) }
|
|
)
|
|
( COMMA ( k:id COLON e:expr { Object_put(a, k, e) }
|
|
| e:expr { Object_push(a, e) }
|
|
) )* )? RPAREN { $$ = a }
|
|
|
|
params = LPAREN p:mkobj
|
|
( i:id { Object_push(p, i) }
|
|
( COMMA i:id { Object_push(p, i) }
|
|
)* )? RPAREN { $$ = p }
|
|
|
|
mkobj = { $$ = new(pObject) }
|
|
|
|
primary = nil | number | string | symbol | var | lambda | subexpr | literal
|
|
|
|
lambda = p:params b:block { $$ = newLambda(p, b) }
|
|
|
|
subexpr = LPAREN e:expr RPAREN { $$ = e }
|
|
| b:block { $$ = newBlock(b) }
|
|
|
|
literal = LBRAK o:mkobj
|
|
( ( i:id COLON e:expr { Object_put(o, i, e) }
|
|
| e:expr { Object_push(o, e) }
|
|
) ( COMMA ( i:id COLON e:expr { Object_put(o, i, e) }
|
|
| e:expr { Object_push(o, e) }
|
|
) )* )? RBRAK { $$ = newLiteral(o) }
|
|
|
|
block = LBRACE b:mkobj
|
|
( e:stmt { Object_push(b, e) }
|
|
)* RBRACE { $$ = b }
|
|
|
|
nil = NIL { $$ = nil }
|
|
|
|
number = "-" u:unsign { $$ = neg(u) }
|
|
| "+" n:number { $$ = u }
|
|
| u:unsign { $$ = u }
|
|
|
|
unsign = < DIGIT+ '.' DIGIT* EXP? > - { $$ = newFloat(strtod(yytext, 0)) }
|
|
| < DIGIT* '.' DIGIT+ EXP? > - { $$ = newFloat(strtod(yytext, 0)) }
|
|
| "0" [bB] < BIGIT+ > - { $$ = newInteger(strtol(yytext, 0, 2)) }
|
|
| "0" [xX] < HIGIT+ > - { $$ = newInteger(strtol(yytext, 0, 16)) }
|
|
| "0" < OIGIT* > - { $$ = newInteger(strtol(yytext, 0, 8)) }
|
|
| < DIGIT+ > - { $$ = newInteger(strtol(yytext, 0, 10)) }
|
|
|
|
string = '"' < ( !'"' . )* > '"' - { $$ = newStringEscaped(yytext) }
|
|
| "'" < ( !"'" . )* > "'" - { $$ = newStringEscaped(yytext) }
|
|
|
|
symbol = HASH i:id { $$ = i }
|
|
|
|
var = i:id { $$ = newGetVar(i) }
|
|
|
|
id = < LETTER ALNUM* > - { $$ = intern(yytext) }
|
|
|
|
BIGIT = [0-1]
|
|
OIGIT = [0-7]
|
|
DIGIT = [0-9]
|
|
HIGIT = [0-9A-Fa-f]
|
|
LETTER = [A-Za-z_]
|
|
ALNUM = LETTER | DIGIT
|
|
SIGN = [-+]
|
|
EXP = [eE] SIGN DIGIT+
|
|
|
|
- = SPACE*
|
|
|
|
SPACE = [ \t] | EOL | '//' (!EOL .)*
|
|
EOL = [\n\r] { ++lineno }
|
|
|
|
NIL = "nil" !ALNUM -
|
|
WHILE = "while" !ALNUM -
|
|
IF = "if" !ALNUM -
|
|
ELSE = "else" !ALNUM -
|
|
FOR = "for" !ALNUM -
|
|
IN = "in" !ALNUM -
|
|
FROM = "from" !ALNUM -
|
|
TO = "to" !ALNUM -
|
|
LET = "let" !ALNUM -
|
|
|
|
BQUOTE = "`" -
|
|
COMMAT = "@" -
|
|
HASH = "#" -
|
|
SEMI = ";" -
|
|
ASSIGN = "=" ![=] -
|
|
COMMA = "," -
|
|
COLON = ":" -
|
|
LPAREN = "(" -
|
|
RPAREN = ")" -
|
|
LBRAK = "[" -
|
|
RBRAK = "]" -
|
|
LBRACE = "{" -
|
|
RBRACE = "}" -
|
|
BARBAR = "||" ![=] -
|
|
ANDAND = "&&" ![=] -
|
|
OR = "|" ![|=] -
|
|
XOR = "^" ![=] -
|
|
AND = "&" ![&=] -
|
|
EQ = "==" -
|
|
NOTEQ = "!=" -
|
|
LESS = "<" ![<=] -
|
|
LESSEQ = "<=" -
|
|
GRTREQ = ">=" -
|
|
GRTR = ">" ![=] -
|
|
SHL = "<<" ![=] -
|
|
SHR = ">>" ![=] -
|
|
PLUS = "+" ![+=] -
|
|
MINUS = "-" ![-=] -
|
|
STAR = "*" ![=] -
|
|
SLASH = "/" ![/=] -
|
|
PCENT = "%" ![*=] -
|
|
DOT = "." -
|
|
PLING = "!" ![=] -
|
|
TILDE = "~" -
|
|
|
|
%%;
|
|
|
|
#define SEND(RCV, MSG) ({ \
|
|
oop _rcv = RCV; \
|
|
oop _fun = Object_get(_rcv, sym_##MSG); \
|
|
get(_fun, Primitive,function)(_fun, _rcv, nil, nil); \
|
|
})
|
|
|
|
oop sym_x = 0;
|
|
oop sym_y = 0;
|
|
|
|
oop Point_magnitude(oop func, oop self, oop args, oop env)
|
|
{
|
|
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));
|
|
}
|
|
|
|
oop apply(oop func, oop self, oop args, oop env)
|
|
{
|
|
int functype = getType(func);
|
|
if (Primitive == functype)
|
|
return _get(func, Primitive,function)(func, self, args, env);
|
|
#if PRIMCLOSURE
|
|
if (Closure != functype)
|
|
fatal("cannot %s %s", (nil == self ? "call" : "invoke"), storeString(func, 0));
|
|
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_function);
|
|
oop environment = Object_get(func, sym_environment);
|
|
oop parameters = Object_get(lambda, sym_parameters);
|
|
oop body = Object_get(lambda, sym_body);
|
|
#endif
|
|
oop *exprs = get(body, Object,indexed);
|
|
int size = _get(body, Object,isize);
|
|
oop result = nil;
|
|
assert(is(Object, args));
|
|
// inherit from closure's captured environment
|
|
_setDelegate(args, environment);
|
|
Object_put(args, sym_self, self);
|
|
int nparam = _get(parameters, Object,isize);
|
|
oop *pparam = _get(parameters, Object,indexed);
|
|
int nargs = _get(args, Object,isize);
|
|
oop *pargs = _get(args, Object,indexed);
|
|
for (int i = 0; i < nparam; ++i)
|
|
Object_put(args, pparam[i], i < nargs ? pargs[i] : nil);
|
|
for (int i = 0; i < size; ++i)
|
|
result = eval(exprs[i], args);
|
|
return result;
|
|
}
|
|
|
|
oop getArg(oop args, int index, char *who)
|
|
{ assert(is(Object, args));
|
|
if (index >= _get(args, Object,isize)) fatal("%s: too few arguments", who);
|
|
return _get(args, Object,indexed)[index];
|
|
}
|
|
|
|
oop getArgType(oop args, int index, int type, char *who)
|
|
{ assert(is(Object, args));
|
|
oop arg = getArg(args, index, who);
|
|
if (type != getType(arg)) fatal("%s: non-%s arg: ", who, typeNames[type], storeString(arg, 0));
|
|
return arg;
|
|
}
|
|
|
|
#if TYPECODES
|
|
|
|
enum typecode getTypecode(oop exp)
|
|
{
|
|
oop delegate = _getDelegate(exp);
|
|
oop name = Object_get(delegate, prop_name);
|
|
enum typecode type = _get(name, Symbol,typecode);
|
|
return type;
|
|
}
|
|
|
|
#else // !TYPECODES
|
|
|
|
#define defineEval(NAME) \
|
|
static inline oop prim_##NAME##_eval(oop func, oop exp, oop args, oop env) { \
|
|
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(defineCodeOn)
|
|
|
|
#undef defineCodeOn
|
|
|
|
static inline oop evalobj(oop exp, oop env)
|
|
{
|
|
# if !TYPECODES
|
|
|
|
oop delegate = _getDelegate(exp);
|
|
oop evaluator = Object_get(delegate, prop_eval);
|
|
return apply(evaluator, exp, new(pObject), env);
|
|
|
|
# else // TYPECODES
|
|
|
|
enum typecode type = getTypecode(exp);
|
|
|
|
# define defineEval(NAME) case t##NAME: return NAME##_eval(exp, env);
|
|
switch (type) {
|
|
doProtos(defineEval);
|
|
}
|
|
# undef defineEval
|
|
|
|
return exp;
|
|
|
|
# endif // TYPECODES
|
|
}
|
|
|
|
long evaluations = 0;
|
|
|
|
oop eval(oop exp, oop env)
|
|
{
|
|
++evaluations;
|
|
enum type type = getType(exp);
|
|
# if PRIMCLOSURE
|
|
if (Lambda == type) return newClosure(exp, env);
|
|
# endif
|
|
if (Object != getType(exp)) return exp;
|
|
if (!opt_O) Object_push(trace, exp);
|
|
oop result = evalobj(exp, env);
|
|
if (!opt_O) Object_pop(trace);
|
|
return result;
|
|
}
|
|
|
|
oop evargs(oop list, oop env)
|
|
{
|
|
if (!is(Object, list)) return list;
|
|
int isize = _get(list, Object,isize);
|
|
int psize = _get(list, Object,psize);
|
|
oop *indexed = _get(list, Object,indexed);
|
|
struct property *props = _get(list, Object,properties);
|
|
oop *indexed2 = isize ? xmalloc(sizeof(*indexed2) * isize) : 0;
|
|
struct property *props2 = psize ? xmalloc(sizeof(*props2 ) * psize) : 0;
|
|
for (int i = 0; i < isize; ++i)
|
|
indexed2[i] = eval(indexed[i], env);
|
|
for (int i = 0; i < psize; ++i) {
|
|
props2[i].key = props[i].key ;
|
|
props2[i].val = eval(props[i].val, env);
|
|
}
|
|
return newObjectWith(isize, indexed2, psize, props2);
|
|
}
|
|
|
|
oop prim_new(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
_setDelegate(args, self);
|
|
return args;
|
|
}
|
|
|
|
oop prim_push(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (!is(Object, self)) fatal("push: not an object");
|
|
int argc = _get(args, Object,isize);
|
|
oop *indexed = _get(args, Object,indexed);
|
|
for (int i = 0; i < argc; ++i) Object_push(self, indexed[i]);
|
|
return self;
|
|
}
|
|
|
|
oop prim_pop(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (!is(Object, self)) fatal("pop: not an object");
|
|
int size = _get(self, Object,isize);
|
|
if (size < 1) fatal("pop: object is empty\n");
|
|
--size;
|
|
_set(self, Object,isize, size);
|
|
return _get(self, Object,indexed)[size];
|
|
}
|
|
|
|
oop prim_length(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (!is(Object, self)) fatal("length: not an object");
|
|
return newInteger(_get(self, Object,isize));
|
|
}
|
|
|
|
oop prim_keys(oop func, oop self, oop args, oop env)
|
|
{
|
|
oop keys = new(pObject);
|
|
# 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
|
|
}
|
|
return keys;
|
|
}
|
|
|
|
oop prim_env(oop func, oop self, oop args, oop env)
|
|
{
|
|
return env;
|
|
}
|
|
|
|
oop prim_eval(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 = eval(indexed[i], env);
|
|
return result;
|
|
}
|
|
|
|
oop prim_print(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
oop *indexed = _get(args, Object,indexed);
|
|
oop result = nil;
|
|
int indent = 0;
|
|
if (nil != Object_getLocal(args, sym_full)) indent = 1;
|
|
for (int i = 0; i < argc; ++i) print(result = indexed[i], indent);
|
|
fflush(stdout);
|
|
return nil;
|
|
}
|
|
|
|
oop prim_codeString(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
oop *indexed = _get(args, Object,indexed);
|
|
oop result = newStringLen(0, 0);
|
|
int indent = 0;
|
|
if (nil != Object_getLocal(args, sym_full)) indent = 1;
|
|
for (int i = 0; i < argc; ++i) codeOn(result, indexed[i], 0);
|
|
return result;
|
|
}
|
|
|
|
oop prim_sqrt(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
if (1 != argc) fatal("sqrt: 1 argument expected");
|
|
return newFloat(sqrt(floatValue(_get(args, Object,indexed)[0], "sqrt")));
|
|
}
|
|
|
|
oop prim_round(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
if (1 != argc) fatal("round: 1 argument expected");
|
|
return newInteger(round(floatValue(_get(args, Object,indexed)[0], "round")));
|
|
}
|
|
|
|
oop prim_truncate(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
if (1 != argc) fatal("truncate: 1 argument expected");
|
|
return newInteger(floatValue(_get(args, Object,indexed)[0], "truncate"));
|
|
}
|
|
|
|
oop prim_cputime(oop func, oop self, oop args, oop env)
|
|
{
|
|
struct rusage ru;
|
|
getrusage(RUSAGE_SELF, &ru);
|
|
return newFloat(ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1000000.0);
|
|
}
|
|
|
|
oop prim_evaluations(oop func, oop self, oop args, oop env)
|
|
{
|
|
return newInteger(evaluations);
|
|
}
|
|
|
|
oop prim_len(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
if (1 != argc) fatal("len: 1 argument expected");
|
|
oop arg = _get(args, Object,indexed)[0];
|
|
switch (getType(arg)) {
|
|
case String: return newInteger(_get(arg, String,length));
|
|
case Symbol: return newInteger(strlen(_get(arg, Symbol,name)));
|
|
case Object: return newInteger(_get(arg, Object,isize));
|
|
default: break;
|
|
}
|
|
return newInteger(0);
|
|
}
|
|
|
|
oop prim_ord(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
if (1 != argc) fatal("ord: 1 argument expected");
|
|
oop arg = _get(args, Object,indexed)[0];
|
|
if (!is(String, arg)) fatal("ord: string argument expected");
|
|
if (1 != _get(arg, String,length)) fatal("ord: string of length 1 expected");
|
|
return newInteger(_get(arg, String,value)[0]);
|
|
}
|
|
|
|
oop prim_chr(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
oop str = newStringLen(0, 0);
|
|
for (int i = 0; i < argc; ++i)
|
|
String_append(str, integerValue(_get(args, Object,indexed)[i], "chr"));
|
|
return str;
|
|
}
|
|
|
|
void readFile(FILE *file, char **textp, int *sizep)
|
|
{
|
|
size_t size = 0;
|
|
char *text = xmallocAtomic(4096);
|
|
for (;;) {
|
|
ssize_t n = fread(text+size, 1, 4096, file);
|
|
if (n < 1) break;
|
|
size += n;
|
|
if (n < 4096) break;
|
|
text = xrealloc(text, size + 4096);
|
|
}
|
|
*textp = text;
|
|
*sizep = size;
|
|
}
|
|
|
|
oop prim_readfile(oop func, oop self, oop args, oop env)
|
|
{
|
|
oop str = newStringLen(0, 0);
|
|
int argc = _get(args, Object,isize);
|
|
for (int i = 0; i < argc; ++i) {
|
|
oop name = _get(args, Object,indexed)[i];
|
|
if (!is(String, name)) fatal("readfile: non-string argument: %s", storeString(name, 0));
|
|
FILE *file = fopen(_get(name, String,value), "r");
|
|
if (!file) fatal("%s: %s", _get(name, String,value), strerror(errno));
|
|
char *text = 0;
|
|
int tlen = 0;
|
|
readFile(file, &text, &tlen);
|
|
fclose(file);
|
|
String_appendAllLen(str, text, tlen);
|
|
}
|
|
return str;
|
|
}
|
|
|
|
oop prim_exit(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
int status = 0;
|
|
if (argc > 1) fatal("exit: too many arguments");
|
|
if (argc == 1) status = integerValue(_get(args, Object,indexed)[0], "exit");
|
|
exit(status);
|
|
return nil;
|
|
}
|
|
|
|
oop replFile(FILE *in)
|
|
{
|
|
int oldline = lineno;
|
|
lineno = 0;
|
|
input = newInput();
|
|
readFile(in, &input->text, &input->size);
|
|
oop result = nil;
|
|
while (yyparse() && yysval) {
|
|
if (opt_v) {
|
|
printf(">>> ");
|
|
(opt_d ? println : codeln)(yysval, opt_v >2);
|
|
}
|
|
result = eval(yysval, nil);
|
|
if (opt_v) {
|
|
printf("==> ");
|
|
if (opt_v >= 3) storeln(result, 1);
|
|
else if (opt_v >= 1) storeln(result, 0);
|
|
}
|
|
}
|
|
lineno = oldline;
|
|
return result;
|
|
}
|
|
|
|
oop replPath(char *path)
|
|
{
|
|
FILE *in = fopen(path, "r");
|
|
if (!in) fatal("%s: %s", path, strerror(errno));
|
|
char *oldname = filename;
|
|
filename = path;
|
|
oop result = replFile(in);
|
|
filename = oldname;
|
|
fclose(in);
|
|
return result;
|
|
}
|
|
|
|
int main(int argc, char **argv)
|
|
{
|
|
GC_INIT();
|
|
|
|
# define defineProp(NAME) prop_##NAME = intern("__"#NAME"__");
|
|
doProperties(defineProp);
|
|
# undef defineProp
|
|
|
|
# define defineSym(NAME) sym_##NAME = intern(#NAME);
|
|
doSymbols(defineSym);
|
|
# undef defineSym
|
|
|
|
pObject = nil;
|
|
|
|
# define defineProto(NAME) \
|
|
p##NAME = new(pObject); \
|
|
Object_put(p##NAME, prop_name, intern(#NAME)); \
|
|
_set(intern(#NAME), Symbol,value, p##NAME); \
|
|
|
|
doProtos(defineProto);
|
|
doTypes(defineProto);
|
|
|
|
# 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);
|
|
|
|
# undef defineEvaluator
|
|
|
|
# define defineCodeOn(NAME) \
|
|
Object_put(p##NAME, prop_codeon, newPrimitive(prim_##NAME##_codeOn));
|
|
|
|
doProtos(defineCodeOn);
|
|
|
|
# undef defineCodeOn
|
|
|
|
macros = Object_put(pSymbol, intern("macros"), new(pObject));
|
|
|
|
_set(intern("__env__" ), Symbol,value, newPrimitive(prim_env));
|
|
_set(intern("eval" ), Symbol,value, newPrimitive(prim_eval));
|
|
_set(intern("print" ), Symbol,value, newPrimitive(prim_print));
|
|
_set(intern("codeString" ), Symbol,value, newPrimitive(prim_codeString));
|
|
_set(intern("sqrt" ), Symbol,value, newPrimitive(prim_sqrt));
|
|
_set(intern("round" ), Symbol,value, newPrimitive(prim_round));
|
|
_set(intern("truncate" ), Symbol,value, newPrimitive(prim_truncate));
|
|
_set(intern("cputime" ), Symbol,value, newPrimitive(prim_cputime));
|
|
_set(intern("evaluations"), Symbol,value, newPrimitive(prim_evaluations));
|
|
_set(intern("len" ), Symbol,value, newPrimitive(prim_len));
|
|
_set(intern("ord" ), Symbol,value, newPrimitive(prim_ord));
|
|
_set(intern("chr" ), Symbol,value, newPrimitive(prim_chr));
|
|
_set(intern("readfile" ), Symbol,value, newPrimitive(prim_readfile));
|
|
_set(intern("exit" ), Symbol,value, newPrimitive(prim_exit));
|
|
|
|
Object_put(pObject, intern("new"), newPrimitive(prim_new ));
|
|
Object_put(pObject, intern("push"), newPrimitive(prim_push ));
|
|
Object_put(pObject, intern("pop"), newPrimitive(prim_pop ));
|
|
Object_put(pObject, intern("length"), newPrimitive(prim_length));
|
|
Object_put(pObject, intern("keys"), newPrimitive(prim_keys ));
|
|
|
|
trace = new(pObject);
|
|
|
|
signal(SIGINT, sigint);
|
|
|
|
int repled = 0;
|
|
|
|
for (int argn = 1; argn < argc; ++argn) {
|
|
char *arg = argv[argn];
|
|
if ('-' == *arg) {
|
|
while (*++arg) {
|
|
switch (*arg) {
|
|
case 'O': ++opt_O; break;
|
|
case 'd': ++opt_d, ++opt_v; break;
|
|
case 'v': ++opt_v; break;
|
|
default: fatal("unknown command-line option '%c'", *arg);
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
replPath(arg);
|
|
++repled;
|
|
}
|
|
}
|
|
|
|
if (!repled) replFile(stdin);
|
|
|
|
return 0;
|
|
}
|