FObject VectorToList(FObject vec)
{
FAssert(VectorP(vec));
FObject lst = EmptyListObject;
for (int_t idx = (int_t) VectorLength(vec) - 1; idx >= 0; idx--)
lst = MakePair(AsVector(vec)->Vector[idx], lst);
return(lst);
}
bool CLispEng::StringP(CP p) {
if (!VectorP(p))
return false;
switch (AsArray(p)->GetElementType()) {
case ELTYPE_CHARACTER:
case ELTYPE_BASECHAR:
return true;
}
return false;
}
void CLispEng::Print(ostream& os, CP form) {
form &= ~FLAG_Mark;
//!!! os << "<" << (void*)form << ">";
os << String(' ', m_printIndent*2);
switch (Type(form)) {
/*!!! case TS_NIL:
os << "NIL";
break;*/
case TS_CHARACTER:
{
os << "#\\";
wchar_t ch = AsChar(form);
switch (ch) {
case '\0': os << "NULL"; break;
case '\a': os << "BELL"; break;
case '\b': os << "BS"; break;
case '\t': os << "TAB"; break;
case '\n': os << "NL"; break;
case '\r': os << "CR"; break;
case '\f': os << "FF"; break;
case '\x1B': os << "ESC"; break;
case '\x7F': os << "RUBOUT"; break;
default: os << (char)ch; break; //!!!
}
}
break;
case TS_FIXNUM:
os << AsNumber(form);
break;
case TS_FRAME_PTR:
os << "#<FRAME " << (DWORD)AsIndex(form) << ">";
break;
case TS_FRAMEINFO:
os << "#<FRAMEINFO>";
break;
case TS_BIGNUM:
os << ToBigInteger(form);
break;
case TS_FLONUM:
os << AsFloatVal(form);
break;
case TS_SYMBOL:
{
//!!! Print(get_Special(L_S_PACKAGE));//!!!D
CSymbolValue *sv = ToSymbol(form);
if (sv->HomePackage == m_packKeyword)
os << ':';
else if (!sv->HomePackage)
os << "#:";
/*!!! else if (!ToPackage(get_Special(L_S_PACKAGE))->IsPresent(form))
{
CPackage *pack = ToPackage(sv->HomePackage);
os << pack->m_name << ':';
if (pack->m_mapExternalSym.find(sv) == pack->m_mapExternalSym.end())
os << ':';
}*/
#if UCFG_LISP_SPLIT_SYM
os << SymNameByIdx(AsIndex(form));
#else
os << sv->m_s;
#endif
}
break;
case TS_PATHNAME:
os << "#P\"" << AsPathname(form)->ToString() << "\"";
break;
case TS_RATIO:
Print(os, AsRatio(form)->m_numerator);
os << "/";
Print(os, AsRatio(form)->m_denominator);
break;//!!!
case TS_MACRO:
os << "#<MACRO>";
break;
case TS_COMPLEX:
os << "#C()"; //!!!
break;
case TS_CONS:
switch (form) {
case 0:
os << "NIL";
break;
case V_U:
os << "#<UNBOUND>";
break;
default:
CSPtr car = Car(form),
cdr = Cdr(form);
if (car == S(L_QUOTE)) {
if (ConsP(cdr)) {
os << "\'";
Print(os, Car(cdr));
break;
}
}
if (car == S(L_BACKQUOTE)) {
os << "`";
Print(os, Car(cdr));
} else if (car == S(L_UNQUOTE)) {
os << ",";
Print(os, Car(cdr));
} else if (car == S(L_SPLICE)) {
os << ",@";
Print(os, Car(cdr));
} else {
os << "(";
PrintList(os, form);
os << ")";
}
}
break;
case TS_STRUCT:
os << "#<STRUCT " << (DWORD)AsIndex(form) << ">";
break;
case TS_STREAM:
os << "#<STREAM " << (DWORD)AsIndex(form) << ">";
break;
case TS_WEAKPOINTER:
os << "<#WEAKPOINTER ";
Print(os, ToWeakPointer(form)->m_p);
os << ">";
break;
case TS_SUBR:
case TS_INTFUNC:
case TS_CCLOSURE:
{
os << "#\'";
Push(m_r);
pair<CP, CP> pp = GetFunctionName(form);
Print(os, pp.second);
m_r = Pop();
}
break;
case TS_PACKAGE:
os << "#<PACKAGE " << ToPackage(form)->m_name << ">";
break;
case TS_READTABLE:
os << "#<READTABLE>";
break;
case TS_HASHTABLE:
{
os << "#S(HASH-TABLE <fun>";
CHashMap& m = *Lisp().ToHashTable(form)->m_pMap;
for (CHashMap::iterator i=m.begin(); i!=m.end(); ++i) {
os << "(";
Print(os, i->first);
os << " . ";
Print(os, i->second);
os << ")";
}
os << ">";
}
break;
case TS_ARRAY:
if (StringP(form))
os << "\"" << AsString(form) << "\"";
else if (VectorP(form)) {
os << "#(";
CArrayValue *av = ToArray(form);
for (size_t i=0; i<av->GetVectorLength(); i++) {
if (i)
os << " ";
Print(os, av->GetElement(i));
}
os << ")";
} else {
CArrayValue *av = ToArray(form);
os << "<ARRAY " << (DWORD)av->TotalSize() << ">";
//!!!
/*!!! os << "#(";
for (int i=0; i<vv->m_count-1; i++)
{
Print(vv->m_pData[i]);
os << " ";
}
os << ")";*/
}
break;
case TS_OBJECT:
{
os << "#<OBJECT ";
//!!! Print(ToObject(form)->m_class);
os << " ";
//!!! Print(ToObject(form)->m_slots);
os << ">";
}
break;
case TS_SYMBOLMACRO:
{
os << "#<SYMBOL-MACRO ";
CSymbolMacro *sm = ToSymbolMacro(form);
Print(os, sm->m_macro);
os << ">";
}
break;
#if UCFG_LISP_FFI
case TS_FF_PTR:
os << "#<POINTER " << ToPointer(form) << ">";
break;
#endif
default:
os << "#<Bad Form>";
//!!! Ext::Throw(E_FAIL);
}
}
static FObject CompileEvalExpr(FObject obj, FObject env, FObject body)
{
if (VectorP(obj))
return(MakePair(SyntaxToDatum(obj), body));
else if (PairP(obj) && (IdentifierP(First(obj)) || SymbolP(First(obj))))
{
if (EqualToSymbol(First(obj), R.DefineLibrarySymbol))
{
CompileLibrary(obj);
return(body);
}
else if (EqualToSymbol(First(obj), R.ImportSymbol))
{
EnvironmentImport(env, obj);
if (body != EmptyListObject)
body = MakePair(List(R.NoValuePrimitive), body);
return(body);
}
// FObject op = EnvironmentGet(env, First(obj));
FObject op = ResolvedGet(env, First(obj));
if (op == DefineSyntax)
{
// (define <variable> <expression>)
// (define <variable>)
// (define (<variable> <formals>) <body>)
// (define (<variable> . <formal>) <body>)
FAssert(EnvironmentP(env));
if (AsEnvironment(env)->Immutable == TrueObject)
RaiseExceptionC(R.Assertion, "define",
"environment is immutable", List(env, obj));
if (PairP(Rest(obj)) == 0)
RaiseExceptionC(R.Syntax, "define",
"expected a variable or list beginning with a variable", List(obj));
if (IdentifierP(First(Rest(obj))) || SymbolP(First(Rest(obj))))
{
if (Rest(Rest(obj)) == EmptyListObject)
{
// (define <variable>)
if (EnvironmentDefine(env, First(Rest(obj)), NoValueObject))
RaiseExceptionC(R.Syntax, "define",
"imported variables may not be redefined in libraries",
List(First(Rest(obj)), obj));
return(body);
}
// (define <variable> <expression>)
if (PairP(Rest(Rest(obj))) == 0 || Rest(Rest(Rest(obj))) != EmptyListObject)
RaiseExceptionC(R.Syntax, "define",
"expected (define <variable> <expression>)", List(obj));
if (EnvironmentDefine(env, First(Rest(obj)), NoValueObject))
RaiseExceptionC(R.Syntax, "define",
"imported variables may not be redefined in libraries",
List(First(Rest(obj)), obj));
return(MakePair(List(SetBangSyntax, First(Rest(obj)),
First(Rest(Rest(obj)))), body));
}
else
{
// (define (<variable> <formals>) <body>)
// (define (<variable> . <formal>) <body>)
if (PairP(First(Rest(obj))) == 0 || (IdentifierP(First(First(Rest(obj)))) == 0
&& SymbolP(First(First(Rest(obj)))) == 0))
RaiseExceptionC(R.Syntax, "define",
"expected a list beginning with a variable", List(obj));
if (EnvironmentDefine(env, First(First(Rest(obj))),
CompileLambda(env, First(First(Rest(obj))), Rest(First(Rest(obj))),
Rest(Rest(obj)))))
RaiseExceptionC(R.Syntax, "define",
"imported variables may not be redefined in libraries",
List(First(First(Rest(obj))), obj));
return(body);
}
}
else if (op == DefineValuesSyntax)
{
// (define-values (<variable> ...) <expression>)
FAssert(EnvironmentP(env));
if (AsEnvironment(env)->Immutable == TrueObject)
RaiseExceptionC(R.Assertion, "define-values",
"environment is immutable", List(env, obj));
if (PairP(Rest(obj)) == 0
|| (PairP(First(Rest(obj))) == 0 && First(Rest(obj)) != EmptyListObject)
|| PairP(Rest(Rest(obj))) == 0 || Rest(Rest(Rest(obj))) != EmptyListObject)
RaiseExceptionC(R.Syntax, "define-values",
"expected (define-values (<variable> ...) <expression>)", List(obj));
FObject lst = First(Rest(obj));
while (PairP(lst))
{
if (IdentifierP(First(lst)) == 0 && SymbolP(First(lst)) == 0)
RaiseExceptionC(R.Syntax, "define-values",
"expected (define-values (<variable> ...) <expression>)",
List(First(lst), obj));
if (EnvironmentDefine(env, First(lst), NoValueObject))
RaiseExceptionC(R.Syntax, "define-values",
"imported variables may not be redefined in libraries",
List(First(lst), obj));
lst = Rest(lst);
}
if (lst != EmptyListObject)
RaiseExceptionC(R.Syntax, "define-values", "expected a list of variables",
List(obj));
return(MakePair(List(SetBangValuesSyntax, First(Rest(obj)), First(Rest(Rest(obj)))),
body));
}
else if (op == DefineSyntaxSyntax)
{
// (define-syntax <keyword> <expression>)
FAssert(EnvironmentP(env));
if (AsEnvironment(env)->Immutable == TrueObject)
RaiseExceptionC(R.Assertion, "define",
"environment is immutable", List(env, obj));
if (PairP(Rest(obj)) == 0 || PairP(Rest(Rest(obj))) == 0
|| Rest(Rest(Rest(obj))) != EmptyListObject
|| (IdentifierP(First(Rest(obj))) == 0 && SymbolP(First(Rest(obj))) == 0))
RaiseExceptionC(R.Syntax, "define-syntax",
"expected (define-syntax <keyword> <transformer>)",
List(obj));
FObject trans = CompileTransformer(First(Rest(Rest(obj))), env);
if (SyntaxRulesP(trans) == 0)
RaiseExceptionC(R.Syntax, "define-syntax",
"expected a transformer", List(trans, obj));
if (EnvironmentDefine(env, First(Rest(obj)), trans))
RaiseExceptionC(R.Syntax, "define",
"imported variables may not be redefined in libraries",
List(First(Rest(obj)), obj));
return(body);
}
else if (SyntaxRulesP(op))
return(CompileEvalExpr(ExpandSyntaxRules(MakeSyntacticEnv(env), op, Rest(obj)), env,
body));
else if (op == BeginSyntax)
return(CompileEvalBegin(Rest(obj), env, body, obj, BeginSyntax));
else if (op == IncludeSyntax || op == IncludeCISyntax)
return(CompileEvalBegin(ReadInclude(First(obj), Rest(obj), op == IncludeCISyntax), env,
body, obj, op));
else if (op == CondExpandSyntax)
{
FObject ce = CondExpand(MakeSyntacticEnv(env), obj, Rest(obj));
if (ce == EmptyListObject)
return(body);
return(CompileEvalBegin(ce, env, body, obj, op));
}
}
return(MakePair(obj, body));
}
