diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..f4f6816 --- /dev/null +++ b/Makefile @@ -0,0 +1,59 @@ +OFLAGS += -Wall -Wno-unused -O3 -DNDEBUG +GFLAGS += -Wall -Wno-unused -g +PFLAGS += $(OFLAGS) -pg +CFLAGS += -I/opt/local/include +LDLIBS += -L/opt/local/lib +LDLIBS += -lgc -lm + +MAIN = minproto + +all : $(MAIN) + +% : %.c + $(CC) $(GFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ $< $(LDLIBS) + +%-opt : %.c + $(CC) $(OFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ $< $(LDLIBS) + +%-prof : %.c + $(CC) $(PFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ $< $(LDLIBS) + +%.c : %.leg + leg -o $@ $< + +test : $(MAIN) + ./$(MAIN) < test.txt | tee test.out + @diff test.ref test.out && echo '\012--- PASSED ---' + +testref : $(MAIN) + ./$(MAIN) < test.txt | tee test.ref + +bench : $(MAIN)-opt + time ./$(MAIN)-opt -O bench.txt + time ./$(MAIN)-opt -O bench.txt + time ./$(MAIN)-opt -O bench.txt + +sieve : $(MAIN)-opt + time ./$(MAIN)-opt -O bench-sieve.txt + time ./$(MAIN)-opt -O bench-sieve.txt + time ./$(MAIN)-opt -O bench-sieve.txt + +profile : $(MAIN)-prof + ./$(MAIN)-prof -O < bench.txt + gprof ./$(MAIN)-prof gmon.out + +FILES = Makefile $(MAIN).leg bench.txt test.txt test2.txt + +checkpoint : .FORCE + tar cvfz ckpt/minproto-$(shell date "+%Y%m%d-%H%M%S").tgz $(FILES) + +clean : .FORCE + rm -rf $(MAIN) $(MAIN)-opt $(MAIN)-prof *.o *.dSYM *.sync-conflict-* + +spotless : clean + rm -f *~ + +stats : .FORCE + @echo $(shell tr -d ' \t\\' < minproto.leg | sort -u | wc -l) lines of code + +.FORCE : diff --git a/bench-sieve.txt b/bench-sieve.txt new file mode 100644 index 0000000..aaed65c --- /dev/null +++ b/bench-sieve.txt @@ -0,0 +1,34 @@ +numbers = 8192; // 1028 primes +repeats = 50; + +count = 0; + +then = cputime(); + +evals = evaluations(); + +for (n = 0; n < repeats; n = n + 1) { + print("\r", n, "/", repeats); + sieve = []; + count = 0; + for (i in numbers) sieve.push(nil); + for (i = 2; i < numbers; i = i + 1) { + if (!sieve[i]) { + // print(i, " "); + count = count + 1; + for (k = i+i; k < numbers; k = k+i) + sieve[k] = #t; + } + } + count; +} + +evals = evaluations() - evals; + +now = cputime(); +secs = now - then; + +print("\r", count, " primes in the first ", numbers, " numbers\n"); +print(evals, " nodes evaluated in ", + secs, " seconds = ", + round(evals / secs), " nodes/sec\n"); diff --git a/bench.txt b/bench.txt new file mode 100644 index 0000000..40e68d3 --- /dev/null +++ b/bench.txt @@ -0,0 +1,10 @@ +nfib = (n) { if (n < 2) 1; else nfib(n-1) + nfib(n-2) + 1; }; + +then = cputime(); +calls = nfib(32); +now = cputime(); +secs = now - then; + +print(calls, " calls in ", + secs, " seconds = ", + round(calls / secs), " calls/sec\n"); diff --git a/minproto.leg b/minproto.leg new file mode 100644 index 0000000..7b23923 --- /dev/null +++ b/minproto.leg @@ -0,0 +1,2509 @@ +# minproto.leg -- minimal prototype langauge for semantic experiments +# +# last edited: 2024-05-07 14:39:10 by piumarta on zora-1034.local + +%{ +; +#ifndef GC +# define GC 1 +#endif + +#ifndef TAGS +# define TAGS 1 +#endif + +#ifndef TYPECODES +# define TYPECODES 0 +#endif + +#ifndef PRIMCLOSURE +# define PRIMCLOSURE 1 +#endif + +#ifndef DELOPT +# define DELOPT 0 +#endif + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include // getrusage() + +#if GC +# include +# 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) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) +#else +#define doProtos(_) _(Object) _(GetVar) _(SetVar) _(GetProp) _(SetProp) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Binop) _(Unyop) _(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) + +#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 lambda, 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) + +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, nil); + 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 lambda, oop environment) +{ + oop obj = make(Closure); + _set(obj, Closure,lambda, lambda); + _set(obj, Closure,environment, environment); + return 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 = obj; + while (is(Object, o)) { + ssize_t ind = Object_find(o, key); + if (ind >= 0) return _get(o, Object,properties)[ind].val; + o = _getDelegate(o); + } +# define makeCase(NAME) case NAME: o = p##NAME; break; + switch (getType(obj)) { + doTypes(makeCase); + case Object: break; + } +# undef makeCase +# if !DELOPT + if (key == prop_delegate) return o; // implicit delegate of atomic object +# endif + while (is(Object, o)) { + ssize_t ind = Object_find(o, key); + if (ind >= 0) return _get(o, Object,properties)[ind].val; + o = _getDelegate(o); + } +# if DELOPT + if (key == prop_delegate) { +# define makeCase(NAME) case NAME: return p##NAME; + switch (getType(obj)) { + doTypes(makeCase); + case Object: return _getDelegate(obj); + } +# undef makeCase + } +# endif + fatal("%s.%s is undefined", storeString(obj, 0), storeString(key, 0)); + return nil; +} + +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); + } + return is(Symbol, key) ? _get(key, Symbol,value) : nil; +} + +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) +{ + 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, "'); + break; + } +#if PRIMCLOSURE + case Lambda: { + codeParametersOn(str, _get(obj, Lambda,parameters), "(", ")"); + codeBlockOn(str, _get(obj, Lambda,body)); + break; + } + case Closure: { + String_appendAll(str, ""); + 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, "'); + break; + } +#if PRIMCLOSURE + case Lambda: String_appendAll(buf, ""); break; + case Closure: String_appendAll(buf, ""); 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 = ""; +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 + +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) +{ + return is(Closure, func) && _get(func, Closure,fixed); +} + +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); + if (nil == ifunc) fatal("%s.%s is undefined", storeString(self, 0), storeString(meth, 0)); + 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 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 newClosure(oop lambda, oop environment) +{ + oop o = new(pClosure); + Object_put(o, sym_lambda , lambda ); + Object_put(o, sym_environment, environment); + return o; +} + +oop Closure_eval(oop exp, oop env) +{ + return exp; +} + +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) + Object_put(clone, kvs[i].key, quasiclone(kvs[i].val, env)); + oop delegate = _getDelegate(exp); + if (nil != delegate) + 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 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; + for (int i = 0; i < size; ++i) result = eval(indexed[i], env); + 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 = 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 } + +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 - + +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,lambda); + oop environment = _get(func, Closure,environment); + oop parameters = _get(lambda, Lambda,parameters); + oop body = _get(lambda, Lambda,body); +#else + if (Object != functype || pClosure != _getDelegate(func)) + fatal("cannot %s %s", (nil == self ? "call" : "invoke"), storeString(func, 0)); + oop lambda = Object_get(func, sym_lambda); + oop 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); \ + } + +#define defineCodeOn(NAME) \ + static inline oop prim_##NAME##_codeOn(oop func, oop exp, oop args, oop env) { \ + NAME##_codeOn(exp, getArgType(args, 0, String, #NAME".codeOn"), env); \ + return exp; \ + } \ + +doProtos(defineEval) +doProtos(defineCodeOn) + +#undef defineEval +#undef defineCodeOn + +#endif // !TYPECODES + +static inline oop evalobj(oop exp, oop env) +{ +# if !TYPECODES + + 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: NAME##_eval(exp, env); break; + 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 (is(Object, self)) { + int size = _get(self, Object,psize); + struct property *kvs = _get(self, Object,properties); +# if DELOPT + if (nil != _getDelegate(self)) Object_push(keys, prop_delegate); +# endif + for (int i = 0; i < size; ++i) Object_push(keys, kvs[i].key); + } + return keys; +} + +oop prim_env(oop func, oop self, oop args, oop env) +{ + return env; +} + +oop prim_makeForm(oop func, oop self, oop args, oop env) +{ + int argc = _get(args, Object,isize); + oop *indexed = _get(args, Object,indexed); + oop result = nil; + for (int i = 0; i < argc; ++i) { + result = indexed[i]; + if (!is(Closure, result)) fatal("makeForm: argument must be closure"); + _set(result, Closure,fixed, 1); + } + return result; +} + +oop prim_makeMacro(oop func, oop self, oop args, oop env) +{ + int argc = _get(args, Object,isize); + oop *indexed = _get(args, Object,indexed); + oop result = nil; + for (int i = 0; i < argc; ++i) { + result = indexed[i]; + if (!is(Closure, result)) fatal("makeForm: argument must be closure"); + _set(result, Closure,fixed, 1); + } + return result; +} + +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 +# 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("makeForm" ), Symbol,value, newPrimitive(prim_makeForm)); + _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; +} diff --git a/test.ref b/test.ref new file mode 100644 index 0000000..dac0403 --- /dev/null +++ b/test.ref @@ -0,0 +1,156 @@ +nil 42 3.140000 string Symbol newline +Object => +Lambda => +Closure => +o = Object.new() => <> +o = Object.new(foo:42, bar: 666) => <> + | bar: 666 + | foo: 42 +o.foo => 42 +Point.new() => <> +Point.new(x: 3, y: 4) => <> + | y: 4 + | x: 3 +twice 21 is 42 +double => +Point.new(x:3, y:4).magnitude() => 5.000000 +<> + | self: nil => + | self: nil + | n: 39 + | 0: 40 +40 +<> + | self: nil => + | self: nil + | n: 40 + | 0: 40 +41 +<> + | self: nil => + | self: nil + | n: 41 + | 0: 40 +42 +<> + | self: nil => + | self: nil + | n: 42 + | 0: 40 +43 +nil no +1 yes +hello yes +15 +1973 +42 42 42 42 +ok +ok +42 +---- +MyType.__eval__() invoked +42 + +==== +42 +hello +nil + + +nil +[KEY: __delegate__ +KEY: y +KEY: x +] +Symbol + + +nil +POINT +P <> +P <> +Q <> +P.mag 13.000000 +<> + | bar: 666 + | foo: 42 + | 0: 1 + | 1: <> + | | 0: 2 + | | 1: 3 + | | 2: 42 +[KEY: __delegate__ +KEY: bar +KEY: foo +] +5 +7 +0 +1 +2 +0 +1 +0: a +2 +0: a +1: b +3 +0: a +1: b +2: c +12 +0: 104 +1: 101 +2: 108 +3: 108 +4: 111 +5: 44 +6: 32 +7: 119 +8: 111 +9: 114 +10: 108 +11: 100 +hello, world +hallo, world +hally, world +hally, wirld +READ = f() { print(__env__()) } +f(); +0 30 t +<> +f 102 ( 40 ) 41 32 { 123 32 p 112 r 114 i 105 n 110 t 116 ( 40 _ 95 _ 95 e 101 n 110 v 118 _ 95 _ 95 ( 40 ) 41 ) 41 32 } 125 + 10 f 102 ( 40 ) 41 ; 59 + 10 +<> + | operation: 15 + | 0: 6 + | 1: 7 +42 +42 +6 * 7 +MACRO table <> + | test: +define testfun +MACRO EVAL test with 1 and 2 +MACRO EVAL test with three and four +call testfun +REPLACEMENT 1 +REPLACEMENT three +0 1 2 3 4 5 6 7 8 9 10 +10 9 8 7 6 5 4 3 2 1 0 +0 1 2 3 4 5 6 7 8 9 +65 66 67 68 69 +1 two 3 four +11: n * factorial(n - 1) +10: if (n < 2) "1" else n * factorial(n - 1) + 9: factorial(n - 1) + 8: n * factorial(n - 1) + 7: if (n < 2) "1" else n * factorial(n - 1) + 6: factorial(n - 1) + 5: n * factorial(n - 1) + 4: if (n < 2) "1" else n * factorial(n - 1) + 3: factorial(n - 1) + 2: n * factorial(n - 1) + 1: if (n < 2) "1" else n * factorial(n - 1) + 0: factorial(5) diff --git a/test.txt b/test.txt new file mode 100644 index 0000000..475bb5a --- /dev/null +++ b/test.txt @@ -0,0 +1,329 @@ +// nil is the undefined object +// integers, floats, strings are as usual +// # is a symbol literal + +print(nil, " ", 42, " ", 3.14, " string ", #Symbol, " newline \n"); + +// the prototypical object types used in the implementation have global names +// e.g., Object is the prototypical object at the root of the delegation hierarchy + +print("Object => ", Object, "\n"); // this prints as +print("Lambda => ", Lambda, "\n"); // this prints as +print("Closure => ", Closure, "\n"); // this prints as + +// create a new object instance by asking an existing one to be the delegate for a new instance +// e.g., to create a new object that delegates to the prototype Object... + +o = Object.new(); + +print("o = Object.new() => ", o, "\n"); + +// this prints as <> because the number of <> surrounding the name tells you +// how many levels of delegation were needed before the __name__ property was found + +// arguments can be positional and/or key:value pairs +// for the new() method, the arguments become the properties of the newly created object + +o = Object.new(foo: 42, bar: 666); + +print("o = Object.new(foo:42, bar: 666) => ", o, "\n", full: 1); +print("o.foo => ", o.foo, "\n"); + +// to create a new type make a prototype with a __name__ that delegates to another prototype + +Point = Object.new(__name__: #Point); + +// objects can be created from the new prototype because it delegates to the Object prototype, +// in other words the new prototype 'inherits' Object.new() + +// objects created from the new prototype will inherit its __name__ property + +print("Point.new() => ", Point.new(), "\n"); +print("Point.new(x: 3, y: 4) => ", Point.new(x: 3, y: 4), "\n", full: 1); + +// anonymous functions are written: "(parameters...) { statements... }" +// all statements return values +// the last statement in a block provides a return value for the entire function + +double = (x) { x+x }; + +print("twice 21 is ", double(21), "\n"); + +// use the keyword argument "full:x" (where x is non-nil) to make the print primitive +// recursively print the entire contents of any objects it encounters + +print("double => ", double, "\n", full:1); + +// anonymous functions installed as properties of a prototype become methods +// for all objects that delegate to the prototype + +Point.magnitude() { sqrt(self.x * self.x + self.y * self.y) } + +m = Point.new(x: 3, y: 4).magnitude(); + +print("Point.new(x:3, y:4).magnitude() => ", m, "\n"); + +// functions close over their dynamic environment when created +// (yes, I know, something needs to be done about all the nasty semicolons) + +makeCounter(n) +{ + n = n - 1; // make the counter return n the first time it is called + () { print(__env__(), "\n", full:1); n = n + 1 } // the counter is an anonymous function, closing over n, that increments n +} + +counter = makeCounter(40); + +print(counter(), "\n"); +print(counter(), "\n"); +print(counter(), "\n"); +print(counter(), "\n"); + +test(x) { print(x, " "); if (x) print("yes\n") else print("no\n") } + +test(nil); +test(1); +test("hello"); + +nfib(n) { if (n < 2) 1 else nfib(n-1) + nfib(n-2) + 1 } + +print(nfib(5), "\n"); +print(nfib(15), "\n"); + +assert(x) { + if (!(eval(x))) { + print("\nassertion failed: ", codeString(x), "\n"); + exit(1); + } +} + +makeForm(assert); + +refute(x) { + if (eval(x)) { + print("\nrefutation failed: ", codeString(x), "\n"); + exit(1); + } +} + +makeForm(refute); + +assert(1 == 1); +refute(1 == 0); + +assert(0 < 1); refute(1 < 1); refute(2 < 1); +assert(0 <= 1); assert(1 <= 1); refute(2 <= 1); +refute(0 >= 1); assert(1 >= 1); assert(2 >= 1); +refute(0 > 1); refute(1 > 1); assert(2 > 1); + +refute(0 == 1); assert(1 == 1); refute(2 == 1); +assert(0 != 1); refute(1 != 1); assert(2 != 1); + +assert(16 << 0 == 16); assert(16 << 1 == 32); assert(16 << 2 == 64); assert(16 << 3 == 128); +assert(16 >> 0 == 16); assert(16 >> 1 == 8); assert(16 >> 2 == 4); assert(16 >> 3 == 2); + +print(0b101010, " "); +print(052, " "); +print(42, " "); +print(0x2a, "\n"); + +bin__(n, b, w) { + if (n >= 2 || w > 1) bin__(truncate(n / 2), b, w - 1); + print(n % 2); +} + +assert((0b1110 | 0b0111) == 0b1111); +assert((0b1110 ^ 0b0111) == 0b1001); +assert((0b1110 & 0b0111) == 0b0110); + +nt = 0; +nf = 0; + +t() { nt = nt + 1; #t } +f() { nf = nf + 1; nil } + +refute(f() || f()); assert(nt == 0); assert(nf == 2); +assert(f() || t()); assert(nt == 1); assert(nf == 3); +assert(t() || f()); assert(nt == 2); assert(nf == 3); +assert(t() || t()); assert(nt == 3); assert(nf == 3); + +refute(f() && f()); assert(nt == 3); assert(nf == 4); +refute(f() && t()); assert(nt == 3); assert(nf == 5); +refute(t() && f()); assert(nt == 4); assert(nf == 6); +assert(t() && t()); assert(nt == 6); assert(nf == 6); + +1 || ({ print("fail\n"); exit(1) }); +nil && ({ print("fail\n"); exit(1) }); +nil || print("ok\n"); +1 && print("ok\n"); + +print(eval(42), "\n"); + +MyType = Object.new(__name__: #MyType); + +print("----\n"); + +MyType.__eval__(self) { + print("MyType.__eval__() invoked\n"); + 42; +} + +myType = MyType.new(); + +print(eval(myType), "\n"); + +Object.print() { print(self) } +Object.println() { self.print(); print("\n") } + +(){}.println(); + +x = 42; + +print("====\n"); + +(42).println(); +"hello".println(); +nil.println(); +nil.__delegate__.println(); +nil.__delegate__.__delegate__.println(); +nil.__delegate__.__delegate__.__delegate__.println(); + +Object.dump() +{ + print("["); + keys = self.keys(); + for (key in keys) print("KEY: ", key, "\n"); + print("]\n"); +} + +p = Point.new(x: 3, y: 4); + +p.dump(); + +#Symbol.println(); +#Symbol.__delegate__.println(); +#Symbol.__delegate__.__delegate__.println(); +#Symbol.__delegate__.__delegate__.__delegate__.println(); + +print("POINT ", Point, "\n"); + +p = [x:5, y:12]; +print("P ", p, "\n"); + +p[#__delegate__] = Point; +print("P ", p, "\n"); + +q = [__delegate__:Point, x:5, y:12]; +print("Q ", q, "\n"); + +print("P.mag ", p.magnitude(), "\n"); + +o = [bar:666, 1, [2, 3, 6*7], foo:42]; + +print(o, "\n", full:1); + +o.dump(); + +print(len("Hello"), "\n"); +print(len(#Goodbye), "\n"); +print(len([]), "\n"); +print(len([1]), "\n"); +print(len([1, 2]), "\n"); + +printelts(x) +{ + n = len(x); + print(n, "\n"); + i = 0; + while (i < n) { + print(i, ": ", x[i], "\n"); + i = i + 1; + } + x; +} + +f() { + printelts(__env__()); +} + +f(); +f("a"); +f("a", "b"); +f("a", "b", "c"); + +printelts("hello, world"); + +s = "hello, world\n"; print(s); +s[1] = 97; print(s); +s[4] = ord("y"); print(s); +s[8] = ord("i"); print(s); + +print("READ = ", readfile("test2.txt")); + +Object.subtype(name) { self.new(__name__: name) } + +Stream = Object.subtype(#Stream); + +newStream(string) { + self = Stream.new( + content: string, + position: 0, + limit: len(string) + ); + print(self.position, " ", self.limit, " ", !self.atEnd(), "\n"); + self; +} + +Stream.atEnd() { self.position >= self.limit } +Stream.peek() { !self.atEnd() && self.content[self.position] } + +Stream.next() { + !self.atEnd() && { + c = self.content[self.position]; + self.position = self.position + 1; + c; + } +} + +s = newStream(readfile("test2.txt")); + +print(s, "\n"); + +while (!s.atEnd()) print(chr(s.peek()), " ", s.next(), " "); +print("\n"); + +x = (`6*7;); +print(x, "\n", full:1); +print(x.__eval__(), "\n", full:1); + +print(eval(x), "\n"); +print(codeString(x), "\n"); + +Symbol.macros.test = (x, y) +{ + print("MACRO EVAL test with ", x, " and ", y, "\n"); + `{print("REPLACEMENT ", @x, "\n"); @y } +}; + +print("MACRO table ", Symbol.macros, "\n", full:1); + +print("define testfun\n"); + +testfun() { + test(1, 2); + test("three", "four"); +} + +print("call testfun\n"); + +testfun(); + +for (i from 0 to 10) print(i, " "); print("\n"); +for (i from 10 to 0) print(i, " "); print("\n"); +for (i in 10) print(i, " "); print("\n"); +for (i in "ABCDE") print(i, " "); print("\n"); +for (i in [1, "two", 3, "four"]) print(i, " "); print("\n"); + +factorial(n) { if (n < 2) "1" else n * factorial(n-1) } + +factorial(5); diff --git a/test2.txt b/test2.txt new file mode 100644 index 0000000..d49c840 --- /dev/null +++ b/test2.txt @@ -0,0 +1,2 @@ +f() { print(__env__()) } +f();