You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
5465 rivejä
179 KiB
5465 rivejä
179 KiB
# minproto.leg -- minimal prototype langauge for semantic experiments
|
|
#
|
|
# last edited: 2024-07-10 11:28:02 by piumarta on zora-1034.local
|
|
|
|
%{
|
|
;
|
|
//#define YY_DEBUG 1
|
|
|
|
#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, because no associative lookup of __delegate__)
|
|
#endif
|
|
|
|
#ifndef BINOPT // store pointer to implemention function in Binop nodes
|
|
# define BINOPT 0 // (approx. 1% performance decrease due to lookup + indirect call)
|
|
#endif
|
|
|
|
#ifndef NONLOCAL // support non-local control flow (return, break, continue)
|
|
# define NONLOCAL 1 // (approx. 5% [loop] to 55% [call] performance decrease, because of jmp_buf initialisations)
|
|
#endif
|
|
|
|
#ifndef EXCEPTIONS // report errors by raising an exception
|
|
# define EXCEPTIONS 1
|
|
#endif
|
|
|
|
#ifndef FOLDCONST // fold constant expressions during parsing
|
|
# define FOLDCONST 1
|
|
#endif
|
|
|
|
#ifndef PROFILE // include profiling support
|
|
# define PROFILE 0
|
|
#endif
|
|
|
|
#ifndef PEGVM // include parsing expression grammar VM
|
|
# define PEGVM 1
|
|
#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 xcalloc(N,S) (GC_malloc((N)*(S)))
|
|
# define xmalloc(N) (GC_malloc(N))
|
|
# define xmallocAtomic(N) (GC_malloc_atomic(N))
|
|
# define xrealloc(P, N) (GC_realloc(P, N))
|
|
# define xfree(P) (GC_free(P))
|
|
#else
|
|
# define GC_INIT()
|
|
# define xcalloc(N,S) (calloc(N, S))
|
|
# define xmalloc(N) (calloc(1, N))
|
|
# define xmallocAtomic(N) (calloc(1, N))
|
|
# define xrealloc(P, N) (realloc(P, N))
|
|
# define xfree(P) (free(P))
|
|
#endif
|
|
|
|
#define indexableSize(A) (sizeof(A) / sizeof(*(A)))
|
|
|
|
void warning(char *fmt, ...);
|
|
void fatal(char *fmt, ...);
|
|
|
|
int opt_O = 0;
|
|
int opt_d = 0;
|
|
int opt_p = 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);
|
|
|
|
oop codeOn(oop buf, oop obj, int indent);
|
|
oop storeOn(oop buf, oop obj, int indent);
|
|
oop printOn(oop buf, oop obj, int indent);
|
|
|
|
#if TAGS
|
|
# define TAGBITS 2
|
|
# define TAGMASK 3
|
|
# define TAGINT Integer // 1
|
|
# define TAGFLT Float // 2
|
|
#endif
|
|
|
|
#if PRIMCLOSURE
|
|
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure)_(Raise)_(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal)
|
|
#else
|
|
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure) _(Raise) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure)
|
|
#endif
|
|
|
|
#define declareProto(NAME) oop p##NAME = 0;
|
|
doProtos(declareProto);
|
|
#undef declareProto
|
|
|
|
#define declareTypecode(NAME) t##NAME,
|
|
enum typecode {
|
|
UNDEFINED_TYPECODE,
|
|
doProtos(declareTypecode)
|
|
};
|
|
#undef declareTypecode
|
|
|
|
#define makeProto(NAME) oop p##NAME = 0;
|
|
doTypes(makeProto);
|
|
#undef makeProto
|
|
|
|
#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) _(owner) _(profile)
|
|
|
|
#define declareProp(NAME) oop prop_##NAME = 0;
|
|
doProperties(declareProp);
|
|
#undef declareProp
|
|
|
|
#define doSymbols(_) _(t) _(name) _(expr) _(function) _(arguments) _(object) _(index) _(key) _(value) _(self) _(method) _(parameters) _(body) _(lambda) _(environment) _(operation) _(full) _(condition) _(consequent) _(alternate) _(expression) _(identifier) _(initialise) _(update) _(first) _(last) _(fixed) _(keyvals) _(__namespaces__) _(O) _(d) _(p) _(v) _(statement) _(handler) _(kind) _(message) _(operand1) _(operand2) _(profile) _(parent) _(count) _(stamp) _(time) _(start) _(stop) _($$) _(yytext) _(yyleng)
|
|
|
|
#define declareSym(NAME) oop sym_##NAME = 0;
|
|
doSymbols(declareSym);
|
|
#undef declareSym
|
|
|
|
#if NONLOCAL
|
|
|
|
#include <setjmp.h>
|
|
|
|
enum {
|
|
NLR_INIT = 0, // initialisation, no non-local flow
|
|
NLR_CONTINUE, // non-local jump back to the start of active loop
|
|
NLR_BREAK, // non-local jump out of the active loop
|
|
NLR_RETURN, // non-local return from the active function
|
|
NLR_RAISE, // exception
|
|
};
|
|
|
|
struct NLR {
|
|
int ntrace;
|
|
jmp_buf env;
|
|
};
|
|
|
|
struct NLR *nlrs = 0;
|
|
|
|
int nnlrs = 0;
|
|
int maxnlrs = 0;
|
|
oop valnlr = 0;
|
|
|
|
#define nlrPush() ({ \
|
|
if (++nnlrs >= maxnlrs) nlrs = realloc(nlrs, sizeof(struct NLR) * (maxnlrs += 32)); \
|
|
nlrs[nnlrs - 1].ntrace = _get(trace, Object,isize); \
|
|
setjmp(nlrs[nnlrs - 1].env); \
|
|
})
|
|
|
|
#define nlrReturn(VAL, TYPE) { \
|
|
valnlr = VAL; \
|
|
longjmp(nlrs[nnlrs-1].env, TYPE); \
|
|
}
|
|
|
|
#define nlrPop() (_set(trace, Object,isize, nlrs[--nnlrs].ntrace), valnlr)
|
|
|
|
#endif
|
|
|
|
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
|
|
#if PROFILE
|
|
struct Primitive { enum type type; oop name; prim_t function; void *cookie; oop profile; int index; };
|
|
#else
|
|
struct Primitive { enum type type; oop name; prim_t function; void *cookie; int index; };
|
|
#endif
|
|
#if PRIMCLOSURE
|
|
struct Lambda { enum type type; oop parameters, body, parent, name; };
|
|
struct Closure { enum type type; oop fixed, 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)
|
|
|
|
oop namespaces = nil;
|
|
|
|
#define UNDEFINED 0
|
|
|
|
|
|
void typeError(char *who, char *msg, oop value);
|
|
void typeError2(char *who, char *msg, oop lhs, oop rhs);
|
|
void rangeError(char *who, char *msg, oop object, int index);
|
|
void valueError(char *who, char *msg, oop value);
|
|
void keyError(char *who, char *msg, oop object, oop key);
|
|
void undefinedError(oop name);
|
|
void syntaxError(char *message);
|
|
void unknownError(char *message);
|
|
void keyboardInterrupt(void);
|
|
|
|
|
|
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)) typeError(op, "non-integer operand", obj);
|
|
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
|
|
}
|
|
|
|
#define isFloat(obj) is(Float, obj)
|
|
|
|
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: typeError(op, "non-numeric operand", obj);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
oop newStringLen(char *value, int length)
|
|
{
|
|
oop obj = make(String);
|
|
char *str = xmallocAtomic(length+1);
|
|
if (value) memcpy(str, value, length);
|
|
else if (length) memset(str, 0, 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));
|
|
}
|
|
|
|
#define isString(obj) is(String, obj)
|
|
|
|
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);
|
|
char *copy = xmalloc(length + 1);
|
|
memcpy(copy, value, length);
|
|
set(str, String,value, copy);
|
|
set(str, String,length, length+1);
|
|
copy[length] = c;
|
|
return str;
|
|
}
|
|
|
|
oop String_appendAllLen(oop str, char *s, int len)
|
|
{
|
|
if (len < 1) return str;
|
|
int length = get(str, String,length);
|
|
char *value = get(str, String,value);
|
|
char *copy = xmalloc(length + len);
|
|
memcpy(copy, value, length);
|
|
memcpy(copy + length, s, len);
|
|
set(str, String,value, copy);
|
|
set(str, String,length, length+len);
|
|
return str;
|
|
}
|
|
|
|
oop String_appendAll(oop str, char *s)
|
|
{
|
|
return String_appendAllLen(str, s, strlen(s));
|
|
}
|
|
|
|
oop String_appendString(oop str, oop val)
|
|
{
|
|
return String_appendAllLen(str, _get(val, String,value), _get(val, String,length));
|
|
}
|
|
|
|
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 (;;) {
|
|
char *orig = value;
|
|
value = xmalloc(length + cap);
|
|
memcpy(value, orig, length);
|
|
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 String_concat(oop a, oop b)
|
|
{
|
|
oop result = newStringLen(_get(a, String,value), _get(a, String,length));
|
|
String_appendAllLen(result, _get(b, String,value), _get(b, String,length));
|
|
return result;
|
|
}
|
|
|
|
oop String_repeat(oop s, int n)
|
|
{ assert(is(String, s));
|
|
char *chars = _get(s, String,value);
|
|
int length = _get(s, String,length);
|
|
oop result = newStringLen(0, 0);
|
|
while (n-- > 0) String_appendAllLen(result, chars, length);
|
|
return result;
|
|
}
|
|
|
|
int digitValue(int digit, int base)
|
|
{
|
|
if ('0' <= digit && digit <= '9') digit -= '0';
|
|
else if ('a' <= digit && digit <= 'z') digit -= 'a' - 10;
|
|
else if ('A' <= digit && digit <= 'Z') digit -= 'A' - 10;
|
|
else 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;
|
|
}
|
|
|
|
oop newStringUnescaped(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'...'7': --string; c = readCharValue(&string, 8, 3); break;
|
|
default : warning("illegal character escape sequence: \\%c", c); break;
|
|
}
|
|
}
|
|
String_append(buf, c);
|
|
}
|
|
return buf;
|
|
}
|
|
|
|
oop String_escaped(oop obj)
|
|
{ assert(is(String, obj));
|
|
oop buf = newStringLen(0, 0);
|
|
char *str = _get(obj, String,value);
|
|
int len = _get(obj, String,length);
|
|
while (len--) {
|
|
int c = *str++;
|
|
if (c == '"') String_appendAll(buf, "\\\"");
|
|
else if (c == '\\') String_appendAll(buf, "\\\\");
|
|
else if (c >= ' ' && c <= '~') String_append(buf, c);
|
|
else {
|
|
switch (c) {
|
|
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;
|
|
default:
|
|
String_format(buf, "\\%03o", c);
|
|
continue;
|
|
}
|
|
String_format(buf, "\\%c", c);
|
|
}
|
|
}
|
|
return buf;
|
|
}
|
|
|
|
char *codeString(oop obj, int indent);
|
|
char *printString(oop obj, int indent);
|
|
|
|
oop String_push(oop obj, oop val) // val is String OR Integer
|
|
{
|
|
if (isInteger(val)) String_append(obj, _integerValue(val));
|
|
else if (is(String, val)) String_appendAllLen(obj, _get(val, String,value), _get(val, String,length));
|
|
else if (is(Symbol, val)) String_appendAllLen(obj, _get(val, Symbol,name), strlen(_get(val, Symbol,name)));
|
|
else typeError("String.push", "value is not integer, string, or symbol", val);
|
|
return val;
|
|
}
|
|
|
|
void getSliceRange(oop obj, oop ostart, oop ostop, int len, int *pstart, int *pstop)
|
|
{
|
|
int start = (nil == ostart) ? 0 : integerValue(ostart, "[:]");
|
|
int stop = (nil == ostop ) ? len : integerValue(ostop, "[:]");
|
|
if (start < 0) start += len;
|
|
if (start < 0 || start >= len) rangeError("[:]", "start index out of bounds", obj, start);
|
|
if (stop < 0) stop += len;
|
|
if (stop < 0 || stop > len) rangeError("[:]", "end index out of bounds", obj, stop);
|
|
*pstart = start;
|
|
*pstop = stop;
|
|
}
|
|
|
|
void print(oop obj, int indent);
|
|
|
|
oop String_slice(oop obj, oop ostart, oop ostop)
|
|
{
|
|
int len = _get(obj, String,length), start, stop;
|
|
getSliceRange(obj, ostart, ostop, len, &start, &stop);
|
|
if (start >= stop) return newStringLen(0, 0);
|
|
return newStringLen(_get(obj, String,value) + start, stop - start);
|
|
}
|
|
|
|
oop newSymbol(char *name)
|
|
{
|
|
oop obj = make(Symbol);
|
|
_set(obj, Symbol,name, strdup(name));
|
|
_set(obj, Symbol,value, UNDEFINED);
|
|
# if TYPECODES
|
|
_set(obj, Symbol,typecode, UNDEFINED_TYPECODE);
|
|
# endif
|
|
return obj;
|
|
}
|
|
|
|
char *stringValue(oop obj, char *who)
|
|
{
|
|
int type = getType(obj);
|
|
if (type == String) return String_content(obj);
|
|
if (type == Symbol) return _get(obj, Symbol,name);
|
|
typeError(who, "non-string operand", obj);
|
|
return 0;
|
|
}
|
|
|
|
int stringLength(oop obj, char *who)
|
|
{
|
|
int type = getType(obj);
|
|
if (type == String) return _get(obj, String,length);
|
|
if (type == Symbol) return strlen(_get(obj, Symbol,name));
|
|
typeError(who, "non-string operand", obj);
|
|
return 0;
|
|
}
|
|
|
|
oop intern(char *name);
|
|
|
|
oop Symbol_slice(oop obj, oop ostart, oop ostop)
|
|
{
|
|
char *name = _get(obj, Symbol,name);
|
|
int len = strlen(name), start, stop;
|
|
getSliceRange(obj, ostart, ostop, len, &start, &stop);
|
|
if (start >= stop) return intern(""); // ?!?
|
|
char buf[stop - start + 1];
|
|
strncpy(buf, name + start, stop - start);
|
|
buf[stop - start] = 0;
|
|
return intern(buf);
|
|
}
|
|
|
|
oop Object_put(oop obj, oop key, oop val);
|
|
oop Object_push(oop obj, oop val);
|
|
|
|
oop primitives = 0;
|
|
|
|
oop newPrimitive(prim_t function, oop name)
|
|
{
|
|
oop obj = make(Primitive);
|
|
_set(obj, Primitive,name, name);
|
|
_set(obj, Primitive,function, function);
|
|
_set(obj, Primitive,cookie, 0);
|
|
# if PROFILE
|
|
_set(obj, Primitive,profile, nil);
|
|
# endif
|
|
_set(obj, Primitive,index, _get(primitives, Object,isize));
|
|
Object_put(primitives, obj, newInteger(_get(primitives, Object,isize)));
|
|
Object_push(primitives, obj);
|
|
return obj;
|
|
}
|
|
|
|
#if PRIMCLOSURE
|
|
|
|
oop newLambda(oop parameters, oop body, oop parent, oop name)
|
|
{
|
|
oop obj = make(Lambda);
|
|
_set(obj, Lambda,parameters, parameters);
|
|
_set(obj, Lambda,body, body);
|
|
# if PROFILE
|
|
_set(obj, Lambda,profile, 0);
|
|
# endif
|
|
_set(obj, Lambda,parent, parent);
|
|
_set(obj, Lambda,name, name);
|
|
return obj;
|
|
}
|
|
|
|
oop newClosure(oop function, oop environment)
|
|
{
|
|
oop obj = make(Closure);
|
|
_set(obj, Closure,function, function);
|
|
_set(obj, Closure,environment, environment);
|
|
_set(obj, Closure,fixed, nil);
|
|
return obj;
|
|
}
|
|
|
|
int isClosure(oop obj) { return is(Closure, obj); }
|
|
|
|
#endif
|
|
|
|
oop macros = 0;
|
|
oop *symbols = 0;
|
|
size_t nsymbols = 0;
|
|
size_t maxsymbols = 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;
|
|
}
|
|
if (++nsymbols >= maxsymbols) symbols = xrealloc(symbols, sizeof(*symbols) * (maxsymbols += 32));
|
|
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) rangeError("Object[]", "index out of bounds", obj, index);
|
|
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) rangeError("Object.[]=", "index out of bounds", obj, index);
|
|
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) rangeError("Object.pop", "object is empty", obj, 0);
|
|
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_refLocal(oop obj, oop key)
|
|
{
|
|
if (!is(Object, obj)) return 0;
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) return &_get(obj, Object,properties)[ind].val;
|
|
return 0;
|
|
}
|
|
|
|
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_ref(oop obj, oop key)
|
|
{
|
|
oop o = nil;
|
|
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 );
|
|
if (key == sym_parent ) return &_get(obj, Lambda,parent );
|
|
if (key == sym_name ) return &_get(obj, Lambda,name );
|
|
o = pLambda;
|
|
break;
|
|
case Closure:
|
|
if (key == sym_function ) return &_get(obj, Closure,function );
|
|
if (key == sym_environment) return &_get(obj, Closure,environment);
|
|
if (key == sym_fixed ) return &_get(obj, Closure,fixed);
|
|
o = pClosure;
|
|
break;
|
|
# endif
|
|
case Object: {
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) return &_get(obj, Object,properties)[ind].val;
|
|
o = _getDelegate(obj);
|
|
if (nil == o) o = pObject;
|
|
break;
|
|
}
|
|
}
|
|
if (key == prop_delegate) keyError("Object.", "__delegate__ is inaccessible", obj, prop_delegate);
|
|
while (is(Object, o)) {
|
|
ssize_t ind = Object_find(o, key);
|
|
if (ind >= 0) return &_get(o, Object,properties)[ind].val;
|
|
o = _getDelegate(o);
|
|
}
|
|
keyError("Object.", "undefined property", obj, key);
|
|
return 0;
|
|
}
|
|
|
|
oop Object_getOwner(oop obj, oop key, oop *ownerp)
|
|
{
|
|
oop o = nil;
|
|
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 );
|
|
if (key == sym_parent ) return _get(obj, Lambda,parent );
|
|
if (key == sym_name ) return _get(obj, Lambda,name );
|
|
o = pLambda;
|
|
break;
|
|
case Closure:
|
|
if (key == sym_function ) return _get(obj, Closure,function );
|
|
if (key == sym_environment) return _get(obj, Closure,environment);
|
|
if (key == sym_fixed ) return _get(obj, Closure,fixed );
|
|
o = pClosure;
|
|
break;
|
|
# endif
|
|
case Object: {
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) { *ownerp = obj; return _get(obj, Object,properties)[ind].val; }
|
|
o = _getDelegate(obj);
|
|
if (nil == o) o = pObject;
|
|
break;
|
|
}
|
|
}
|
|
if (key == prop_delegate) return o;
|
|
while (is(Object, o)) {
|
|
ssize_t ind = Object_find(o, key);
|
|
if (ind >= 0) { *ownerp = o; return _get(o, Object,properties)[ind].val; }
|
|
o = _getDelegate(o);
|
|
}
|
|
keyError("Object.", "undefined property", obj, key);
|
|
return nil;
|
|
}
|
|
|
|
oop Object_get(oop obj, oop key)
|
|
{
|
|
oop o = nil;
|
|
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 );
|
|
if (key == sym_parent ) return _get(obj, Lambda,parent );
|
|
if (key == sym_name ) return _get(obj, Lambda,name );
|
|
o = pLambda;
|
|
break;
|
|
case Closure:
|
|
if (key == sym_function ) return _get(obj, Closure,function );
|
|
if (key == sym_environment) return _get(obj, Closure,environment);
|
|
if (key == sym_fixed ) return _get(obj, Closure,fixed );
|
|
o = pClosure;
|
|
break;
|
|
# endif
|
|
case Object: {
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) return _get(obj, Object,properties)[ind].val;
|
|
o = _getDelegate(obj);
|
|
if (nil == o) o = pObject;
|
|
break;
|
|
}
|
|
}
|
|
if (key == prop_delegate) return o;
|
|
while (is(Object, o)) {
|
|
ssize_t ind = Object_find(o, key);
|
|
if (ind >= 0) return _get(o, Object,properties)[ind].val;
|
|
o = _getDelegate(o);
|
|
}
|
|
keyError("Object.", "undefined property", obj, key);
|
|
return nil;
|
|
}
|
|
|
|
oop *_refvar(oop obj, oop key)
|
|
{
|
|
while (is(Object, obj)) { // look for a binding of key in the local scopes
|
|
ssize_t ind = Object_find(obj, key);
|
|
if (ind >= 0) return &_get(obj, Object,properties)[ind].val;
|
|
obj = _getDelegate(obj);
|
|
}
|
|
int numspaces = _get(namespaces, Object,isize);
|
|
if (numspaces) { // look for a binding of key in the namespace stack
|
|
oop *nss = _get(namespaces, Object,indexed);
|
|
for (int i = numspaces; i--;) {
|
|
oop ns = nss[i];
|
|
ssize_t ind = Object_find(ns, key);
|
|
if (ind >= 0) return &_get(ns, Object,properties)[ind].val;
|
|
}
|
|
}
|
|
oop *ref = &_get(key, Symbol,value); // use the global binding
|
|
return ref;
|
|
}
|
|
|
|
oop *refvar(oop obj, oop key)
|
|
{
|
|
oop *ref = _refvar(obj, key);
|
|
if (UNDEFINED == *ref) undefinedError(key);
|
|
return ref;
|
|
}
|
|
|
|
oop getvar(oop obj, oop key)
|
|
{
|
|
return *refvar(obj, key);
|
|
}
|
|
|
|
oop Object_put(oop obj, oop key, oop val);
|
|
|
|
oop setvar(oop obj, oop key, oop val)
|
|
{
|
|
oop env = obj;
|
|
while (is(Object, env)) { // look for a binding of key in the local scopes
|
|
ssize_t ind = Object_find(env, key);
|
|
if (ind >= 0) return _get(env, Object,properties)[ind].val = val; // set it
|
|
env = _getDelegate(env);
|
|
}
|
|
if (nil != obj) return Object_put(obj, key, val); // create a new local variable
|
|
int numspaces = _get(namespaces, Object,isize);
|
|
if (numspaces) {
|
|
oop *nss = _get(namespaces, Object,indexed);
|
|
oop ns = nss[numspaces - 1];
|
|
if (is(Object, ns)) return Object_put(ns, key, val); // define a namespace variable
|
|
}
|
|
return _get(key, Symbol,value) = val; // set a global variable
|
|
}
|
|
|
|
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; }
|
|
if (key == sym_parent ) { _set(obj, Lambda,parent, val); return val; }
|
|
if (key == sym_name ) { _set(obj, Lambda,name, val); return val; }
|
|
break;
|
|
case Closure:
|
|
if (key == sym_fixed ) { _set(obj, Closure,fixed, val); return val; }
|
|
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 Object_slice(oop obj, oop ostart, oop ostop)
|
|
{
|
|
oop *indexed = _get(obj, Object,indexed);
|
|
int len = _get(obj, Object,isize), start, stop;
|
|
getSliceRange(obj, ostart, ostop, len, &start, &stop);
|
|
oop result = new(_getDelegate(obj));
|
|
for (int i = start; i < stop; ++i) Object_push(result, indexed[i]);
|
|
return result;
|
|
}
|
|
|
|
#if EXCEPTIONS
|
|
|
|
void genericError(char *who, char *message, char *kind, ...);
|
|
|
|
#define END (oop)0
|
|
|
|
void typeError(char *who, char *msg, oop value) { genericError(who, msg, "type error",
|
|
sym_value, value, END); }
|
|
|
|
void typeError2(char *who, char *msg, oop lhs, oop rhs) { genericError(who, msg, "type error",
|
|
sym_operand1, lhs, sym_operand2, rhs, END); }
|
|
|
|
void rangeError(char *who, char *msg, oop obj, int index) { genericError(who, msg, "index error",
|
|
sym_object, obj, sym_index, newInteger(index), END); }
|
|
|
|
void valueError(char *who, char *msg, oop value) { genericError(who, msg, "value error",
|
|
sym_value, value, END); }
|
|
|
|
void keyError(char *who, char *msg, oop object, oop key) { genericError(who, msg, "key error",
|
|
sym_object, object, sym_key, key, END); }
|
|
|
|
void undefinedError(oop name) { genericError( 0, 0, "undefined name",
|
|
sym_name, name, END); }
|
|
|
|
void syntaxError(char *msg) { genericError( 0, msg, "syntax error", END); }
|
|
|
|
void unknownError(char *msg) { genericError( 0, msg, "error", END); }
|
|
|
|
void keyboardInterrupt(void) { genericError( 0, 0, "keyboard interrupt", END); }
|
|
|
|
#undef END
|
|
|
|
#else
|
|
|
|
void typeError(char *who, char *msg, oop value) { fatal("%s: %s: %s", who, msg, getTypeName(value)); }
|
|
void typeError2(char *who, char *msg, oop lhs, oop rhs) { fatal("%s: %s: %s and %s", who, msg, getTypeName(lhs), getTypeName(rhs)); }
|
|
void rangeError(char *who, char *msg, oop obj, int index) { fatal("%s: %s: %s[%d]", who, msg, codeString(obj, 0), index); }
|
|
void valueError(char *who, char *msg, oop value) { fatal("%s: %s: %s", who, msg, codeString(value, 0)); }
|
|
void keyError(char *who, char *msg, oop object, oop key) { fatal("%s: %s: %s.%s", who, msg, codeString(object, 0), printString(key, 0)); }
|
|
void undefinedError(oop name) { fatal("undefined: %s", printString(name, 0)); }
|
|
void syntaxError(char *msg) { fatal("syntax error: %s", msg); }
|
|
void unknownError(char *msg) { fatal("%s", msg); }
|
|
void keyboardInterrupt(void) { fatal("keyboard interrupt"); }
|
|
|
|
#endif
|
|
|
|
|
|
int isSpecial(oop key)
|
|
{
|
|
return is(Symbol, key) && !strncmp("__", _get(key, Symbol,name), 2);
|
|
}
|
|
|
|
oop keys(oop self, int all)
|
|
{
|
|
oop keys = new(pObject);
|
|
# if DELOPT
|
|
if (all && 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;
|
|
# if PRIMCLOSURE
|
|
case Lambda: {
|
|
Object_push(keys, sym_parameters);
|
|
Object_push(keys, sym_body);
|
|
Object_push(keys, sym_parent);
|
|
Object_push(keys, sym_name);
|
|
break;
|
|
}
|
|
case Closure: {
|
|
Object_push(keys, sym_fixed);
|
|
Object_push(keys, sym_lambda);
|
|
Object_push(keys, sym_environment);
|
|
break;
|
|
}
|
|
# endif
|
|
case Object: {
|
|
int size = _get(self, Object,psize);
|
|
struct property *kvs = _get(self, Object,properties);
|
|
for (int i = 0; i < size; ++i) {
|
|
oop key = kvs[i].key;
|
|
if (all || !isSpecial(key)) Object_push(keys, key);
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
return keys;
|
|
}
|
|
|
|
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) {
|
|
double ll = floatValue(l, who), rr = floatValue(r, who);
|
|
return ll < rr ? -1 : (ll > rr ? 1 : 0);
|
|
}
|
|
if (String == tl && String == tr) {
|
|
int ll = _get(l, String,length), rr = _get(r, String,length);
|
|
if (ll == rr) return strncmp(_get(l, String,value), _get(r, String,value), ll);
|
|
return ll - rr;
|
|
}
|
|
if (Symbol == tl && Symbol == tr) return strcmp(stringValue(l, who), stringValue(r, who));
|
|
return (intptr_t)l - (intptr_t)r;
|
|
}
|
|
|
|
#if defined (__linux__)
|
|
int objcmp(const void *a, const void *b, void *who) { return cmp(*(oop *)a, *(oop *)b, who); }
|
|
#else
|
|
int objcmp(void *who, const void *a, const void *b) { return cmp(*(oop *)a, *(oop *)b, who); }
|
|
#endif
|
|
|
|
oop sortObject(oop obj, char *who)
|
|
{ assert(is(Object, obj));
|
|
# if defined(__linux__)
|
|
qsort_r(_get(obj, Object,indexed), _get(obj, Object,isize), sizeof(oop), objcmp, "sort");
|
|
# else
|
|
qsort_r(_get(obj, Object,indexed), _get(obj, Object,isize), sizeof(oop), "sort", objcmp);
|
|
# endif
|
|
return obj;
|
|
}
|
|
|
|
int chrcmp(const void *a, const void *b) { return *(char *)a - *(char *)b; }
|
|
|
|
oop sortString(oop obj)
|
|
{ assert(is(String, obj));
|
|
qsort(_get(obj, String,value), _get(obj, String,length), 1, chrcmp);
|
|
return obj;
|
|
}
|
|
|
|
oop clone(oop obj) // shallow copy
|
|
{
|
|
switch (getType(obj)) {
|
|
case String: return newStringLen(_get(obj, String,value), _get(obj, String,length));
|
|
case Primitive: {
|
|
oop clone = make(Primitive);
|
|
_set(clone, Primitive,name, _get(obj, Primitive,name ));
|
|
_set(clone, Primitive,function, _get(obj, Primitive,function));
|
|
_set(clone, Primitive,cookie, _get(obj, Primitive,cookie ));
|
|
_set(clone, Primitive,index, _get(obj, Primitive,index ));
|
|
return clone;
|
|
}
|
|
case Object: {
|
|
oop clone = new(_getDelegate(obj));
|
|
oop *elts = _get(obj, Object,indexed);
|
|
int size = _get(obj, Object,isize);
|
|
for (int i = 0; i < size; ++i) Object_push(clone, elts[i]);
|
|
struct property *kvs = _get(obj, Object,properties);
|
|
size = _get(obj, Object,psize);
|
|
for (int i = 0; i < size; ++i) {
|
|
oop key = kvs[i].key;
|
|
if (prop_delegate == key) continue;
|
|
Object_put(clone, key, kvs[i].val);
|
|
}
|
|
return clone;
|
|
}
|
|
default: break;
|
|
}
|
|
return obj;
|
|
}
|
|
|
|
|
|
oop sorted(oop obj, char *who)
|
|
{
|
|
switch (getType(obj)) {
|
|
case String: return sortString(clone(obj));
|
|
case Object: return sortObject(clone(obj), who);
|
|
default: break;
|
|
}
|
|
typeError("sort", "unsortable type", obj);
|
|
return 0;
|
|
}
|
|
|
|
oop reverseString(oop obj, char *who)
|
|
{ assert(is(String, obj));
|
|
char *elts = _get(obj, String,value);
|
|
int size = _get(obj, String,length), middle = size / 2;
|
|
int left = 0, right = size;
|
|
while (left <= middle) {
|
|
int tmp = elts[left];
|
|
elts[left++] = elts[--right];
|
|
elts[right] = tmp;
|
|
}
|
|
return obj;
|
|
}
|
|
|
|
oop reverseObject(oop obj, char *who)
|
|
{ assert(is(Object, obj));
|
|
oop *elts = _get(obj, Object,indexed);
|
|
int size = _get(obj, Object,isize), middle = size / 2;
|
|
int left = 0, right = size;
|
|
while (left <= middle) {
|
|
oop tmp = elts[left];
|
|
elts[left++] = elts[--right];
|
|
elts[right] = tmp;
|
|
}
|
|
return obj;
|
|
}
|
|
|
|
oop reversed(oop obj, char *who)
|
|
{
|
|
switch (getType(obj)) {
|
|
case String: return reverseString(clone(obj), who);
|
|
case Object: return reverseObject(clone(obj), who);
|
|
default: break;
|
|
}
|
|
typeError("reverse", "unreversible type", obj);
|
|
return 0;
|
|
}
|
|
|
|
oop apply(oop func, oop self, oop args, oop env, oop owner);
|
|
|
|
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)) printOn(str, _get(obj, Primitive,name), 0);
|
|
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>");
|
|
codeOn(str, _get(obj, Closure,function), indent);
|
|
break;
|
|
}
|
|
#endif
|
|
case Object: {
|
|
oop owner = nil;
|
|
oop evaluator = Object_getOwner(obj, prop_codeon, &owner);
|
|
oop args = new(pObject);
|
|
Object_push(args, str);
|
|
apply(evaluator, obj, args, nil, owner);
|
|
break;
|
|
}
|
|
default:
|
|
assert(!"this cannot happen");
|
|
}
|
|
return str;
|
|
}
|
|
|
|
void indentOn(oop buf, int indent)
|
|
{
|
|
if (indent < 1) return;
|
|
String_append(buf, '\n');
|
|
for (int i = indent; i--;) String_appendAll(buf, " | ");
|
|
String_appendAll(buf, " ");
|
|
}
|
|
|
|
void printObjectNameOn(oop buf, oop obj, int indent)
|
|
{
|
|
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, 0);
|
|
else String_appendAll(buf, "?");
|
|
for (int i = level; i--;) String_append(buf, '>');
|
|
}
|
|
|
|
enum {
|
|
NO_DELEGATE = -1,
|
|
NO_SPECIALS = -2,
|
|
};
|
|
|
|
int printObjectPropertiesOn(oop buf, oop obj, int indent)
|
|
{
|
|
oop names = sortObject(keys(obj, indent > 0), "print");
|
|
int nkeys = _get(names, Object,isize);
|
|
oop *elts = _get(names, Object,indexed);
|
|
int i = 0;
|
|
for (i = 0; i < nkeys; ++i) {
|
|
if (i && indent < 1) String_appendAll(buf, ", ");
|
|
oop key = elts[i];
|
|
if (prop_delegate == key) continue;
|
|
indentOn(buf, indent);
|
|
printOn(buf, key, 0);
|
|
String_appendAll(buf, ": ");
|
|
printOn(buf, Object_getLocal(obj, key), indent + (indent >= 0));
|
|
}
|
|
return i;
|
|
}
|
|
|
|
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: {
|
|
char *str = _get(obj, String,value);
|
|
int len = _get(obj, String,length);
|
|
if (indent && indent != 1) {
|
|
String_append(buf, '"');
|
|
String_appendString(buf, String_escaped(obj));
|
|
String_append(buf, '"');
|
|
return buf;
|
|
}
|
|
String_format(buf, "%.*s", len, str);
|
|
break;
|
|
}
|
|
case Symbol:
|
|
if (indent < 0) String_append(buf, '#');
|
|
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), 0);
|
|
else String_format(buf, "%p", _get(obj, Primitive,function));
|
|
String_append(buf, '>');
|
|
break;
|
|
}
|
|
#if PRIMCLOSURE
|
|
case Lambda: {
|
|
String_appendAll(buf, "<<Lambda>>");
|
|
if (indent < 1) break;
|
|
|
|
indentOn(buf, indent);
|
|
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 < 1) 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;
|
|
}
|
|
#endif
|
|
case Object: {
|
|
printObjectNameOn(buf, obj, indent);
|
|
if (!indent) break;
|
|
for (;;) {
|
|
printObjectPropertiesOn(buf, obj, indent);
|
|
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 = (unsigned char)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, "\\%03o", c);
|
|
else String_append(buf, c);
|
|
break;
|
|
}
|
|
}
|
|
String_append(buf, '"');
|
|
break;
|
|
}
|
|
case Object: {
|
|
String_appendAll(buf, "[");
|
|
oop *elts = _get(obj, Object,indexed);
|
|
int size = _get(obj, Object,isize);
|
|
int i = 0;
|
|
while (i < size) {
|
|
if (i) String_appendAll(buf, ", ");
|
|
codeOn(buf, elts[i], indent);
|
|
++i;
|
|
}
|
|
oop names = sortObject(keys(obj, indent > 0), "print");
|
|
size = _get(names, Object,isize);
|
|
elts = _get(names, Object,indexed);
|
|
for (int j = 0; j < size; ++j) {
|
|
oop key = elts[j];
|
|
oop val = Object_getLocal(obj, key);
|
|
if (key == prop_delegate && val == pObject) continue;
|
|
if (i++) String_appendAll(buf, ", ");
|
|
codeOn(buf, key, indent);
|
|
String_appendAll(buf, ": ");
|
|
codeOn(buf, val, indent);
|
|
}
|
|
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 vwarning(char *fmt, va_list ap)
|
|
{
|
|
fflush(stdout);
|
|
fprintf(stderr, "\n%s:%d: ", filename, lineno);
|
|
vfprintf(stderr, fmt, ap);
|
|
fprintf(stderr, "\n");
|
|
}
|
|
|
|
void warning(char *fmt, ...)
|
|
{
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vwarning(fmt, ap);
|
|
va_end(ap);
|
|
}
|
|
|
|
void fatal(char *fmt, ...)
|
|
{
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vwarning(fmt, ap);
|
|
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);
|
|
}
|
|
|
|
|
|
#if EXCEPTIONS
|
|
|
|
void genericError(char *who, char *message, char *kind, ...)
|
|
{ assert(kind);
|
|
oop err = new(pObject);
|
|
if (who) Object_put(err, prop_function, newString(who));
|
|
if (message) Object_put(err, prop_message, newString(message));
|
|
Object_put(err, prop_kind, newString(kind));
|
|
va_list ap;
|
|
va_start(ap, kind);
|
|
oop sym = 0;
|
|
while ((sym = va_arg(ap, oop))) { assert(is(Symbol, sym));
|
|
oop arg = va_arg(ap, oop); assert(arg);
|
|
Object_put(err, sym, arg);
|
|
}
|
|
va_end(ap);
|
|
if (is(Object, trace)) {
|
|
int size = _get(trace, Object,isize);
|
|
oop *elts = _get(trace, Object,indexed);
|
|
for (int i = 0; i < size; ++i) Object_push(err, elts[i]);
|
|
}
|
|
nlrReturn(err, NLR_RAISE);
|
|
}
|
|
|
|
#endif
|
|
|
|
|
|
#include <signal.h>
|
|
|
|
void sigint(int sig)
|
|
{
|
|
keyboardInterrupt();
|
|
}
|
|
|
|
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); \
|
|
}
|
|
|
|
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);
|
|
}
|
|
|
|
extern inline oop mkptr(void *address)
|
|
{
|
|
// top 7 bits of virtual addresses are guaranteed to be the same,
|
|
// at least until Apple decides to break that and call it a "feature"
|
|
intptr_t p = (intptr_t)address;
|
|
oop o = newInteger(p); assert(p == _integerValue(o));
|
|
return o;
|
|
}
|
|
|
|
oop newRefLocal(oop name)
|
|
{
|
|
oop o = new(pRefLocal);
|
|
Object_put(o, sym_name, name);
|
|
return o;
|
|
}
|
|
|
|
oop RefLocal_eval(oop exp, oop env)
|
|
{
|
|
if (!is(Object, env)) valueError("local", "not in a local scope", exp);
|
|
oop sym = Object_get(exp, sym_name);
|
|
oop *ref = Object_refLocal(env, sym);
|
|
if (!ref) undefinedError(sym);
|
|
return mkptr(ref);
|
|
}
|
|
|
|
void RefLocal_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "local ");
|
|
printOn(str, Object_get(exp, sym_name), 0);
|
|
}
|
|
|
|
oop newGetLocal(oop name)
|
|
{
|
|
oop o = new(pGetLocal);
|
|
Object_put(o, sym_name, name);
|
|
return o;
|
|
}
|
|
|
|
oop GetLocal_eval(oop exp, oop env)
|
|
{
|
|
if (!is(Object, env)) valueError("local", "not in a local scope", exp);
|
|
oop sym = Object_get(exp, sym_name);
|
|
oop *ref = Object_refLocal(env, sym);
|
|
if (!ref) undefinedError(sym);
|
|
return *ref;
|
|
}
|
|
|
|
void GetLocal_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "local ");
|
|
printOn(str, Object_get(exp, sym_name), 0);
|
|
}
|
|
|
|
oop newSetLocal(oop name, oop value)
|
|
{
|
|
oop o = new(pSetLocal);
|
|
Object_put(o, sym_name, name);
|
|
Object_put(o, sym_value, value);
|
|
return o;
|
|
}
|
|
|
|
oop SetLocal_eval(oop exp, oop env)
|
|
{
|
|
if (!is(Object, env)) valueError("local", "not in a local scope", exp);
|
|
oop sym = Object_get(exp, sym_name );
|
|
oop val = eval(Object_get(exp, sym_value), env);
|
|
return Object_put(env, sym, val);
|
|
}
|
|
|
|
void SetLocal_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "local ");
|
|
printOn(str, Object_get(exp, sym_name), 0);
|
|
String_appendAll(str, " = ");
|
|
codeOn(str, Object_get(exp, sym_value), 0);
|
|
}
|
|
|
|
oop newRefGlobal(oop name)
|
|
{
|
|
oop o = new(pRefGlobal);
|
|
Object_put(o, sym_name, name);
|
|
return o;
|
|
}
|
|
|
|
oop RefGlobal_eval(oop exp, oop env)
|
|
{
|
|
oop sym = Object_get(exp, sym_name);
|
|
return mkptr(&_get(sym, Symbol,value));
|
|
}
|
|
|
|
void RefGlobal_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "global ");
|
|
printOn(str, Object_get(exp, sym_name), 0);
|
|
}
|
|
|
|
oop newGetGlobal(oop name)
|
|
{
|
|
oop o = new(pGetGlobal);
|
|
Object_put(o, sym_name, name);
|
|
return o;
|
|
}
|
|
|
|
oop GetGlobal_eval(oop exp, oop env)
|
|
{
|
|
oop sym = Object_get(exp, sym_name);
|
|
oop val = _get(sym, Symbol,value);
|
|
if (UNDEFINED == val) undefinedError(sym);
|
|
return val;
|
|
}
|
|
|
|
void GetGlobal_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "global ");
|
|
printOn(str, Object_get(exp, sym_name), 0);
|
|
}
|
|
|
|
oop newSetGlobal(oop name, oop value)
|
|
{
|
|
oop o = new(pSetGlobal);
|
|
Object_put(o, sym_name, name);
|
|
Object_put(o, sym_value, value);
|
|
return o;
|
|
}
|
|
|
|
oop SetGlobal_eval(oop exp, oop env)
|
|
{
|
|
oop sym = Object_get(exp, sym_name ) ;
|
|
oop val = eval(Object_get(exp, sym_value), env);
|
|
return _set(sym, Symbol,value, val);
|
|
}
|
|
|
|
void SetGlobal_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "global ");
|
|
printOn(str, Object_get(exp, sym_name), 0);
|
|
String_appendAll(str, " = ");
|
|
codeOn(str, Object_get(exp, sym_value), 0);
|
|
}
|
|
|
|
oop newRefVar(oop name)
|
|
{
|
|
oop o = new(pRefVar);
|
|
Object_put(o, sym_name, name);
|
|
return o;
|
|
}
|
|
|
|
oop RefVar_eval(oop exp, oop env)
|
|
{
|
|
return mkptr(refvar(env, Object_get(exp, sym_name)));
|
|
}
|
|
|
|
void RefVar_codeOn(oop exp, oop str, oop env) { printOn(str, Object_get(exp, sym_name), 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 value)
|
|
{
|
|
oop o = new(pSetVar);
|
|
Object_put(o, sym_name, name);
|
|
Object_put(o, sym_value, value);
|
|
return o;
|
|
}
|
|
|
|
oop SetVar_eval(oop exp, oop env)
|
|
{
|
|
oop key = Object_get(exp, sym_name ) ;
|
|
oop val = eval(Object_get(exp, sym_value), 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_value), 0);
|
|
}
|
|
|
|
oop newRefProp(oop object, oop key)
|
|
{
|
|
oop o = new(pRefProp);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_key , key );
|
|
return o;
|
|
}
|
|
|
|
oop RefProp_eval(oop exp, oop env)
|
|
{
|
|
oop obj = eval(Object_get(exp, sym_object), env);
|
|
oop key = Object_get(exp, sym_key ) ;
|
|
return mkptr(Object_ref(obj, key));
|
|
}
|
|
|
|
void RefProp_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 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);
|
|
}
|
|
|
|
void oob(oop obj, int index)
|
|
{
|
|
rangeError("[]", "index out of bounds", obj, index);
|
|
}
|
|
|
|
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 newRefArray(oop object, oop index)
|
|
{
|
|
oop o = new(pRefArray);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_index , index );
|
|
return o;
|
|
}
|
|
|
|
oop RefArray_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: goto error;
|
|
case Symbol: goto error;
|
|
case Object: return mkptr(Object_aref(obj, index));
|
|
default: goto error;
|
|
}
|
|
}
|
|
if (is(Object, obj)) {
|
|
oop *ref = Object_refLocal(obj, ind);
|
|
if (ref) return mkptr(ref);
|
|
}
|
|
error:
|
|
typeError("[]", "not an object", obj);
|
|
return 0;
|
|
}
|
|
|
|
void RefArray_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 newGetArray(oop object, oop index)
|
|
{
|
|
oop o = new(pGetArray);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_index , index );
|
|
return o;
|
|
}
|
|
|
|
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(*(unsigned char *)String_aref(obj, index));
|
|
case Symbol: return newInteger(*(unsigned char *)Symbol_aref(obj, index));
|
|
case Object: return *Object_aref(obj, index);
|
|
default: typeError("[]", "non-indexable object", obj);
|
|
}
|
|
}
|
|
if (!is(Object, obj)) typeError("[]", "non-associative object", obj);
|
|
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: typeError("[]=", "non-indexable object", obj);
|
|
}
|
|
return val;
|
|
}
|
|
if (!is(Object, obj)) typeError("[]=", "non-associative object", obj);
|
|
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 newGetSlice(oop object, oop start, oop stop)
|
|
{
|
|
oop o = new(pGetSlice);
|
|
Object_put(o, sym_object, object);
|
|
Object_put(o, sym_start, start );
|
|
Object_put(o, sym_stop, stop );
|
|
return o;
|
|
}
|
|
|
|
oop GetSlice_eval(oop exp, oop env)
|
|
{
|
|
oop obj = eval(Object_get(exp, sym_object), env);
|
|
oop start = eval(Object_get(exp, sym_start ), env);
|
|
oop stop = eval(Object_get(exp, sym_stop ), env);
|
|
switch (getType(obj)) {
|
|
case String: return String_slice(obj, start, stop);
|
|
case Symbol: return Symbol_slice(obj, start, stop);
|
|
case Object: return Object_slice(obj, start, stop);
|
|
default: typeError("[:]", "non-indexable object", obj);
|
|
}
|
|
return nil;
|
|
}
|
|
|
|
void GetSlice_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
codeOn(str, Object_get(exp, sym_object), 0);
|
|
String_appendAll(str, "[");
|
|
codeOn(str, Object_get(exp, sym_start ), 0);
|
|
String_appendAll(str, ":");
|
|
codeOn(str, Object_get(exp, sym_stop ), 0);
|
|
String_appendAll(str, "]");
|
|
}
|
|
|
|
oop newCall(oop function, oop arguments)
|
|
{
|
|
oop o = new(pCall);
|
|
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, nil);
|
|
}
|
|
return newCall(function, arguments);
|
|
}
|
|
|
|
int isFixed(oop func)
|
|
{
|
|
# if PRIMCLOSURE
|
|
return is(Closure, func) && nil != _get(func, Closure,fixed);
|
|
# else
|
|
return nil != Object_getLocal(func, sym_fixed);
|
|
# 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, nil);
|
|
}
|
|
|
|
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 newSuper(oop method, oop arguments)
|
|
{
|
|
oop o = new(pSuper);
|
|
Object_put(o, sym_method , method );
|
|
Object_put(o, sym_arguments, arguments);
|
|
return o;
|
|
}
|
|
|
|
oop Super_eval(oop exp, oop env)
|
|
{
|
|
oop meth = Object_get(exp, sym_method);
|
|
oop args = Object_get(exp, sym_arguments);
|
|
oop self = Object_get(env, sym_self);
|
|
oop owner = Object_get(env, prop_owner);
|
|
oop iargs = evargs(args, env);
|
|
oop ifunc = Object_getOwner(_getDelegate(owner), meth, &owner); // fails if property not defined
|
|
return apply(ifunc, self, iargs, env, owner);
|
|
}
|
|
|
|
void Super_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "super.");
|
|
printOn(str, Object_get(exp, sym_method ), 0);
|
|
codeArgumentsOn(str, Object_get(exp, sym_arguments), "(", ")");
|
|
}
|
|
|
|
oop newInvoke(oop self, oop method, oop arguments)
|
|
{
|
|
oop o = new(pInvoke);
|
|
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 owner = nil;
|
|
oop ifunc = Object_getOwner(self, meth, &owner); // fails if property not defined
|
|
return apply(ifunc, self, iargs, env, owner);
|
|
}
|
|
|
|
void Invoke_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
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), "(", ")");
|
|
}
|
|
|
|
oop newContinue(void)
|
|
{
|
|
return new(pContinue);
|
|
}
|
|
|
|
oop Continue_eval(oop exp, oop env)
|
|
{
|
|
# if NONLOCAL
|
|
nlrReturn(nil, NLR_CONTINUE);
|
|
assert(!"this cannot happen");
|
|
# endif
|
|
return nil;
|
|
}
|
|
|
|
void Continue_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "continue");
|
|
}
|
|
|
|
oop newBreak(oop value)
|
|
{
|
|
oop o = new(pBreak);
|
|
Object_put(o, sym_value, value);
|
|
return o;
|
|
}
|
|
|
|
oop Break_eval(oop exp, oop env)
|
|
{
|
|
oop value = eval(Object_get(exp, sym_value), env);
|
|
# if NONLOCAL
|
|
nlrReturn(value, NLR_BREAK);
|
|
assert(!"this cannot happen");
|
|
# endif
|
|
return value;
|
|
}
|
|
|
|
void Break_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "break");
|
|
oop value = Object_get(exp, sym_value);
|
|
if (nil != value) {
|
|
String_appendAll(str, " ");
|
|
codeOn(str, value, 0);
|
|
}
|
|
}
|
|
|
|
oop newReturn(oop value)
|
|
{
|
|
oop o = new(pReturn);
|
|
Object_put(o, sym_value, value);
|
|
return o;
|
|
}
|
|
|
|
oop Return_eval(oop exp, oop env)
|
|
{
|
|
oop value = eval(Object_get(exp, sym_value), env);
|
|
# if NONLOCAL
|
|
nlrReturn(value, NLR_RETURN);
|
|
assert(!"this cannot happen");
|
|
# endif
|
|
return value;
|
|
}
|
|
|
|
void Return_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "return ");
|
|
codeOn(str, Object_get(exp, sym_value), 0);
|
|
}
|
|
|
|
oop newTryCatch(oop statement, oop identifier, oop handler)
|
|
{
|
|
oop o = new(pTryCatch);
|
|
Object_put(o, sym_statement, statement);
|
|
Object_put(o, sym_identifier, identifier);
|
|
Object_put(o, sym_handler, handler);
|
|
return o;
|
|
}
|
|
|
|
oop TryCatch_eval(oop exp, oop env)
|
|
{
|
|
oop statement = Object_get(exp, sym_statement);
|
|
# if NONLOCAL
|
|
switch (nlrPush()) {
|
|
case NLR_CONTINUE: nlrReturn(nlrPop(), NLR_CONTINUE);
|
|
case NLR_BREAK: nlrReturn(nlrPop(), NLR_BREAK);
|
|
case NLR_RETURN: nlrReturn(nlrPop(), NLR_RETURN);
|
|
case NLR_RAISE: {
|
|
oop exception = nlrPop();
|
|
oop env2 = new(pObject);
|
|
_setDelegate(env2, env);
|
|
Object_put(env2, Object_get(exp, sym_identifier), exception);
|
|
return eval(Object_get(exp, sym_handler), env2);
|
|
}
|
|
}
|
|
# endif
|
|
oop result = eval(Object_get(exp, sym_statement), env);
|
|
# if NONLOCAL
|
|
nlrPop();
|
|
# endif
|
|
return result;
|
|
}
|
|
|
|
void TryCatch_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "try ");
|
|
codeOn(str, Object_get(exp, sym_statement), 0);
|
|
String_appendAll(str, " catch (");
|
|
printOn(str, Object_get(exp, sym_identifier), 0);
|
|
String_appendAll(str, ") ");
|
|
codeOn(str, Object_get(exp, sym_handler), 0);
|
|
}
|
|
|
|
oop newTryEnsure(oop statement, oop handler)
|
|
{
|
|
oop o = new(pTryEnsure);
|
|
Object_put(o, sym_statement, statement);
|
|
Object_put(o, sym_handler, handler);
|
|
return o;
|
|
}
|
|
|
|
oop TryEnsure_eval(oop exp, oop env)
|
|
{
|
|
oop statement = Object_get(exp, sym_statement);
|
|
oop handler = Object_get(exp, sym_handler);
|
|
oop result = nil;
|
|
int nlreason = 0;
|
|
# if NONLOCAL
|
|
if (NLR_INIT != (nlreason = nlrPush())) {
|
|
result = nlrPop();
|
|
eval(handler, env);
|
|
nlrReturn(result, nlreason);
|
|
}
|
|
# endif
|
|
result = eval(Object_get(exp, sym_statement), env);
|
|
# if NONLOCAL
|
|
nlrPop();
|
|
# endif
|
|
eval(handler, env);
|
|
return result;
|
|
}
|
|
|
|
void TryEnsure_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "try ");
|
|
codeOn(str, Object_get(exp, sym_statement), 0);
|
|
String_appendAll(str, " catch (");
|
|
printOn(str, Object_get(exp, sym_identifier), 0);
|
|
String_appendAll(str, ") ");
|
|
codeOn(str, Object_get(exp, sym_handler), 0);
|
|
}
|
|
|
|
oop newRaise(oop value)
|
|
{
|
|
oop o = new(pRaise);
|
|
Object_put(o, sym_value, value);
|
|
return o;
|
|
}
|
|
|
|
oop Raise_eval(oop exp, oop env)
|
|
{
|
|
oop value = eval(Object_get(exp, sym_value), env);
|
|
# if NONLOCAL
|
|
nlrReturn(value, NLR_RAISE);
|
|
assert(!"this cannot happen");
|
|
# endif
|
|
return value;
|
|
}
|
|
|
|
void Raise_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
String_appendAll(str, "raise ");
|
|
codeOn(str, Object_get(exp, sym_value), 0);
|
|
}
|
|
|
|
#if !PRIMCLOSURE
|
|
|
|
oop newLambda(oop parameters, oop body, oop parent, oop name)
|
|
{
|
|
oop o = new(pLambda);
|
|
Object_put(o, sym_parameters, parameters );
|
|
Object_put(o, sym_body , body );
|
|
# if PROFILE
|
|
Object_put(o, sym_profile , nil );
|
|
# endif
|
|
Object_put(o, sym_parent , parent );
|
|
Object_put(o, sym_name , name );
|
|
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;
|
|
}
|
|
|
|
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)
|
|
{
|
|
printOn(str, Object_getLocal(exp, sym_function), 0);
|
|
}
|
|
|
|
int isClosure(oop obj)
|
|
{
|
|
return is(Object, obj) && pClosure == _getDelegate(obj);
|
|
}
|
|
|
|
#endif // !PRIMCLOSURE
|
|
|
|
#define doBinops(_) \
|
|
_(LogOr, ||) \
|
|
_(LogAnd, &&) \
|
|
_(BitOr, |) \
|
|
_(BitXor, ^) \
|
|
_(BitAnd, &) \
|
|
_(Eq, ==) _(NotEq, !=) \
|
|
_(Less, < ) _(LessEq, <=) _(Grtr, >=) _(GrtrEq, > ) \
|
|
_(Shl, <<) _(Shr, >>) \
|
|
_(Add, +) _(Sub, -) \
|
|
_(Mul, *) _(Div, /) _(Mod, %) \
|
|
_(PostAdd, ++) _(PostDec, --) \
|
|
_(PreSet, =) \
|
|
_(PreOr, |=) _(PreXor, ^=) _(PreAnd, &=) \
|
|
_(PreShl, >>=) _(PreShr, <<=) \
|
|
_(PreAdd, +=) _(PreSub, -=) \
|
|
_(PreMul, *=) _(PreDiv, /=) _(PreMod, %=)
|
|
|
|
#define defineBinop(NAME, OP) op##NAME,
|
|
enum binop {
|
|
doBinops(defineBinop)
|
|
};
|
|
#undef defineBinop
|
|
|
|
#define nameBinop(NAME, OP) #OP,
|
|
char *binopNames[] = {
|
|
doBinops(nameBinop)
|
|
};
|
|
#undef nameBinop
|
|
|
|
#if BINOPT
|
|
|
|
typedef oop (*binop_t)(oop lhs, oop rhs);
|
|
|
|
#define declBinop(NAME, OP) oop bin##NAME(oop, oop);
|
|
doBinops(declBinop)
|
|
#undef declBinop
|
|
|
|
#define implBinop(NAME, OP) bin##NAME,
|
|
binop_t binops[] = {
|
|
doBinops(implBinop)
|
|
};
|
|
#undef implBinop
|
|
|
|
#endif // BINOPT
|
|
|
|
#define newBoolean(TF) ((TF) ? sym_t : nil)
|
|
|
|
#define binop(NAME, OP) \
|
|
oop NAME(oop lhs, oop rhs) \
|
|
{ \
|
|
return newInteger(integerValue(lhs, #OP) OP integerValue(rhs, #OP)); \
|
|
}
|
|
|
|
binop(binBitOr, |);
|
|
binop(binBitXor, ^);
|
|
binop(binBitAnd, &);
|
|
|
|
#undef binop
|
|
|
|
#define binop(NAME, OP) \
|
|
oop NAME(oop lhs, oop rhs) \
|
|
{ \
|
|
return newBoolean(cmp(lhs, rhs, #OP) OP 0); \
|
|
}
|
|
|
|
binop(binEq, ==);
|
|
binop(binNotEq, !=);
|
|
binop(binLess, < );
|
|
binop(binLessEq, <=);
|
|
binop(binGrtrEq, >=);
|
|
binop(binGrtr, > );
|
|
|
|
#undef binop
|
|
|
|
oop binLogOr (oop lhs, oop rhs) { abort(); return 0; }
|
|
oop binLogAnd(oop lhs, oop rhs) { abort(); return 0; }
|
|
|
|
oop binPostAdd(oop lhs, oop rhs)
|
|
{ assert(isInteger(lhs)); // lval ref
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs)); // X++ -> X+=1
|
|
oop value = *ref;
|
|
int amount = _integerValue(rhs);
|
|
switch (getType(value)) {
|
|
case Integer: *ref = newInteger(_integerValue(value) + amount); break;
|
|
case Float: *ref = newFloat (_floatValue (value) + amount); break;
|
|
default: typeError("++", "non-numeric value", value);
|
|
}
|
|
return value;
|
|
}
|
|
|
|
oop binPostDec(oop lhs, oop rhs)
|
|
{ assert(isInteger(lhs)); // lval ref
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs)); // X-- -> X-=1
|
|
oop value = *ref;
|
|
int amount = _integerValue(rhs);
|
|
switch (getType(value)) {
|
|
case Integer: *ref = newInteger(_integerValue(value) - amount); break;
|
|
case Float: *ref = newFloat (_floatValue (value) - amount); break;
|
|
default: typeError("++", "non-numeric value", value);
|
|
}
|
|
return value;
|
|
}
|
|
|
|
oop binPreSet(oop lhs, oop rhs)
|
|
{ assert(isInteger(lhs));
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs));
|
|
return *ref = rhs;
|
|
}
|
|
|
|
#define binop(NAME, OP) \
|
|
oop NAME(oop lhs, oop rhs) \
|
|
{ assert(isInteger(lhs)); \
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs)); \
|
|
oop val = *ref; \
|
|
if (isInteger(val) && isInteger(rhs)) { \
|
|
long l = _integerValue(val), r = _integerValue(rhs); \
|
|
l OP r; \
|
|
return *ref = newInteger(l); \
|
|
} \
|
|
double l = floatValue(val, #OP); \
|
|
double r = floatValue(rhs, #OP); \
|
|
l OP r; \
|
|
return *ref = newFloat(l); \
|
|
}
|
|
|
|
binop(binPreAdd, +=);
|
|
binop(binPreSub, -=);
|
|
binop(binPreMul, *=);
|
|
|
|
#undef binop
|
|
|
|
oop binPreDiv(oop lhs, oop rhs)
|
|
{ assert(isInteger(lhs));
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs));
|
|
oop val = *ref;
|
|
if (isInteger(val) && isInteger(rhs)) {
|
|
long l = _integerValue(val), r = _integerValue(rhs);
|
|
if (!r) valueError("/=", "division by zero", rhs);
|
|
l /= r;
|
|
return *ref = newInteger(l);
|
|
}
|
|
double l = floatValue(val, "/=");
|
|
double r = floatValue(rhs, "/=");
|
|
if (!r) valueError("/=", "division by zero", rhs);
|
|
l /= r;
|
|
return *ref = newFloat(l);
|
|
}
|
|
|
|
oop binPreMod(oop lhs, oop rhs)
|
|
{ assert(isInteger(lhs));
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs));
|
|
oop val = *ref;
|
|
if (isInteger(val) && isInteger(rhs)) {
|
|
long l = _integerValue(val), r = _integerValue(rhs);
|
|
if (!r) valueError("%%=", "division by zero", rhs);
|
|
l /= r;
|
|
return *ref = newInteger(l);
|
|
}
|
|
double l = floatValue(val, "%=");
|
|
double r = floatValue(rhs, "%=");
|
|
if (!r) valueError("%%=", "division by zero", rhs);
|
|
return *ref = newFloat(fmod(l, r));
|
|
}
|
|
|
|
#define binop(NAME, OP) \
|
|
oop NAME(oop lhs, oop rhs) \
|
|
{ assert(isInteger(lhs)); \
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs); assert(isInteger(rhs)); \
|
|
oop val = *ref; \
|
|
long l = integerValue(val, #OP); \
|
|
long r = integerValue(rhs, #OP); \
|
|
l OP r; \
|
|
return *ref = newInteger(l); \
|
|
}
|
|
|
|
binop(binPreOr, |=);
|
|
binop(binPreXor, ^=);
|
|
binop(binPreAnd, &=);
|
|
binop(binPreShl, <<=);
|
|
binop(binPreShr, >>=);
|
|
|
|
#undef binop
|
|
|
|
oop binShl(oop l, oop r)
|
|
{
|
|
int tl = getType(l), tr = getType(r);
|
|
if (Integer == tl && Integer == tr)
|
|
return newInteger(_integerValue(l) << _integerValue(r));
|
|
typeError2("<<", "non-integer operand", l, r);
|
|
return 0;
|
|
}
|
|
|
|
oop binShr(oop l, oop r)
|
|
{
|
|
int tl = getType(l), tr = getType(r);
|
|
if (Integer == tl && Integer == tr)
|
|
return newInteger(_integerValue(l) >> _integerValue(r));
|
|
typeError2(">>", "non-integer operand", l, r);
|
|
return 0;
|
|
}
|
|
|
|
oop binAdd(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 ( floatValue (l, "+") + floatValue (r, "+"));
|
|
if (String == tl && String == tr) return String_concat(l, r);
|
|
typeError2("+", "illegal operand types", l, 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)); \
|
|
typeError2(#OP, "illegal operand types", l, r); \
|
|
return 0; \
|
|
}
|
|
|
|
binop(binSub, -);
|
|
|
|
#undef binop
|
|
|
|
oop binMul(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 ( floatValue (l, "*") * floatValue (r, "*"));
|
|
if (String == tl && Integer == tr) return String_repeat(l, _integerValue(r));
|
|
if (Integer == tl && String == tr) return String_repeat(r, _integerValue(l));
|
|
typeError2("*", "illegal operand types", l, r);
|
|
return 0;
|
|
}
|
|
|
|
oop binDiv(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, "/"));
|
|
typeError2("/", "illegal operand type", l, r);
|
|
return 0;
|
|
}
|
|
|
|
oop binMod(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, "%")));
|
|
typeError2("/", "illegal operand types", l, r);
|
|
return 0;
|
|
}
|
|
|
|
int isNumber(oop obj) { return isInteger(obj) || isFloat(obj); }
|
|
int isAtom(oop obj) { return nil == obj || isNumber(obj) || isString(obj) || is(Symbol, obj); }
|
|
|
|
oop newBinop(enum binop operation, oop lhs, oop rhs)
|
|
{
|
|
# if FOLDCONST
|
|
if (isAtom(lhs) && isAtom(rhs)) {
|
|
switch (operation) {
|
|
case opLogOr: return newBoolean((lhs != nil) || (rhs != nil));
|
|
case opLogAnd: return newBoolean((lhs != nil) && (rhs != nil));
|
|
case opEq: return binEq (lhs, rhs);
|
|
case opNotEq: return binNotEq(lhs, rhs);
|
|
default: break;
|
|
}
|
|
}
|
|
if (isInteger(lhs) && isInteger(rhs)) {
|
|
switch (operation) {
|
|
case opBitOr: return binBitOr (lhs, rhs);
|
|
case opBitXor: return binBitXor(lhs, rhs);
|
|
case opBitAnd: return binBitAnd(lhs, rhs);
|
|
case opShl: return binShl (lhs, rhs);
|
|
case opShr: return binShr (lhs, rhs);
|
|
default: break;
|
|
}
|
|
}
|
|
if (isNumber(lhs) && isNumber(rhs)) {
|
|
switch (operation) {
|
|
case opLess: return binLess (lhs, rhs);
|
|
case opLessEq: return binLessEq(lhs, rhs);
|
|
case opGrtr: return binGrtr (lhs, rhs);
|
|
case opGrtrEq: return binGrtrEq(lhs, rhs);
|
|
case opAdd: return binAdd (lhs, rhs);
|
|
case opSub: return binSub (lhs, rhs);
|
|
case opMul: return binMul (lhs, rhs);
|
|
case opDiv: return binDiv (lhs, rhs);
|
|
case opMod: return binMod (lhs, rhs);
|
|
default: break;
|
|
}
|
|
}
|
|
# endif
|
|
oop o = new(pBinop);
|
|
Object_put(o, sym_operation, newInteger(operation));
|
|
# if BINOPT
|
|
Object_put(o, prop_function, mkptr(binops[operation]));
|
|
# endif
|
|
Object_push(o, lhs);
|
|
Object_push(o, rhs);
|
|
return o;
|
|
}
|
|
|
|
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);
|
|
# if BINOPT
|
|
return (binop_t)_integerValue(Object_get(exp, prop_function))(lhs, rhs);
|
|
# else
|
|
switch (code) {
|
|
case opLogOr: break;
|
|
case opLogAnd: break;
|
|
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 binShl(lhs, rhs);
|
|
case opShr: return binShr(lhs, rhs);
|
|
case opAdd: return binAdd(lhs, rhs);
|
|
case opSub: return binSub(lhs, rhs);
|
|
case opMul: return binMul(lhs, rhs);
|
|
case opDiv: return binDiv(lhs, rhs);
|
|
case opMod: return binMod(lhs, rhs);
|
|
case opPostAdd:
|
|
case opPostDec: { assert(isInteger(lhs)); // ref
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs);
|
|
oop value = *ref; assert(isInteger(rhs)); // delta
|
|
int amount = _integerValue(rhs);
|
|
if (code == opPostDec) amount = -amount;
|
|
switch (getType(value)) {
|
|
case Integer: *ref = newInteger(_integerValue(value) + amount); break;
|
|
case Float: *ref = newFloat (_floatValue (value) + amount); break;
|
|
default: typeError("++", "non-numeric value", value);
|
|
}
|
|
return value;
|
|
}
|
|
case opPreSet: { assert(isInteger(lhs)); // ref
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs);
|
|
return *ref = rhs;
|
|
}
|
|
case opPreOr ... opPreMod: {
|
|
oop *ref = (oop *)(intptr_t)_integerValue(lhs);
|
|
oop val = *ref;
|
|
switch (code) {
|
|
case opPreOr ... opPreShr: {
|
|
long l = integerValue(val, binopNames[code]);
|
|
long r = integerValue(rhs, binopNames[code]);
|
|
switch (code) {
|
|
case opPreOr: l |= r; break;
|
|
case opPreXor: l ^= r; break;
|
|
case opPreAnd: l &= r; break;
|
|
case opPreShl: l <<= r; break;
|
|
case opPreShr: l >>= r; break;
|
|
default: assert(!"this cannot happen");
|
|
}
|
|
return *ref = newInteger(l);
|
|
}
|
|
case opPreAdd ... opPreMod: {
|
|
if (isInteger(val) && isInteger(rhs)) {
|
|
long l = _integerValue(val), r = _integerValue(rhs);
|
|
switch (code) {
|
|
case opPreAdd: l += r; break;
|
|
case opPreSub: l -= r; break;
|
|
case opPreMul: l *= r; break;
|
|
case opPreDiv:
|
|
if (!r) valueError("/=", "division by zero", rhs);
|
|
l /= r;
|
|
break;
|
|
case opPreMod:
|
|
if (!r) valueError("%=", "division by zero", rhs);
|
|
l %= r;
|
|
break;
|
|
default: assert(!"this cannot happen");
|
|
}
|
|
return *ref = newInteger(l);
|
|
}
|
|
double l = floatValue(val, binopNames[code]);
|
|
double r = floatValue(rhs, binopNames[code]);
|
|
switch (code) {
|
|
case opPreAdd: l += r; break;
|
|
case opPreSub: l -= r; break;
|
|
case opPreMul: l *= r; break;
|
|
case opPreDiv:
|
|
if (!r) valueError("/=", "division by zero", rhs);
|
|
l /= r;
|
|
break;
|
|
case opPreMod:
|
|
if (!r) valueError("%=", "division by zero", rhs);
|
|
l = fmod(l, r);
|
|
break;
|
|
default: assert(!"this cannot happen");
|
|
}
|
|
return *ref = newFloat(l);
|
|
}
|
|
default: assert(!"this cannot happen");
|
|
}
|
|
}
|
|
}
|
|
fatal("illegal binary operation %d", code);
|
|
return 0;
|
|
# endif
|
|
}
|
|
|
|
void Binop_codeOn(oop exp, oop str, oop env)
|
|
{
|
|
if (_getDelegate(exp) == pBinop) { 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);
|
|
}
|
|
else {
|
|
printOn(str, exp, 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 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;
|
|
}
|
|
typeError("-", "non-numeric operand", n);
|
|
return 0;
|
|
}
|
|
|
|
oop com(oop n)
|
|
{
|
|
int tn = getType(n);
|
|
switch (tn) {
|
|
case Integer: return newInteger(~_integerValue(n));
|
|
default: break;
|
|
}
|
|
typeError("~", "non-numeric operand", n);
|
|
return 0;
|
|
}
|
|
|
|
oop newUnyop(int operation, oop value)
|
|
{
|
|
# if FOLDCONST
|
|
if (operation == opNot && isAtom (value)) return newBoolean(nil == value);
|
|
if (operation == opNeg && isNumber (value)) return neg(value);
|
|
if (operation == opCom && isInteger(value)) return com(value);
|
|
# endif
|
|
oop o = new(pUnyop);
|
|
Object_put(o, sym_operation, newInteger(operation));
|
|
Object_push(o, value);
|
|
return o;
|
|
}
|
|
|
|
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 ) syntaxError("@ 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)
|
|
{
|
|
# if FOLDCONST
|
|
if (isAtom(condition)) return nil == condition ? alternate : consequent;
|
|
# endif
|
|
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);
|
|
}
|
|
}
|
|
|
|
#define _PASTE(A, B) A##B
|
|
#define PASTE(A, B) _PASTE(A,B)
|
|
|
|
#if NONLOCAL
|
|
|
|
# define LOOP() \
|
|
PASTE(continue,__LINE__): \
|
|
switch (nlrPush()) { \
|
|
case NLR_CONTINUE: nlrPop(); goto PASTE(continue, __LINE__); \
|
|
case NLR_BREAK: return nlrPop(); \
|
|
case NLR_RETURN: nlrReturn(nlrPop(), NLR_RETURN); \
|
|
case NLR_RAISE: nlrReturn(nlrPop(), NLR_RAISE ); \
|
|
}
|
|
|
|
# define DONE() nlrPop()
|
|
#else
|
|
# define LOOP()
|
|
# define DONE()
|
|
#endif
|
|
|
|
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;
|
|
LOOP();
|
|
while (nil != eval(condition, env)) result = eval(body, env);
|
|
DONE();
|
|
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);
|
|
int n = 0;
|
|
LOOP();
|
|
if (n) goto doContinue;
|
|
n = 1;
|
|
for (;;) {
|
|
if (nil == eval(condition, env2)) break;
|
|
result = eval(body, env2);
|
|
doContinue:
|
|
eval(update, env2);
|
|
}
|
|
DONE();
|
|
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 i = -1, limit = _integerValue(vals);
|
|
LOOP();
|
|
while (++i < limit) {
|
|
Object_put(env2, identifier, newInteger(i));
|
|
result = eval(body, env2);
|
|
}
|
|
DONE();
|
|
return result;
|
|
}
|
|
if (is(String, vals)) {
|
|
int len = _get(vals, String,length);
|
|
char *val = _get(vals, String,value);
|
|
int i = -1;
|
|
LOOP();
|
|
while (++i < len) {
|
|
Object_put(env2, identifier, newInteger(val[i]));
|
|
result = eval(body, env2);
|
|
}
|
|
DONE();
|
|
return result;
|
|
}
|
|
if (!is(Object, vals)) typeError("for", "non-iterable value", vals);
|
|
oop *indexed = _get(vals, Object,indexed);
|
|
int size = _get(vals, Object,isize);
|
|
int i = -1;
|
|
LOOP();
|
|
while (++i < size) {
|
|
Object_put(env2, identifier, indexed[i]);
|
|
result = eval(body, env2);
|
|
}
|
|
DONE();
|
|
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 = eval(Object_get(exp, sym_first), env);
|
|
oop last = eval(Object_get(exp, sym_last ), env);
|
|
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;
|
|
start -= step;
|
|
LOOP();
|
|
for (;;) {
|
|
start += step;
|
|
Object_put(env2, identifier, newInteger(start));
|
|
result = eval(body, env2);
|
|
if (start == stop) break;
|
|
}
|
|
DONE();
|
|
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);
|
|
}
|
|
|
|
#undef LOOP
|
|
#undef DONE
|
|
|
|
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);
|
|
// if (is(String, object)) return newStringLen(_get(object, String,value), _get(object, String,length));
|
|
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;
|
|
}
|
|
|
|
#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);
|
|
codeOn(str, object, 0);
|
|
# if 0
|
|
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, "]");
|
|
# endif
|
|
}
|
|
|
|
oop lvalue(oop rval)
|
|
{
|
|
if (!is(Object,rval)) valueError("=", "non-assignable value", rval);
|
|
oop kind = _getDelegate(rval);
|
|
if (kind == pGetVar ) kind = pRefVar;
|
|
else if (kind == pGetProp ) kind = pRefProp;
|
|
else if (kind == pGetArray ) kind = pRefArray;
|
|
else if (kind == pGetLocal ) kind = pRefLocal;
|
|
else if (kind == pGetGlobal) kind = pRefGlobal;
|
|
else valueError("=", "non-assignable value", rval);
|
|
_setDelegate(rval, kind);
|
|
return rval;
|
|
}
|
|
|
|
oop assign(oop rval, oop value)
|
|
{
|
|
if (!is(Object,rval)) valueError("=", "non-assignable value", rval);
|
|
oop kind = _getDelegate(rval);
|
|
if (kind == pGetVar ) kind = pSetVar;
|
|
else if (kind == pGetProp ) kind = pSetProp;
|
|
else if (kind == pGetArray) kind = pSetArray;
|
|
else valueError("=", "non-assignable value", rval);
|
|
_setDelegate(rval, kind);
|
|
Object_put(rval, sym_value, value);
|
|
return rval;
|
|
}
|
|
|
|
void expected(char *what, char *where)
|
|
{
|
|
fatal("syntax error: %s expected near: %s", what, where);
|
|
}
|
|
|
|
%}
|
|
|
|
start = - ( s:stmt { yysval = s }
|
|
| !. { yysval = 0 }
|
|
| < (!EOL .)* > { syntaxError(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) }
|
|
)
|
|
| CONT EOS { $$ = newContinue() }
|
|
| BREAK e:expr EOS { $$ = newBreak(e) }
|
|
| BREAK EOS { $$ = newBreak(nil) }
|
|
| RETURN e:expr EOS { $$ = newReturn(e) }
|
|
| RETURN EOS { $$ = newReturn(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) }
|
|
| TRY t:stmt
|
|
( CATCH LPAREN i:id RPAREN c:stmt { $$ = newTryCatch(t, i, c) }
|
|
| ENSURE e:stmt { $$ = newTryEnsure(t, e) }
|
|
)
|
|
| RAISE e:expr EOS { $$ = newRaise(e) }
|
|
| LOCAL i:id p:params b:block { $$ = newSetLocal (i, newLambda(p, b, nil, i)) }
|
|
| GLOBAL i:id p:params b:block { $$ = newSetGlobal(i, newLambda(p, b, nil, i)) }
|
|
| i:id p:params b:block { $$ = newSetVar (i, newLambda(p, b, nil, i)) }
|
|
| v:proto DOT i:id p:params b:block { $$ = newSetProp(v, i, newLambda(p, b, v, i)) }
|
|
| b:block { $$ = newBlock(b) }
|
|
| e:expr EOS { $$ = e }
|
|
|
|
proto = v:var ( DOT j:id !LPAREN { v = newGetProp(v, j) }
|
|
)* { $$ = v }
|
|
|
|
EOS = SEMI+ | &RBRACE | &ELSE | &CATCH
|
|
|
|
expr = LOCAL i:id ASSIGN e:expr { $$ = newSetLocal (i, e) }
|
|
| GLOBAL i:id ASSIGN e:expr { $$ = newSetGlobal(i, e) }
|
|
| i:id ASSIGN e:expr { $$ = newSetVar (i, e) }
|
|
| l:logor ( ASSIGN r:expr { l = assign(l, r) }
|
|
| PLUSEQ r:expr { l = newBinop(opPreAdd, lvalue(l), r) }
|
|
| MINUSEQ r:expr { l = newBinop(opPreSub, lvalue(l), r) }
|
|
| STAREQ r:expr { l = newBinop(opPreMul, lvalue(l), r) }
|
|
| SLASHEQ r:expr { l = newBinop(opPreDiv, lvalue(l), r) }
|
|
| PCENTEQ r:expr { l = newBinop(opPreMod, lvalue(l), r) }
|
|
| SHLEQ r:expr { l = newBinop(opPreShl, lvalue(l), r) }
|
|
| SHREQ r:expr { l = newBinop(opPreShr, lvalue(l), r) }
|
|
| ANDEQ r:expr { l = newBinop(opPreAnd, lvalue(l), r) }
|
|
| XOREQ r:expr { l = newBinop(opPreXor, lvalue(l), r) }
|
|
| OREQ r:expr { l = newBinop(opPreOr, lvalue(l), r) }
|
|
)? { $$ = l }
|
|
|
|
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 = PPLUS p:prefix { $$ = newBinop(opPreAdd, lvalue(p), newInteger(1)) }
|
|
| MMINUS p:prefix { $$ = newBinop(opPreSub, lvalue(p), newInteger(1)) }
|
|
| 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 = SUPER DOT i:id a:args { $$ = newSuper(i, a) }
|
|
| p:primary
|
|
( LBRAK
|
|
( COLON ( RBRAK { p = newGetSlice(p, nil, nil) }
|
|
| e:xexpr RBRAK { p = newGetSlice(p, nil, e) }
|
|
)
|
|
| s:xexpr ( COLON ( RBRAK { p = newGetSlice(p, s, nil) }
|
|
| e:xexpr RBRAK { p = newGetSlice(p, s, e) }
|
|
)
|
|
| RBRAK { p = newGetArray(p, s) }
|
|
)
|
|
)
|
|
| DOT i:id ( a:args !LBRACE { p = newInvoke(p, i, a) }
|
|
| { p = newGetProp(p, i) }
|
|
)
|
|
| a:args !LBRACE { p = newApply(p, a) }
|
|
)*
|
|
( PPLUS { p = newBinop(opPostAdd, lvalue(p), newInteger( 1)) }
|
|
| MMINUS { p = newBinop(opPostAdd, lvalue(p), newInteger(-1)) }
|
|
)? { $$ = p }
|
|
|
|
args = LPAREN a:mkobj
|
|
( RPAREN
|
|
| ( k:id COLON e:xexpr { Object_put(a, k, e) }
|
|
| e:xexpr { Object_push(a, e) }
|
|
)
|
|
( COMMA ( k:id COLON e:xexpr { Object_put(a, k, e) }
|
|
| e:xexpr { Object_push(a, e) }
|
|
) )* RPAREN ) { $$ = a }
|
|
|
|
params = LPAREN p:mkobj
|
|
( RPAREN
|
|
| i:id ( COLON e:expr { Object_put(p, i, e) }
|
|
| { Object_push(p, i) }
|
|
)
|
|
( COMMA i:id ( COLON e:expr { Object_put(p, i, e) }
|
|
| { Object_push(p, i) }
|
|
)
|
|
)* RPAREN ) { $$ = p }
|
|
|
|
mkobj = { $$ = new(pObject) }
|
|
|
|
primary = nil | number | string | symbol | var | lambda | subexpr | literal # | regex
|
|
|
|
lambda = p:params b:block { $$ = newLambda(p, b, nil, nil) }
|
|
|
|
subexpr = LPAREN e:expr RPAREN { $$ = e }
|
|
| b:block { $$ = newBlock(b) }
|
|
|
|
literal = LBRAK o:mkobj
|
|
( RBRAK
|
|
| ( ( 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 }
|
|
| error @{ expected("statement or \x7D", yytext) }
|
|
)
|
|
|
|
nil = NIL { $$ = nil }
|
|
|
|
number = "-" n:unsign { $$ = neg(n) }
|
|
| "+" n:number { $$ = n }
|
|
| n:unsign { $$ = n }
|
|
|
|
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)) }
|
|
| "'" < char > "'" - { $$ = newInteger(_get(newStringUnescaped(yytext), String,value)[0]) }
|
|
|
|
string = '"' < ( !'"' char )* > '"' - { $$ = newStringUnescaped(yytext) }
|
|
|
|
char = "\\" ( ["'\\abfnrtv]
|
|
| [xX] HIGIT*
|
|
| [0-7][0-7]?[0-7]?
|
|
)
|
|
| .
|
|
|
|
symbol = HASH i:id { $$ = i }
|
|
|
|
var = LOCAL i:id { $$ = newGetLocal (i) }
|
|
| GLOBAL i:id { $$ = newGetGlobal(i) }
|
|
| i:id { $$ = newGetVar (i) }
|
|
|
|
id = < LETTER ALNUM* > - { $$ = intern(yytext) }
|
|
|
|
# regex = SLASH a:alts SLASH { $$ = a }
|
|
|
|
# alts = s:seq ( OR t:seq { s = Alt_append(t) }
|
|
# )* { $$ = s }
|
|
|
|
# seq = p:pre ( q:pre { s = Seq_append(t) }
|
|
# )* { $$ = s }
|
|
|
|
# elt = action | pre
|
|
|
|
# action = b:block { $$ = newAction(b) }
|
|
|
|
# pre = PLING p:pre { $$ = newNot(p) }
|
|
# | AND p:pre { $$ = newAnd(p) }
|
|
# | post
|
|
|
|
# post = a:atom ( STAR { a = newMany(a) }
|
|
# | PLUS { a = newMore(a) }
|
|
# | QUERY { a = newMore(a) }
|
|
# )? { $$ = a }
|
|
|
|
# atom = DOT { $$ = newDot() }
|
|
# | "[" ( !"]" "\\"? . )* "]" - { $$ = newClass(yytext) }
|
|
# | '"' xxxxxx
|
|
|
|
# class = LBRAK
|
|
|
|
BIGIT = [0-1]
|
|
OIGIT = [0-7]
|
|
DIGIT = [0-9]
|
|
HIGIT = [0-9A-Fa-f]
|
|
LETTER = [A-Za-z_$?]
|
|
ALNUM = LETTER | DIGIT
|
|
SIGN = [-+]
|
|
EXP = [eE] SIGN DIGIT+
|
|
|
|
- = SPACE*
|
|
|
|
SPACE = [ \t] | EOL | SLC | MLC
|
|
EOL = [\n\r] { ++lineno }
|
|
SLC = "//" (!EOL .)*
|
|
MLC = "/*" ( MLC | !"*/" (EOL | .))* "*/" -
|
|
|
|
NIL = "nil" !ALNUM -
|
|
WHILE = "while" !ALNUM -
|
|
IF = "if" !ALNUM -
|
|
ELSE = "else" !ALNUM -
|
|
FOR = "for" !ALNUM -
|
|
IN = "in" !ALNUM -
|
|
FROM = "from" !ALNUM -
|
|
TO = "to" !ALNUM -
|
|
CONT = "continue" !ALNUM -
|
|
BREAK = "break" !ALNUM -
|
|
RETURN = "return" !ALNUM -
|
|
TRY = "try" !ALNUM -
|
|
CATCH = "catch" !ALNUM -
|
|
ENSURE = "ensure" !ALNUM -
|
|
RAISE = "raise" !ALNUM -
|
|
GLOBAL = "global" !ALNUM -
|
|
LOCAL = "local" !ALNUM -
|
|
SUPER = "super" !ALNUM -
|
|
|
|
BQUOTE = "`" -
|
|
COMMAT = "@" -
|
|
HASH = "#" -
|
|
SEMI = ";" -
|
|
ASSIGN = "=" ![=] -
|
|
COMMA = "," -
|
|
COLON = ":" ![:] -
|
|
LPAREN = "(" -
|
|
RPAREN = ")" -
|
|
LBRAK = "[" -
|
|
RBRAK = "]" -
|
|
LBRACE = "{" -
|
|
RBRACE = "}" -
|
|
BARBAR = "||" ![=] -
|
|
ANDAND = "&&" ![=] -
|
|
OR = "|" ![|=] -
|
|
OREQ = "|=" -
|
|
XOR = "^" ![=] -
|
|
XOREQ = "^=" -
|
|
AND = "&" ![&=] -
|
|
ANDEQ = "&=" -
|
|
EQ = "==" -
|
|
NOTEQ = "!=" -
|
|
LESS = "<" ![<=] -
|
|
LESSEQ = "<=" -
|
|
GRTREQ = ">=" -
|
|
GRTR = ">" ![=] -
|
|
SHL = "<<" ![=] -
|
|
SHLEQ = "<<=" -
|
|
SHR = ">>" ![=] -
|
|
SHREQ = ">>=" -
|
|
PLUS = "+" ![+=] -
|
|
PLUSEQ = "+=" -
|
|
PPLUS = "++" -
|
|
MINUS = "-" ![-=] -
|
|
MINUSEQ = "-=" -
|
|
MMINUS = "--" -
|
|
STAR = "*" ![=] -
|
|
STAREQ = "*=" -
|
|
SLASH = "/" ![/=] -
|
|
SLASHEQ = "/=" -
|
|
PCENT = "%" ![=] -
|
|
PCENTEQ = "%=" -
|
|
DOT = "." -
|
|
PLING = "!" ![=] -
|
|
TILDE = "~" -
|
|
|
|
error = - < (!EOL .)* >
|
|
|
|
xexpr = expr | error @{ expected("expression", yytext) }
|
|
|
|
%%
|
|
;
|
|
|
|
#if PROFILE
|
|
|
|
oop *profiles = 0;
|
|
int nprofiles = 0;
|
|
|
|
oop profileInit(oop function)
|
|
{
|
|
profiles = xrealloc(profiles, sizeof(*profiles) * (nprofiles + 1));
|
|
oop p = profiles[nprofiles++] = new(pObject);
|
|
Object_put(p, sym_function, function);
|
|
Object_put(p, sym_count, newInteger(0));
|
|
Object_put(p, sym_stamp, newInteger(0));
|
|
Object_put(p, sym_time, newInteger(0));
|
|
return p;
|
|
}
|
|
|
|
#include <time.h>
|
|
|
|
long uclock(void)
|
|
{
|
|
struct rusage ru;
|
|
getrusage(RUSAGE_SELF, &ru);
|
|
return ru.ru_utime.tv_sec * 1000000 + ru.ru_utime.tv_usec;
|
|
}
|
|
|
|
void profileTick(oop p)
|
|
{
|
|
oop *ref = Object_refLocal(p, sym_count); if (!ref) fatal("profile data lost: count");
|
|
long count = _integerValue(*ref);
|
|
*ref = newInteger(count + 1);
|
|
ref = Object_refLocal(p, sym_stamp); if (!ref) fatal("profile data lost: stamp");
|
|
//*ref = newInteger(clock());
|
|
*ref = newInteger(uclock());
|
|
}
|
|
|
|
void profileTock(oop p)
|
|
{
|
|
//long ticks = clock() - _integerValue(Object_getLocal(p, sym_stamp));
|
|
long ticks = uclock() - _integerValue(Object_getLocal(p, sym_stamp));
|
|
oop *timep = Object_refLocal(p, sym_time ); if (!timep) fatal("profile data lost: time");
|
|
ticks += _integerValue(*timep);
|
|
*timep = newInteger(ticks);
|
|
}
|
|
|
|
void profileReport(void)
|
|
{
|
|
printf("%7s %7s function\n", "count", "msecs");
|
|
for (int i = 0; i < nprofiles; ++i) {
|
|
oop prof = profiles[i];
|
|
oop func = Object_getLocal(prof, sym_function);
|
|
long count = _integerValue(Object_getLocal(prof, sym_count ));
|
|
long ticks = _integerValue(Object_getLocal(prof, sym_time ));
|
|
printf("%7ld ", count);
|
|
//printf("%7ld ", (long)(1000. * ticks / CLOCKS_PER_SEC));
|
|
printf("%7ld ", ticks);
|
|
if (is(Primitive, func)) {
|
|
printf("%s\n", printString(func, 0));
|
|
continue;
|
|
}
|
|
oop parent = Object_getLocal(func, sym_parent);
|
|
oop name = Object_getLocal(func, sym_name);
|
|
if (nil != parent) printf("%s.", codeString (parent, 0));
|
|
if (nil != name ) printf("%s", printString(name, 0));
|
|
else printf("[anonymous function]");
|
|
printf("\n");
|
|
}
|
|
}
|
|
|
|
#endif
|
|
|
|
oop apply(oop func, oop self, oop args, oop env, oop owner)
|
|
{
|
|
int functype = getType(func);
|
|
if (Primitive == functype) {
|
|
# if PROFILE
|
|
oop profile = nil;
|
|
if (opt_p) {
|
|
profile = _get(func, Primitive,profile);
|
|
if (nil == profile) profile = _set(func, Primitive,profile, profileInit(func));
|
|
profileTick(profile);
|
|
}
|
|
# endif
|
|
oop result = _get(func, Primitive,function)(func, self, args, env);
|
|
# if PROFILE
|
|
if (opt_p) profileTock(profile);
|
|
# endif
|
|
return result;
|
|
}
|
|
#if PRIMCLOSURE
|
|
if (Closure != functype)
|
|
valueError(nil == self ? "()" : ".()", "cannot apply", func);
|
|
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))
|
|
valueError(nil == self ? "()" : ".()", "cannot apply", func);
|
|
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);
|
|
# if PROFILE
|
|
oop profile = nil;
|
|
if (opt_p) {
|
|
profile = Object_getLocal(lambda, sym_profile);
|
|
if (nil == profile) profile = Object_put(lambda, sym_profile, profileInit(lambda));
|
|
profileTick(profile);
|
|
}
|
|
# endif
|
|
#endif
|
|
oop *exprs = get(body, Object,indexed);
|
|
int size = _get(body, Object,isize);
|
|
oop result = nil;
|
|
assert(is(Object, args));
|
|
// inherit from closure's captured environment
|
|
_setDelegate(args, environment);
|
|
Object_put(args, sym_self, self);
|
|
Object_put(args, prop_owner, owner);
|
|
int nparam = _get(parameters, Object,isize);
|
|
oop *pparam = _get(parameters, Object,indexed);
|
|
int nargs = _get(args, Object,isize);
|
|
oop *pargs = _get(args, Object,indexed);
|
|
# if NONLOCAL
|
|
switch (nlrPush()) {
|
|
case NLR_CONTINUE: syntaxError("continue outside loop");
|
|
case NLR_BREAK: syntaxError("break outside loop");
|
|
case NLR_RETURN: return nlrPop();
|
|
case NLR_RAISE: nlrReturn(nlrPop(), NLR_RAISE);
|
|
}
|
|
# endif
|
|
// positional args -> named parameters
|
|
for (int i = 0; i < nparam; ++i)
|
|
Object_put(args, pparam[i], i < nargs ? pargs[i] : nil);
|
|
// keyword defaults
|
|
int nkeywd = _get(parameters, Object,psize);
|
|
struct property *pkeywd = _get(parameters, Object,properties);
|
|
for (int i = 0; i < nkeywd; ++i)
|
|
if (Object_find(args, pkeywd[i].key) < 0)
|
|
Object_put(args, pkeywd[i].key, eval(pkeywd[i].val, args));
|
|
for (int i = 0; i < size; ++i)
|
|
result = eval(exprs[i], args);
|
|
# if NONLOCAL
|
|
nlrPop();
|
|
# endif
|
|
# if PROFILE
|
|
if (opt_p) profileTock(profile);
|
|
# endif
|
|
return result;
|
|
}
|
|
|
|
oop getArg(oop args, int index, char *who)
|
|
{ assert(is(Object, args));
|
|
if (index >= _get(args, Object,isize)) valueError("%s", "too few arguments", args);
|
|
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)) typeError(who, "illegal argument type", arg);
|
|
return arg;
|
|
}
|
|
|
|
#if TYPECODES
|
|
|
|
enum typecode getTypecode(oop exp)
|
|
{
|
|
oop delegate = _getDelegate(exp);
|
|
oop name = Object_getLocal(delegate, prop_name);
|
|
return is(Symbol, name) ? _get(name, Symbol,typecode) : UNDEFINED_TYPECODE;
|
|
}
|
|
|
|
#endif // !TYPECODES
|
|
|
|
#define defineEval(NAME) \
|
|
static inline oop prim_##NAME##_eval(oop func, oop exp, oop args, oop env) { \
|
|
if (_get(args,Object,isize) >= 1) env = Object_at(args, 0); \
|
|
return NAME##_eval(exp, env); \
|
|
}
|
|
|
|
doProtos(defineEval)
|
|
|
|
#undef defineEval
|
|
|
|
#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
|
|
switch (getTypecode(exp)) {
|
|
case UNDEFINED_TYPECODE:
|
|
break;
|
|
# define defineEval(NAME) case t##NAME: return NAME##_eval(exp, env);
|
|
doProtos(defineEval);
|
|
# undef defineEval
|
|
}
|
|
# endif // TYPECODES
|
|
|
|
oop owner = nil;
|
|
oop evaluator = Object_getOwner(exp, prop_eval, &owner);
|
|
oop args = new(pObject);
|
|
Object_push(args, env);
|
|
return apply(evaluator, exp, args, env, owner);
|
|
}
|
|
|
|
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 != type) {
|
|
if (String == type) return newStringLen(_get(exp, String,value), _get(exp, String,length));
|
|
return exp;
|
|
}
|
|
if (!opt_O) {
|
|
Object_push(trace, exp);
|
|
if (opt_d && opt_v) {
|
|
printf("@@@ ");
|
|
codeln(exp, 0);
|
|
}
|
|
}
|
|
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_Object_new(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
_setDelegate(args, self);
|
|
oop owner = nil;
|
|
oop ifunc = Object_getOwner(args, sym_initialise, &owner);
|
|
apply(ifunc, args, new(pObject), env, owner);
|
|
return args;
|
|
}
|
|
|
|
oop prim_Object_initialise(oop func, oop self, oop args, oop env)
|
|
{
|
|
return self;
|
|
}
|
|
|
|
oop prim_Object_push(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
int argc = _get(args, Object,isize); assert(is(Object, self));
|
|
oop *indexed = _get(args, Object,indexed);
|
|
for (int i = 0; i < argc; ++i) Object_push(self, indexed[i]);
|
|
return self;
|
|
}
|
|
|
|
oop prim_Object_pop(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, self));
|
|
int size = _get(self, Object,isize);
|
|
if (size < 1) rangeError("Object.pop", "object is empty", self, 0);
|
|
--size;
|
|
_set(self, Object,isize, size);
|
|
return _get(self, Object,indexed)[size];
|
|
}
|
|
|
|
oop prim_String_new(oop func, oop self, oop args, oop env)
|
|
{
|
|
int nargs = _get(args, Object,isize);
|
|
if (nargs == 0) return newStringLen(0, 0);
|
|
int len = _integerValue(getArgType(args, 0, Integer, "String.new"));
|
|
return newStringLen(0, len);
|
|
}
|
|
|
|
oop prim_String_escaped(oop func, oop self, oop args, oop env)
|
|
{
|
|
return String_escaped(self);
|
|
}
|
|
|
|
oop prim_String_unescaped(oop func, oop self, oop args, oop env)
|
|
{
|
|
return newStringUnescaped(String_content(self));
|
|
}
|
|
|
|
oop prim_String_push(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
int argc = _get(args, Object,isize); assert(is(String, self));
|
|
oop *indexed = _get(args, Object,indexed);
|
|
for (int i = 0; i < argc; ++i) String_push(self, indexed[i]);
|
|
return self;
|
|
}
|
|
|
|
oop prim_String_pop(oop func, oop self, oop args, oop env)
|
|
{ assert(is(String, self));
|
|
int size = _get(self, String,length);
|
|
if (size < 1) rangeError("String.pop", "string is empty", self, 0);
|
|
--size;
|
|
_set(self, String,length, size);
|
|
return newInteger(_get(self, String,value)[size]);
|
|
}
|
|
|
|
oop prim_String_asInteger(oop func, oop self, oop args, oop env)
|
|
{ assert(is(String, self));
|
|
char *str = String_content(self); // ensure nul terminator
|
|
char *end = 0;
|
|
long value = strtol(str, &end, 0);
|
|
if (*end) return nil;
|
|
return newInteger(value);
|
|
}
|
|
|
|
oop prim_String_asFloat(oop func, oop self, oop args, oop env)
|
|
{ assert(is(String, self));
|
|
char *str = String_content(self); // ensure nul terminator
|
|
char *end = 0;
|
|
double value = strtod(str, &end);
|
|
if (*end) return nil;
|
|
return newFloat(value);
|
|
}
|
|
|
|
oop prim_String_asSymbol(oop func, oop self, oop args, oop env)
|
|
{ assert(is(String, self));
|
|
return intern(String_content(self));
|
|
}
|
|
|
|
char *strnchr(char *s, int len, int c)
|
|
{
|
|
while (len--) if (c == *s++) return s-1;
|
|
return 0;
|
|
}
|
|
|
|
#if !defined(__MACH__) // BSD has this in libc
|
|
|
|
char *strnstr(char *s, char *t, int slen)
|
|
{
|
|
int tlen = strlen(t);
|
|
int limit = slen - tlen;
|
|
for (int i = 0; i <= limit; ++i)
|
|
if (!strncmp(s + i, t, tlen))
|
|
return s+i;
|
|
return 0;
|
|
}
|
|
|
|
#endif
|
|
|
|
oop String_bitSet(oop string, int bit)
|
|
{
|
|
int index = bit / 8, shift = bit % 8;
|
|
while (index >= _get(string, String,length)) String_append(string, 0);
|
|
_get(string, String,value)[index] |= (1 << shift);
|
|
return string;
|
|
}
|
|
|
|
oop prim_String_bitSet(oop func, oop self, oop args, oop env)
|
|
{
|
|
return String_bitSet(self, _integerValue(getArgType(args, 0, Integer, "String.bitSet")));
|
|
}
|
|
|
|
oop String_bitClear(oop string, int bit)
|
|
{
|
|
int index = bit / 8, shift = bit % 8;
|
|
while (index >= _get(string, String,length)) String_append(string, 0);
|
|
_get(string, String,value)[index] &= ~(1 << shift);
|
|
return string;
|
|
}
|
|
|
|
oop prim_String_bitClear(oop func, oop self, oop args, oop env)
|
|
{
|
|
return String_bitClear(self, _integerValue(getArgType(args, 0, Integer, "String.bitClear")));
|
|
}
|
|
|
|
oop String_bitInvert(oop string, int bit)
|
|
{
|
|
int index = bit / 8, shift = bit % 8;
|
|
while (index >= _get(string, String,length)) String_append(string, 0);
|
|
_get(string, String,value)[index] ^ (1 << shift);
|
|
return string;
|
|
}
|
|
|
|
oop prim_String_bitInvert(oop func, oop self, oop args, oop env)
|
|
{
|
|
return String_bitInvert(self, _integerValue(getArgType(args, 0, Integer, "String.bitInvert")));
|
|
}
|
|
|
|
int String_bitTest(oop string, int bit)
|
|
{
|
|
int index = bit / 8, shift = bit % 8;
|
|
if (index >= _get(string, String,length)) return 0;
|
|
return (_get(string, String,value)[index] >> shift) & 1;
|
|
}
|
|
|
|
oop prim_String_bitTest(oop func, oop self, oop args, oop env)
|
|
{
|
|
return newBoolean(String_bitTest(self, _integerValue(getArgType(args, 0, Integer, "String.bitTest"))));
|
|
}
|
|
|
|
// a bit silly having this as a primitive...
|
|
|
|
int charClassNext(char **ppc)
|
|
{
|
|
int c = *(*ppc)++;
|
|
if ('\\' == c && **ppc) {
|
|
c = *(*ppc)++;
|
|
switch (c) {
|
|
case 'a': return '\a';
|
|
case 'b': return '\b';
|
|
case 'f': return '\f';
|
|
case 'n': return '\n';
|
|
case 'r': return '\r';
|
|
case 't': return '\t';
|
|
case 'v': return '\v';
|
|
case '0'...'7': {
|
|
c &= 7;
|
|
if ('0' <= **ppc && **ppc <= '7') c = (c << 3) | (*(*ppc)++ & 7);
|
|
if ('0' <= **ppc && **ppc <= '7') c = (c << 3) | (*(*ppc)++ & 7);
|
|
return c;
|
|
}
|
|
case 'x': {
|
|
c = 0;
|
|
int d;
|
|
while ((d = digitValue(**ppc, 16)) >= 0) c = (c << 4) | d, ++*ppc;
|
|
return c;
|
|
}
|
|
}
|
|
}
|
|
return c;
|
|
}
|
|
|
|
oop prim_String_charClass(oop func, oop self, oop args, oop env)
|
|
{
|
|
oop bits = newStringLen(0, 0);
|
|
char *spec = String_content(self);
|
|
int invert = 0;
|
|
if ((invert = ('^' == spec[0]))) ++spec;
|
|
while (*spec) {
|
|
int c = charClassNext(&spec);
|
|
if ('-' == spec[0] && spec[1]) {
|
|
++spec;
|
|
int d = charClassNext(&spec);
|
|
for (int i = c; i <= d; ++i) String_bitSet(bits, i);
|
|
continue;
|
|
}
|
|
String_bitSet(bits, c);
|
|
}
|
|
if (invert) {
|
|
int length = _get(bits, String,length);
|
|
while (length < 16) String_append(bits, 0), ++length;
|
|
char *value = _get(bits, String,value);
|
|
for (int i = 0; i < length; ++i) value[i] ^= 0xff;
|
|
}
|
|
return bits;
|
|
}
|
|
|
|
oop prim_String_compareFrom(oop func, oop self, oop args, oop env)
|
|
{
|
|
int off = _integerValue(getArgType(args, 0, Integer, "String.compareFrom"));
|
|
oop str = getArgType(args, 1, String, "String.compareFrom");
|
|
char *myval = _get(self, String,value);
|
|
int mylen = _get(self, String,length);
|
|
char *qqval = _get(str, String,value);
|
|
int qqlen = _get(str, String,length);
|
|
if (off + qqlen > mylen) return nil;
|
|
return newInteger(strncmp(myval + off, qqval, qqlen));
|
|
}
|
|
|
|
oop prim_String_intAt(oop func, oop self, oop args, oop env)
|
|
{
|
|
int index = _integerValue(getArgType(args, 0, Integer, "String.intAt"));
|
|
int size = _get(self, String,length);
|
|
if (index < 0 || index + sizeof(int) > size)
|
|
rangeError("String.intAt", "index out of bounds", self, index);
|
|
return newInteger(*(int *)(_get(self, String,value) + index));
|
|
}
|
|
|
|
oop prim_Object_includes(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (!is(Object, self)) return nil;
|
|
int argc = _get(args, Object,isize);
|
|
oop *argv = _get(args, Object,indexed);
|
|
int size = _get(self, Object,isize);
|
|
oop *elts = _get(self, Object,indexed);
|
|
for (int i = 0; i < argc; ++i) {
|
|
oop arg = argv[i];
|
|
int found = 0;
|
|
for (int j = 0; j < size; ++j)
|
|
if ((found = (elts[j] == arg)))
|
|
break;
|
|
if (!found) return nil;
|
|
}
|
|
return sym_t;
|
|
}
|
|
|
|
oop prim_String_includes(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
int size = _get(args, Object,isize); assert(is(String, self));
|
|
oop *elts = _get(args, Object,indexed);
|
|
char *value = _get(self, String,value);
|
|
int length = _get(self, String,length);
|
|
for (int i = 0; i < size; ++i) {
|
|
oop arg = elts[i];
|
|
switch (getType(arg)) {
|
|
case Integer:
|
|
if (!strnchr(value, length, _integerValue(arg))) return nil;
|
|
continue;
|
|
case String:
|
|
if (!strnstr(value, String_content(arg), length)) return nil;
|
|
continue;
|
|
default:
|
|
typeError("String.includes", "non-string/integer argument", arg);
|
|
break;
|
|
}
|
|
}
|
|
return sym_t;
|
|
}
|
|
|
|
oop prim_String_sliced(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
int argc = _get(args, Object,isize); assert(is(String, self));
|
|
if (argc != 2) valueError("String.sliced", "two arguments expected", args);
|
|
oop *argv = _get(args, Object,indexed);
|
|
char *value = _get(self, String,value);
|
|
int length = _get(self, String,length);
|
|
int start = integerValue(argv[0], "String.sliced");
|
|
int end = integerValue(argv[1], "String.sliced");
|
|
if (start < 0) start += length;
|
|
if (start < 0 || start >= length) rangeError("String.sliced", "start index out of bounds", self, start);
|
|
if (end < 0) end += length;
|
|
if (end < 0 || end >= length) rangeError("String.sliced", "end index out of bounds", self, end);
|
|
oop result = newStringLen(0, 0);
|
|
String_appendAllLen(result, value + start, end - start + 1);
|
|
return result;
|
|
}
|
|
|
|
oop prim_Symbol_asString(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Symbol, self));
|
|
return newString(_get(self, Symbol,name));
|
|
}
|
|
|
|
oop prim_length(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (!is(Object, self)) valueError("length", "not an object", self);
|
|
return newInteger(_get(self, Object,isize));
|
|
}
|
|
|
|
oop prim_keys(oop func, oop self, oop args, oop env)
|
|
{
|
|
return keys(self, 0);
|
|
}
|
|
|
|
oop prim_allKeys(oop func, oop self, oop args, oop env)
|
|
{
|
|
return keys(self, 1);
|
|
}
|
|
|
|
oop prim_findKey(oop func, oop self, oop args, oop env)
|
|
{
|
|
if (is(Object, self)) {
|
|
if (_get(args, Object,isize) != 1) valueError("Object.findKey", "one argument expected", args);
|
|
oop key = _get(args, Object,indexed)[0];
|
|
int index = Object_find(self, key);
|
|
return newInteger(index);
|
|
}
|
|
return nil;
|
|
}
|
|
|
|
oop prim_sorted(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (self == nil) {
|
|
if (_get(args, Object,isize) != 1) valueError("sorted", "one argument expected", args);
|
|
self = _get(args, Object,indexed)[0];
|
|
}
|
|
return sorted(self, "sorted");
|
|
}
|
|
|
|
oop prim_reversed(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (self == nil) {
|
|
if (_get(args, Object,isize) != 1) valueError("reversed", "one argument expected", args);
|
|
self = _get(args, Object,indexed)[0];
|
|
}
|
|
return reversed(self, "reversed");
|
|
}
|
|
|
|
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___eval__(oop func, oop self, oop args, oop env)
|
|
{
|
|
return self;
|
|
}
|
|
|
|
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;
|
|
oop full = Object_getLocal(args, sym_full);
|
|
int indent = isInteger(full) ? _integerValue(full) : nil != full;
|
|
for (int i = 0; i < argc; ++i) print(result = indexed[i], indent);
|
|
fflush(stdout);
|
|
return result;
|
|
}
|
|
|
|
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) valueError("sqrt", "one argument expected", args);
|
|
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) valueError("round", "one argument expected", args);
|
|
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) valueError("truncate", "one argument expected", args);
|
|
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) valueError("len", "one argument expected", args);
|
|
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) valueError("ord", "one argument expected", args);
|
|
oop arg = _get(args, Object,indexed)[0];
|
|
if (!is(String, arg)) typeError("ord", "non-string argument", arg);
|
|
if (1 != _get(arg, String,length)) valueError("ord", "string of length one expected", arg);
|
|
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)) typeError("readfile", "non-string argument", name);
|
|
FILE *file = fopen(_get(name, String,value), "r");
|
|
if (!file) valueError("readfile", strerror(errno), name);
|
|
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) valueError("exit", "too many arguments", args);
|
|
if (argc == 1) status = integerValue(_get(args, Object,indexed)[0], "exit");
|
|
exit(status);
|
|
return nil;
|
|
}
|
|
|
|
oop prim_error(oop func, oop self, oop args, oop env)
|
|
{
|
|
int argc = _get(args, Object,isize);
|
|
if (argc != 1) valueError("error", "one argument expected", args);
|
|
oop arg = _get(args, Object,indexed)[0];
|
|
if (!is(String, arg)) typeError("error", "non-string argument", arg);
|
|
unknownError(String_content(arg));
|
|
return 0;
|
|
}
|
|
|
|
oop prim_Symbol_setopt(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Symbol, self));
|
|
int argc = _get(args, Object,isize);
|
|
if (argc != 1) valueError("Symbol.setopt", "one argument expected", args);
|
|
oop val = _get(args, Object,indexed)[0];
|
|
if (!isInteger(val)) typeError("Symbol.setopt", "non-integer agument", val);
|
|
int optval = _integerValue(val);
|
|
if (sym_O == self) opt_O = optval;
|
|
else if (sym_d == self) opt_d = optval;
|
|
else if (sym_p == self) opt_p = optval;
|
|
else if (sym_v == self) opt_v = optval;
|
|
else valueError("Symbol.setopt", "unknown option", val);
|
|
return val;
|
|
}
|
|
|
|
oop prim_Symbol_getopt(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Symbol, self));
|
|
if (sym_O == self) return newInteger(opt_O);
|
|
else if (sym_d == self) return newInteger(opt_d);
|
|
else if (sym_p == self) return newInteger(opt_p);
|
|
else if (sym_v == self) return newInteger(opt_v);
|
|
else valueError("Symbol.getopt", "unknown option", self);
|
|
return 0;
|
|
}
|
|
|
|
oop prim_defined(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
if (1 != _get(args, Object,isize)) valueError("defined", "one argument expected", args);
|
|
oop arg = _get(args, Object,indexed)[0];
|
|
return UNDEFINED == *_refvar(env, arg) ? nil : sym_t; // looks in locals too
|
|
}
|
|
|
|
oop prim_Symbol_defined(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Symbol, self));
|
|
return UNDEFINED == _get(self, Symbol,value) ? nil : sym_t; // looks only at global
|
|
}
|
|
|
|
oop prim_Symbol_define(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Object, args));
|
|
int argc = _get(args, Object,isize); assert(is(Symbol, self));
|
|
if (argc != 1) valueError("Symbol.define", "one argument expected", args);
|
|
_set(self, Symbol,value, _get(args, Object,indexed)[0]);
|
|
return self;
|
|
}
|
|
|
|
oop prim_Symbol_value(oop func, oop self, oop args, oop env)
|
|
{ assert(is(Symbol, self));
|
|
oop value = _get(self, Symbol,value);
|
|
return value ? value : nil;
|
|
}
|
|
|
|
oop prim_Symbol_allInstances(oop func, oop self, oop args, oop env)
|
|
{
|
|
oop result = new(pObject);
|
|
for (int i = 0; i < nsymbols; ++i) Object_push(result, symbols[i]);
|
|
return result;
|
|
}
|
|
|
|
#include <dlfcn.h>
|
|
#include <ffi.h>
|
|
|
|
void *pointerValue(oop obj, char *who)
|
|
{
|
|
switch (getType(obj)) {
|
|
case Integer: return (void *)(intptr_t)_integerValue(obj);
|
|
case String: return String_content(obj), _get(obj, String,value);
|
|
case Symbol: return &_get(obj, Symbol,name);
|
|
default: valueError(who, "cannot convert to pointer", obj);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
ffi_type *sig2type(int sig)
|
|
{
|
|
switch (sig) {
|
|
case 'v': return &ffi_type_void;
|
|
case 'c': return &ffi_type_schar;
|
|
case 'C': return &ffi_type_uchar;
|
|
case 's': return &ffi_type_sshort;
|
|
case 'S': return &ffi_type_ushort;
|
|
case 'i': return &ffi_type_sint;
|
|
case 'I': return &ffi_type_uint;
|
|
case 'l': return &ffi_type_slong;
|
|
case 'L': return &ffi_type_ulong;
|
|
case 'z': return &ffi_type_slong;
|
|
case 'Z': return &ffi_type_ulong;
|
|
case 'f': return &ffi_type_float;
|
|
case 'd': return &ffi_type_double;
|
|
case 'p':
|
|
case '*': return &ffi_type_pointer;
|
|
}
|
|
valueError("__extern__", "illegal type code", newInteger(sig));
|
|
return 0;
|
|
}
|
|
|
|
struct ffi_t {
|
|
char *name;
|
|
ffi_cif *cif;
|
|
char *signature;
|
|
void *function;
|
|
int arity;
|
|
};
|
|
|
|
oop primitiveExternalCall = 0;
|
|
|
|
void *dlprobe(char *dir, char *prefix, char *name, char *suffix, int mode)
|
|
{
|
|
oop path = newStringLen(0, 0);
|
|
String_appendAll(path, dir);
|
|
String_appendAll(path, prefix);
|
|
String_appendAll(path, name);
|
|
String_appendAll(path, suffix);
|
|
char *cpath = String_content(path);
|
|
if (opt_d) printf("dlprobe %s\n", cpath);
|
|
return dlopen(cpath, mode);
|
|
}
|
|
|
|
void *dlfind(char *name, int mode)
|
|
{
|
|
static char *dirs[] = { "", "/usr/lib/", "/lib/", "/usr/local/lib/", "/opt/local/lib/", 0 };
|
|
static char *prefixes[] = { "lib", "", 0 };
|
|
static char *suffixes[] = { ".so", ".dylib", ".dll", 0 };
|
|
for (char **dir = dirs; *dir; ++dir)
|
|
for (char **prefix = prefixes; *prefix; ++prefix)
|
|
for (char **suffix = suffixes; *suffix; ++suffix) {
|
|
void *hnd = dlprobe(*dir, *prefix, name, *suffix, mode);
|
|
if (hnd) {
|
|
if (opt_d) printf("-> %p\n", hnd);
|
|
return hnd;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
void *xdlopen(oop obj)
|
|
{
|
|
if (nil == obj) return dlopen(0, RTLD_GLOBAL | RTLD_LAZY);
|
|
void *hnd = dlfind(stringValue(obj, "__extern__"), RTLD_GLOBAL | RTLD_LAZY);
|
|
if (!hnd) valueError("__extern__", "library not found", obj);
|
|
return hnd;
|
|
}
|
|
|
|
void *xdlsym(void *handle, char *name)
|
|
{
|
|
void *addr = dlsym(handle, name);
|
|
if (!addr) valueError("__extern__", dlerror(), newString(name));
|
|
return addr;
|
|
}
|
|
|
|
oop prim_extern(oop func, oop self, oop args, oop env)
|
|
{
|
|
int nargs = _get(args, Object,isize);
|
|
oop *pargs = _get(args, Object,indexed);
|
|
switch (nargs) {
|
|
case 0: {
|
|
return mkptr(xdlopen(nil));
|
|
}
|
|
case 1: { // extern("libname")
|
|
return mkptr(xdlopen(pargs[0]));
|
|
}
|
|
case 2: { // extern("libname"/handle, "name")
|
|
void *hnd = 0;
|
|
if (isInteger(pargs[0])) hnd = (void *)(intptr_t)_integerValue(pargs[0]);
|
|
else hnd = xdlopen(pargs[0]);
|
|
return mkptr(xdlsym(hnd, stringValue(pargs[1], "__extern__")));
|
|
}
|
|
}
|
|
// extern("libname"/handle", "name", "signature")
|
|
void *hnd = 0;
|
|
if (isInteger(pargs[0])) hnd = (void *)(intptr_t)_integerValue(pargs[0]);
|
|
else hnd = xdlopen(pargs[0]);
|
|
char *sym = stringValue(pargs[1], "__extern__");
|
|
void *adr = xdlsym(hnd, sym);
|
|
char *sig = stringValue(pargs[2], "__extern__");
|
|
int argc = strlen(sig);
|
|
ffi_cif *cif = xcalloc(1, sizeof(ffi_cif));
|
|
ffi_type **argv = xcalloc(argc, sizeof(*argv));
|
|
for (int i = 0; i < argc; ++i) argv[i] = sig2type(sig[i]);
|
|
ffi_prep_cif(cif, FFI_DEFAULT_ABI, argc - 1, argv[0], argv + 1);
|
|
struct ffi_t *ffi = xmalloc(sizeof(*ffi));
|
|
ffi->name = sym;
|
|
ffi->cif = cif;
|
|
ffi->signature = sig;
|
|
ffi->function = adr;
|
|
ffi->arity = argc;
|
|
oop result = clone(primitiveExternalCall);
|
|
_set(result, Primitive,cookie, ffi);
|
|
return result;
|
|
}
|
|
|
|
union arg_t {
|
|
signed char c;
|
|
unsigned char C;
|
|
signed short s;
|
|
unsigned short S;
|
|
signed int i;
|
|
unsigned int I;
|
|
signed long l;
|
|
unsigned long L;
|
|
ssize_t z;
|
|
size_t Z;
|
|
float f;
|
|
double d;
|
|
void *p;
|
|
intptr_t P;
|
|
};
|
|
|
|
oop prim_externalCall(oop func, oop self, oop args, oop env)
|
|
{
|
|
struct ffi_t *ffi = _get(func, Primitive,cookie); assert(ffi);
|
|
int argc = ffi->arity;
|
|
union arg_t vals[argc];
|
|
void *argv[argc];
|
|
for (int i = 1; i < argc; ++i) {
|
|
switch (ffi->signature[i]) {
|
|
case 'c': vals[i].c = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'C': vals[i].C = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 's': vals[i].s = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'S': vals[i].S = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'i': vals[i].i = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'I': vals[i].I = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'l': vals[i].l = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'L': vals[i].L = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'z': vals[i].z = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'Z': vals[i].Z = integerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'f': vals[i].f = floatValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'd': vals[i].d = floatValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
case 'p':
|
|
case '*': vals[i].p = pointerValue(getArg(args, i-1, ffi->name), ffi->name); break;
|
|
default: valueError(ffi->name, "illegal argument type code", newInteger(ffi->signature[i]));
|
|
}
|
|
argv[i] = vals + i;
|
|
}
|
|
ffi_call(ffi->cif, FFI_FN(ffi->function), vals, argv+1);
|
|
switch (ffi->signature[0]) {
|
|
case 'v': return nil;
|
|
case 'c': return newInteger(vals[0].c);
|
|
case 'C': return newInteger(vals[0].C);
|
|
case 's': return newInteger(vals[0].s);
|
|
case 'S': return newInteger(vals[0].S);
|
|
case 'i': return newInteger(vals[0].i);
|
|
case 'I': return newInteger(vals[0].I);
|
|
case 'l': return newInteger(vals[0].l);
|
|
case 'L': return newInteger(vals[0].L);
|
|
case 'z': return newInteger(vals[0].z);
|
|
case 'Z': return newInteger(vals[0].Z);
|
|
case 'f': return newFloat (vals[0].f);
|
|
case 'd': return newFloat (vals[0].d);
|
|
case 'p':
|
|
case '*': return mkptr (vals[0].p);
|
|
}
|
|
valueError(ffi->name, "illegal return type code", newInteger(ffi->signature[0]));
|
|
return 0;
|
|
}
|
|
|
|
#if PEGVM
|
|
|
|
oop applyThunkIn(oop func, oop env)
|
|
{
|
|
int functype = getType(func);
|
|
if (Primitive == functype) {
|
|
# if PROFILE
|
|
oop profile = nil;
|
|
if (opt_p) {
|
|
profile = _get(func, Primitive,profile);
|
|
if (nil == profile) profile = _set(func, Primitive,profile, profileInit(func));
|
|
profileTick(profile);
|
|
}
|
|
# endif
|
|
oop result = _get(func, Primitive,function)(func, nil, nil, env);
|
|
# if PROFILE
|
|
if (opt_p) profileTock(profile);
|
|
# endif
|
|
return result;
|
|
}
|
|
#if PRIMCLOSURE
|
|
if (Closure != functype) valueError("()", "cannot apply", func);
|
|
oop lambda = _get(func, Closure,function);
|
|
oop body = _get(lambda, Lambda,body);
|
|
#else
|
|
if (Object != functype || pClosure != _getDelegate(func)) valueError("()", "cannot apply", func);
|
|
oop lambda = Object_get(func, sym_function);
|
|
oop body = Object_get(lambda, sym_body);
|
|
oop parameters = Object_get(lambda, sym_parameters);
|
|
# if PROFILE
|
|
oop profile = nil;
|
|
if (opt_p) {
|
|
profile = Object_getLocal(lambda, sym_profile);
|
|
if (nil == profile) profile = Object_put(lambda, sym_profile, profileInit(lambda));
|
|
profileTick(profile);
|
|
}
|
|
# endif
|
|
#endif
|
|
oop *exprs = get(body, Object,indexed);
|
|
int size = _get(body, Object,isize);
|
|
oop result = nil;
|
|
oop args = new(pObject);
|
|
// inherit from closure's captured environment
|
|
_setDelegate(args, env);
|
|
# if NONLOCAL
|
|
switch (nlrPush()) {
|
|
case NLR_CONTINUE: syntaxError("continue outside loop");
|
|
case NLR_BREAK: syntaxError("break outside loop");
|
|
case NLR_RETURN: return nlrPop();
|
|
case NLR_RAISE: nlrReturn(nlrPop(), NLR_RAISE);
|
|
}
|
|
# endif
|
|
for (int i = 0; i < size; ++i)
|
|
result = eval(exprs[i], args);
|
|
# if NONLOCAL
|
|
nlrPop();
|
|
# endif
|
|
# if PROFILE
|
|
if (opt_p) profileTock(profile);
|
|
# endif
|
|
return result;
|
|
}
|
|
|
|
typedef unsigned char byte;
|
|
|
|
typedef enum op_t {
|
|
PUSH, DROP, POP, DOT, CLASS, STRING, TEST, RULE2, RULE, CALL, CALL2,
|
|
SUCCEED, FAIL, ACTION, BEGIN, END, UNEND, SET,
|
|
} op_t;
|
|
|
|
char *op_n[] = {
|
|
"PUSH", "DROP", "POP", "DOT", "CLASS", "STRING", "TEST", "RULE2", "RULE", "CALL", "CALL2",
|
|
"SUCCEED", "FAIL", "ACTION", "BEGIN", "END", "UNEND", "SET",
|
|
};
|
|
|
|
typedef struct vmInsn vmInsn;
|
|
|
|
struct vmInsn {
|
|
union {
|
|
char *str;
|
|
oop obj;
|
|
vmInsn *code;
|
|
int len;
|
|
} arg, arg2;
|
|
unsigned short op, ok, ko;
|
|
};
|
|
|
|
typedef struct vmState
|
|
{
|
|
oop result;
|
|
oop variables;
|
|
} vmState;
|
|
|
|
#define VM_STATE_INITIALISER { nil, nil }
|
|
|
|
void vmEnter(vmState *state, oop obj, char *yytext, int yyleng)
|
|
{
|
|
state->variables = new(state->variables);
|
|
Object_put(state->variables, sym_$$, state->result);
|
|
}
|
|
|
|
void vmSet(vmState *state, oop obj, char *yytext, int yyleng)
|
|
{
|
|
Object_put(state->variables, obj, state->result);
|
|
}
|
|
|
|
void vmAction(vmState *state, oop obj, char *yytext, int yyleng)
|
|
{
|
|
oop text = yyleng ? newStringLen(yytext, yyleng) : nil;
|
|
Object_put(state->variables, sym_yytext, text);
|
|
Object_put(state->variables, sym_yyleng, newInteger(yyleng));
|
|
applyThunkIn(obj, state->variables);
|
|
}
|
|
|
|
void vmLeave(vmState *state, oop obj, char *yytext, int yyleng)
|
|
{
|
|
state->result = Object_getLocal(state->variables, sym_$$);
|
|
state->variables = _getDelegate(state->variables);
|
|
}
|
|
|
|
void vmDisassemble(vmInsn *code, int pc)
|
|
{
|
|
vmInsn *i = &code[pc];
|
|
printf("%p ", code);
|
|
switch (i->op) {
|
|
case CLASS:
|
|
case STRING:
|
|
printf("%03d %-7s \"%s\" %2d %2d %2d\n",
|
|
pc, op_n[i->op], i->arg.str, i->arg2.len, i->ok, i->ko);
|
|
break;
|
|
case CALL:
|
|
printf("%03d %-7s %p %2d %2d %2d\n",
|
|
pc, op_n[i->op], i->arg.code, i->arg2.len, i->ok, i->ko);
|
|
break;
|
|
case CALL2:
|
|
printf("%03d %-7s %p %2d %2d %2d\n",
|
|
pc, op_n[i->op], i->arg.code, i->arg2.len, i->ok, i->ko);
|
|
break;
|
|
default:
|
|
printf("%03d %-7s %s %2d %2d %2d\n",
|
|
pc, op_n[i->op], codeString(i->arg.obj, 0), i->arg2.len, i->ok, i->ko);
|
|
break;
|
|
}
|
|
}
|
|
|
|
oop vmCache = 0;
|
|
|
|
void vmCachePut(oop grammar, oop symbol, vmInsn *code)
|
|
{
|
|
oop *ref = Object_refLocal(vmCache, grammar);
|
|
if (UNDEFINED == ref) {
|
|
Object_put(vmCache, grammar, new(pObject));
|
|
ref = _refvar(vmCache, grammar);
|
|
}
|
|
oop line = *ref;
|
|
ref = Object_refLocal(line, symbol);
|
|
if (UNDEFINED != ref) fatal("vm cache collision");
|
|
Object_put(line, symbol, mkptr(code));
|
|
}
|
|
|
|
vmInsn *vmCompile(oop grammar, oop symbol)
|
|
{
|
|
oop program = Object_get(grammar, symbol);
|
|
if (!is(Object, program)) valueError("__match__", "program is not an object", program);
|
|
oop *prog = _get(program, Object,indexed);
|
|
int plen = _get(program, Object,isize);
|
|
if (plen % 5 != 0) valueError("__match__", "program length is not a multiple of five", program);
|
|
int clen = plen / 5;
|
|
vmInsn *code = xcalloc(clen, sizeof(*code));
|
|
vmCachePut(grammar, symbol, code);
|
|
oop env = nil;
|
|
int ppc = 0;
|
|
int cpc = 0;
|
|
while (ppc < plen) {
|
|
int op = integerValue(prog[ppc++], "__match__");
|
|
oop arg = prog[ppc++]; assert(arg);
|
|
oop arg2 = prog[ppc++]; assert(arg2);
|
|
int ok = integerValue(prog[ppc++], "__match__");
|
|
int ko = integerValue(prog[ppc++], "__match__");
|
|
if (ok < 0 || ok >= clen) valueError("__match__", "OK destination out of range", program);
|
|
if (ko < 0 || ko >= clen) valueError("__match__", "KO destination out of range", program);
|
|
code[cpc] = (vmInsn){ .arg.obj = arg, .arg2.obj = arg2, .op = op, .ok = ok, .ko = ko };
|
|
switch (op) {
|
|
case CLASS:
|
|
case STRING: {
|
|
code[cpc].arg2.len = stringLength(code[cpc].arg.obj, "__match__");
|
|
code[cpc].arg.str = stringValue (code[cpc].arg.obj, "__match__");
|
|
break;
|
|
}
|
|
case TEST: {
|
|
if (!isClosure(code[cpc].arg.obj)) valueError("__match__", "TEST argument must be a closure", program);
|
|
break;
|
|
}
|
|
case RULE2: {
|
|
if (!is(Symbol, code[cpc].arg.obj )) valueError("__match__", "RULE2 argument must be a symbol", program);
|
|
if (!is(Object, code[cpc].arg2.obj)) valueError("__match__", "RULE2 argument2 must be an object", program);
|
|
break;
|
|
}
|
|
case RULE: {
|
|
if (!is(Symbol, code[cpc].arg.obj)) valueError("__match__", "RULE argument must be a symbol", program);
|
|
break;
|
|
}
|
|
case CALL: {
|
|
valueError("__match__", "program contains explicit CALL opcode", program);
|
|
break;
|
|
}
|
|
case CALL2: {
|
|
valueError("__match__", "program contains explicit CALL2 opcode", program);
|
|
break;
|
|
}
|
|
case ACTION: {
|
|
if (!isClosure(code[cpc].arg.obj)) valueError("__match__", "ACTION argument must be a closure", program);
|
|
break;
|
|
}
|
|
case SET: {
|
|
if (!is(Symbol, code[cpc].arg.obj)) valueError("__match__", "SET argument must be a symbol", program);
|
|
if (nil == env) env = new(pObject);
|
|
Object_put(env, code[cpc].arg.obj, nil);
|
|
break;
|
|
}
|
|
default: {
|
|
break;
|
|
}
|
|
}
|
|
++cpc;
|
|
}
|
|
|
|
if (opt_d) {
|
|
printf("---- BEGIN "); println(symbol, 0);
|
|
for (int pc = 0; pc < cpc; ++pc) vmDisassemble(code, pc);
|
|
printf("---- END "); println(symbol, 0);
|
|
}
|
|
|
|
return code;
|
|
}
|
|
|
|
vmInsn *vmCacheGet(oop grammar, oop symbol)
|
|
{
|
|
oop *ref = Object_refLocal(vmCache, grammar);
|
|
if (UNDEFINED != ref) {
|
|
oop line = *ref;
|
|
ref = Object_refLocal(line, symbol);
|
|
if (UNDEFINED != ref)
|
|
return (vmInsn *)(intptr_t)_integerValue(*ref);
|
|
}
|
|
return vmCompile(grammar, symbol);
|
|
}
|
|
|
|
int vmRun(oop grammar0, oop symbol, char *text, int start, int length)
|
|
{
|
|
vmCache = new(pObject);
|
|
|
|
int maxactions = 32;
|
|
|
|
struct Action {
|
|
void (*function)(vmState *state, oop object, char *yytext, int yyleng);
|
|
oop object;
|
|
int textbeg, textlen;
|
|
} *actions = xcalloc(maxactions, sizeof(*actions));
|
|
|
|
struct Context { // for back-tracking
|
|
int position;
|
|
int nactions;
|
|
} *cstack, context;
|
|
|
|
int csp = 0, ncstack = 32;
|
|
cstack = xmalloc(sizeof(*cstack) * ncstack);
|
|
context.position = start;
|
|
context.nactions = 0;
|
|
|
|
vmState state = VM_STATE_INITIALISER;
|
|
state.variables = new(pObject);
|
|
|
|
# define saveAction(ACT, OBJ, BEG, LEN) { \
|
|
if (context.nactions >= maxactions) \
|
|
actions = xrealloc(actions, sizeof(*actions) * (maxactions *= 2)); \
|
|
actions[context.nactions++] = (struct Action){ ACT, OBJ, BEG, LEN }; \
|
|
}
|
|
|
|
//vmInsn *code = vmCacheGet(frame.grammar, symbol);
|
|
|
|
struct Frame {
|
|
oop grammar;
|
|
oop symbol;
|
|
vmInsn *code;
|
|
int pc;
|
|
int nactions;
|
|
} *rstack, frame;
|
|
|
|
int rsp = 0, nrstack = 32;
|
|
rstack = xmalloc(sizeof(*rstack) * nrstack);
|
|
frame.grammar = grammar0;
|
|
frame.symbol = symbol;
|
|
frame.code = vmCacheGet(grammar0, symbol);
|
|
frame.pc = 0;
|
|
frame.nactions = context.nactions;
|
|
|
|
int textbeg = 0, textend = 0;
|
|
int result = 0;
|
|
|
|
#define push(C, X) { \
|
|
if (C##sp >= n##C##stack) C##stack = xrealloc(C##stack, sizeof(*C##stack) * (n##C##stack *= 2)); \
|
|
C##stack[C##sp++] = (X); \
|
|
}
|
|
|
|
#define drop(C) { \
|
|
assert(C##sp); \
|
|
--C##sp; \
|
|
}
|
|
|
|
#define pop(C) ({ \
|
|
assert(C##sp); \
|
|
C##stack[--C##sp]; \
|
|
})
|
|
|
|
for (;;) {
|
|
if (opt_d) vmDisassemble(frame.code, frame.pc);
|
|
vmInsn *i = frame.code + frame.pc++;
|
|
switch (i->op) {
|
|
case PUSH: push(c, context); frame.pc = i->ok; continue;
|
|
case DROP: drop(c); frame.pc = i->ok; continue;
|
|
case POP: context = pop(c); frame.pc = i->ok; continue;
|
|
case DOT: {
|
|
if (context.position < length) {
|
|
context.position++;
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
frame.pc = i->ko;
|
|
continue;
|
|
}
|
|
case CLASS: {
|
|
if (context.position < length) {
|
|
byte c = text[context.position];
|
|
if ((((byte *)i->arg.str)[c/8] >> (c % 8)) & 1) {
|
|
context.position++;
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
}
|
|
frame.pc = i->ko;
|
|
continue;
|
|
}
|
|
case STRING: {
|
|
if (context.position + i->arg2.len <= length) {
|
|
if (0 == memcmp(text + context.position, i->arg.str, i->arg2.len)) {
|
|
context.position += i->arg2.len;
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
}
|
|
frame.pc = i->ko;
|
|
continue;
|
|
}
|
|
case TEST: {
|
|
oop result = apply(i->arg.obj, nil, new(pObject), nil, nil);
|
|
frame.pc = (nil == result) ? i->ko : i->ok;
|
|
continue;
|
|
}
|
|
case RULE2: {
|
|
i->op = CALL2;
|
|
i->arg.code = vmCacheGet(i->arg2.obj, i->arg.obj);
|
|
goto doCall2; // (just in case they are not consecutive ;-))
|
|
case CALL2: { doCall2:
|
|
frame.pc--; // save pc of call insn
|
|
push(r, frame);
|
|
frame.grammar = i->arg2.obj;
|
|
frame.code = i->arg.code;
|
|
frame.pc = 0;
|
|
saveAction(vmEnter, nil, 0, 0);
|
|
frame.nactions = context.nactions;
|
|
continue;
|
|
}
|
|
goto doCall;
|
|
}
|
|
case RULE: {
|
|
// frame.pc--; // save pc of call insn
|
|
// push(r, frame);
|
|
// frame.code = vmCacheGet(grammar, i->arg.obj);
|
|
// frame.pc = 0;
|
|
// if (((Node *)(i->arg))->Symbol.nvars) {
|
|
// saveAction(enter, i->arg, 0, 0);
|
|
// frame.nactions = context.nactions;
|
|
// }
|
|
// continue;
|
|
//i->op = CALL;
|
|
//i->arglen = ((Node *)i->arg)->Symbol.nvars;
|
|
//i->arg = ((Node *)i->arg)->Symbol.code; assert(i->arg);
|
|
i->op = CALL;
|
|
i->arg.code = vmCacheGet(frame.grammar, i->arg.obj);
|
|
goto doCall; // (just in case they are not consecutive ;-))
|
|
}
|
|
case CALL: { doCall:
|
|
frame.pc--; // save pc of call insn
|
|
push(r, frame);
|
|
frame.code = i->arg.code;
|
|
frame.pc = 0;
|
|
saveAction(vmEnter, nil, 0, 0);
|
|
frame.nactions = context.nactions;
|
|
continue;
|
|
}
|
|
case SUCCEED: {
|
|
if (frame.nactions == context.nactions) // no actions were added
|
|
context.nactions--; // remove the enter action
|
|
else
|
|
saveAction(vmLeave, nil, 0, 0);
|
|
if (rsp) {
|
|
frame = pop(r);
|
|
i = frame.code + frame.pc;
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
result = context.position - start;
|
|
break;
|
|
}
|
|
case FAIL: {
|
|
if (rsp) {
|
|
context.nactions = frame.nactions - 1; // remove all actions added by this rule
|
|
frame = pop(r);
|
|
i = frame.code + frame.pc;
|
|
frame.pc = i->ko;
|
|
continue;
|
|
}
|
|
else {
|
|
context.nactions = 0;
|
|
}
|
|
result = -1;
|
|
break;
|
|
}
|
|
case ACTION: {
|
|
// printf("--> ACTION %d [%d %d]\n", context.nactions, textbeg, textend);
|
|
saveAction(vmAction, i->arg.obj, textbeg, textend - textbeg);
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
case BEGIN: {
|
|
textbeg = textend = context.position;
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
case END: {
|
|
textend = context.position;
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
case UNEND: {
|
|
textbeg = textend = 0;
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
case SET: {
|
|
saveAction(vmSet, i->arg.obj, 0, 0);
|
|
frame.pc = i->ok;
|
|
continue;
|
|
}
|
|
default: {
|
|
fatal("this cannot happen %d", i->op);
|
|
break;
|
|
}
|
|
}
|
|
break;
|
|
}
|
|
|
|
saveAction(vmLeave, nil, 0, 0);
|
|
|
|
#undef pop
|
|
#undef drop
|
|
#undef push
|
|
|
|
xfree(cstack);
|
|
xfree(rstack);
|
|
|
|
for (int i = 0; i < context.nactions; ++i) {
|
|
char *yytext = text + actions[i].textbeg;
|
|
int yyleng = actions[i].textlen;
|
|
// printf("==> ACTION %d [%d %d]\n", i, actions[i].textbeg, actions[i].textbeg + actions[i].textlen);
|
|
actions[i].function(&state, actions[i].object, yytext, yyleng);
|
|
}
|
|
|
|
vmCache = nil;
|
|
return result;
|
|
}
|
|
|
|
oop prim_match(oop func, oop self, oop args, oop env)
|
|
{
|
|
oop grammar = getArg (args, 0, "__match__");
|
|
oop symbol = getArgType(args, 1, Symbol, "__match__");
|
|
oop string = getArgType(args, 2, String, "__match__");
|
|
int start = _integerValue(getArgType(args, 3, Integer, "__match__"));
|
|
|
|
char *text = get(string, String,value);
|
|
int length = get(string, String,length);
|
|
oop program = Object_get(grammar, symbol);
|
|
|
|
int result = vmRun(grammar, symbol, text, start, length);
|
|
|
|
return newInteger(result);
|
|
}
|
|
|
|
#endif // PEGVM
|
|
|
|
oop replFile(FILE *in)
|
|
{
|
|
int oldline = lineno;
|
|
lineno = 1;
|
|
input = newInput();
|
|
readFile(in, &input->text, &input->size);
|
|
oop result = nil;
|
|
# if NONLOCAL
|
|
switch (nlrPush()) {
|
|
case NLR_CONTINUE: syntaxError("continue outside loop");
|
|
case NLR_BREAK: syntaxError("break outside loop");
|
|
case NLR_RETURN: syntaxError("return outside function");
|
|
case NLR_RAISE: {
|
|
if (!is(Object, valnlr)) fatal("%s%s",
|
|
is(String, valnlr) ? "" : "unhandled exception: ",
|
|
printString(valnlr, 1));
|
|
oop msg = newStringLen(0, 0);
|
|
if (Object_find(valnlr, prop_function) >= 0) {
|
|
String_push(msg, Object_get(valnlr, prop_function));
|
|
String_appendAll(msg, ": ");
|
|
}
|
|
if (Object_find(valnlr, prop_kind) >= 0)
|
|
String_push(msg, Object_get(valnlr, prop_kind));
|
|
else
|
|
String_appendAll(msg, "unhandled exception");
|
|
if (Object_find(valnlr, prop_message) >= 0) {
|
|
String_appendAll(msg, ": ");
|
|
String_push(msg, Object_get(valnlr, prop_message));
|
|
}
|
|
int size = _get(valnlr, Object,psize);
|
|
struct property *kvs = _get(valnlr, Object,properties);
|
|
if (size) String_appendAll(msg, ": ");
|
|
int n = 0;
|
|
for (int i = 0; i < size; ++i) {
|
|
if (isSpecial(kvs[i].key)) continue;
|
|
if (n++) String_appendAll(msg, ", ");
|
|
String_push(msg, kvs[i].key);
|
|
String_appendAll(msg, " = ");
|
|
storeOn(msg, kvs[i].val, 0);
|
|
}
|
|
String_appendAll(msg, ":");
|
|
if (Object_find(valnlr, sym_message) >= 0) {
|
|
String_append(msg, ' ');
|
|
String_push(msg, Object_get(valnlr, sym_message));
|
|
}
|
|
size = _get(valnlr, Object,isize);
|
|
oop *elts = _get(valnlr, Object,indexed);
|
|
int w = 2 + log10(size);
|
|
for (int i = size; i--;) {
|
|
String_format(msg, "\n%*d: ", w, i);
|
|
codeOn(msg, elts[i], 0);
|
|
}
|
|
trace = nil;
|
|
fatal(String_content(msg));
|
|
}
|
|
}
|
|
# endif
|
|
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);
|
|
}
|
|
}
|
|
# if NONLOCAL
|
|
nlrPop();
|
|
# endif
|
|
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;
|
|
}
|
|
|
|
void cleanup(void)
|
|
{
|
|
# if PROFILE
|
|
if (opt_p) profileReport();
|
|
# endif
|
|
}
|
|
|
|
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
|
|
|
|
primitives = new(pObject);
|
|
|
|
_set(intern("__primitives__"), Symbol,value, primitives);
|
|
|
|
Object_put(pObject, prop_eval, newPrimitive(prim___eval__, newString("Object.__eval__"))); // inherited by all objects
|
|
|
|
#if TYPECODES
|
|
|
|
# define defineEvaluator(NAME) \
|
|
_set(intern(#NAME), Symbol,typecode, t##NAME);
|
|
|
|
# undef defineEvaluator
|
|
|
|
#endif // !TYPECODES
|
|
|
|
# define defineEvaluator(NAME) \
|
|
Object_put(p##NAME, prop_eval, newPrimitive(prim_##NAME##_eval, newString(#NAME".__eval__")));
|
|
|
|
doProtos(defineEvaluator);
|
|
|
|
# undef defineEvaluator
|
|
|
|
# define defineCodeOn(NAME) \
|
|
Object_put(p##NAME, prop_codeon, newPrimitive(prim_##NAME##_codeOn, newString(#NAME".codeOn")));
|
|
|
|
doProtos(defineCodeOn);
|
|
|
|
# undef defineCodeOn
|
|
|
|
macros = Object_put(pSymbol, intern("macros"), new(pObject));
|
|
|
|
# define prim(NAME, FUNC) _set(intern(#NAME), Symbol,value, newPrimitive(FUNC, newString(#NAME)))
|
|
|
|
prim(__env__ , prim_env);
|
|
prim(eval , prim_eval);
|
|
prim(print , prim_print);
|
|
prim(codeString , prim_codeString);
|
|
prim(sqrt , prim_sqrt);
|
|
prim(round , prim_round);
|
|
prim(truncate , prim_truncate);
|
|
prim(cputime , prim_cputime);
|
|
prim(evaluations, prim_evaluations);
|
|
prim(len , prim_len);
|
|
prim(ord , prim_ord);
|
|
prim(chr , prim_chr);
|
|
prim(readfile , prim_readfile);
|
|
prim(exit , prim_exit);
|
|
prim(error , prim_error);
|
|
prim(defined , prim_defined);
|
|
prim(__extern__ , prim_extern);
|
|
prim(__match__ , prim_match);
|
|
|
|
# undef prim
|
|
|
|
primitiveExternalCall = newPrimitive(prim_externalCall, newString("externalCall"));
|
|
|
|
# define method(CLASS, NAME, FUNC) Object_put(p##CLASS, intern(#NAME), newPrimitive(FUNC, newString(#CLASS"."#NAME)))
|
|
|
|
method(Object,new, prim_Object_new );
|
|
method(Object,initialise, prim_Object_initialise );
|
|
method(Object,push, prim_Object_push );
|
|
method(Object,pop, prim_Object_pop );
|
|
method(Object,length, prim_length );
|
|
method(Object,keys, prim_keys );
|
|
method(Object,allKeys, prim_allKeys );
|
|
method(Object,findKey, prim_findKey );
|
|
method(Object,sorted, prim_sorted );
|
|
method(Object,reversed, prim_reversed );
|
|
method(Object,includes, prim_Object_includes );
|
|
method(String,new, prim_String_new );
|
|
method(String,escaped, prim_String_escaped );
|
|
method(String,unescaped, prim_String_unescaped );
|
|
method(String,push, prim_String_push );
|
|
method(String,pop, prim_String_pop );
|
|
method(String,asInteger, prim_String_asInteger );
|
|
method(String,asFloat, prim_String_asFloat );
|
|
method(String,asSymbol, prim_String_asSymbol );
|
|
method(String,includes, prim_String_includes );
|
|
method(String,sliced, prim_String_sliced );
|
|
method(String,bitSet, prim_String_bitSet );
|
|
method(String,bitClear, prim_String_bitClear );
|
|
method(String,bitInvert, prim_String_bitInvert );
|
|
method(String,bitTest, prim_String_bitTest );
|
|
method(String,charClass, prim_String_charClass );
|
|
method(String,compareFrom, prim_String_compareFrom );
|
|
method(String,intAt, prim_String_intAt );
|
|
method(Symbol,asString, prim_Symbol_asString );
|
|
method(Symbol,setopt, prim_Symbol_setopt );
|
|
method(Symbol,getopt, prim_Symbol_getopt );
|
|
method(Symbol,defined, prim_Symbol_defined );
|
|
method(Symbol,define, prim_Symbol_define );
|
|
method(Symbol,value, prim_Symbol_value );
|
|
method(Symbol,allInstances, prim_Symbol_allInstances);
|
|
|
|
# undef method
|
|
|
|
namespaces = _set(sym___namespaces__, Symbol,value, new(pObject));
|
|
|
|
trace = new(pObject);
|
|
|
|
oop args = new(pObject);
|
|
_set(intern("__argv__"), Symbol,value, args);
|
|
|
|
signal(SIGINT, sigint);
|
|
|
|
int argn = 1;
|
|
|
|
while (argn < argc) {
|
|
char *arg = argv[argn];
|
|
if ('-' != *arg) break;
|
|
while (*++arg) {
|
|
switch (*arg) {
|
|
case 'O': ++opt_O; continue;
|
|
case 'd': ++opt_d, ++opt_v; continue;
|
|
case 'p': ++opt_p; continue;
|
|
case 'v': ++opt_v; continue;
|
|
default: fatal("unknown command-line option '%c'", *arg);
|
|
}
|
|
}
|
|
++argn;
|
|
}
|
|
|
|
for (int i = argn; i < argc; ++i)
|
|
Object_push(args, newString(argv[i]));
|
|
|
|
atexit(cleanup);
|
|
|
|
if (argn == argc)
|
|
replFile(stdin);
|
|
else
|
|
replPath(argv[argn]);
|
|
|
|
return 0;
|
|
}
|
|
|
|
// Local Variables:
|
|
// eval: (setq indent-tabs-mode nil)
|
|
// eval: (untabify (point-min) (point-max))
|
|
// End:
|