void EnvironmentImportLibrary(FObject env, FObject nam)
{
FAssert(EnvironmentP(env));
FAssert(AsEnvironment(env)->Interactive == TrueObject);
FObject lib = FindLibrary(nam);
FAssert(LibraryP(lib));
FObject elst = AsLibrary(lib)->Exports;
while (PairP(elst))
{
FAssert(PairP(First(elst)));
FAssert(SymbolP(First(First(elst))));
FAssert(GlobalP(Rest(First(elst))));
#ifdef FOMENT_DEBUG
int_t ret =
#endif // FOMENT_DEBUG
EnvironmentImportGlobal(env,
ImportGlobal(env, First(First(elst)), Rest(First(elst))));
FAssert(ret == 0);
elst = Rest(elst);
}
FAssert(elst == EmptyListObject);
}
int_t ListLength(FObject lst)
{
int_t ll = 0;
FObject fst = lst;
FObject slw = lst;
for (;;)
{
if (fst == EmptyListObject)
break;
if (PairP(fst) == 0)
return(-1);
fst = Rest(fst);
ll += 1;
if (fst == EmptyListObject)
break;
if (PairP(fst) == 0 || fst == slw)
return(-1);
fst = Rest(fst);
ll += 1;
FAssert(PairP(slw));
slw = Rest(slw);
if (fst == slw)
return(-1);
}
return(ll);
}
static FObject CheckForRename(FObject nam, FObject rlst)
{
FAssert(SymbolP(nam));
while (PairP(rlst))
{
FObject rnm = First(rlst);
FAssert(PairP(rnm));
FAssert(PairP(Rest(rnm)));
if (SymbolP(First(rnm)))
{
FAssert(SymbolP(First(Rest(rnm))));
if (nam == First(rnm))
return(First(Rest(rnm)));
}
else
{
FAssert(IdentifierP(First(rnm)));
FAssert(IdentifierP(First(Rest(rnm))));
if (nam == AsIdentifier(First(rnm))->Symbol)
return(AsIdentifier(First(Rest(rnm)))->Symbol);
}
rlst = Rest(rlst);
}
FAssert(rlst == EmptyListObject);
return(NoValueObject);
}
static FObject CompileLibraryCode(FObject env, FObject lst)
{
FObject body = EmptyListObject;
while (PairP(lst))
{
FAssert(PairP(First(lst)));
FAssert(IdentifierP(First(First(lst))) || SymbolP(First(First(lst))));
FObject form = First(lst);
if (EqualToSymbol(First(form), R.BeginSymbol)
|| EqualToSymbol(First(form), R.IncludeSymbol)
|| EqualToSymbol(First(form), R.IncludeCISymbol))
body = CompileEvalExpr(form, env, body);
else
{
FAssert(EqualToSymbol(First(form), R.ImportSymbol)
|| EqualToSymbol(First(form), R.IncludeLibraryDeclarationsSymbol)
|| EqualToSymbol(First(form), R.CondExpandSymbol)
|| EqualToSymbol(First(form), R.ExportSymbol)
|| EqualToSymbol(First(form), R.AkaSymbol));
}
lst = Rest(lst);
}
FAssert(lst == EmptyListObject);
if (body == EmptyListObject)
return(NoValueObject);
return(CompileLambda(env, NoValueObject, EmptyListObject, ReverseListModify(body)));
}
static FObject DoOnlyOrExcept(FObject env, FObject is, int_t cfif)
{
if (PairP(Rest(is)) == 0)
return(NoValueObject);
FObject ilst = DoImportSet(env, First(Rest(is)), is);
FObject ids = Rest(Rest(is));
while (PairP(ids))
{
if (IdentifierP(First(ids)) == 0 && SymbolP(First(ids)) == 0)
return(NoValueObject);
ids = Rest(ids);
}
if (ids != EmptyListObject)
return(NoValueObject);
FObject nlst = EmptyListObject;
while (PairP(ilst))
{
FAssert(GlobalP(First(ilst)));
if (CheckForIdentifier(AsGlobal(First(ilst))->Name, Rest(Rest(is))) == cfif)
nlst = MakePair(First(ilst), nlst);
ilst = Rest(ilst);
}
FAssert(ilst == EmptyListObject);
return(nlst);
}
static FObject LoadLibrary(FObject nam)
{
FDontWait dw;
FObject lp = R.LibraryPath;
while (PairP(lp))
{
FAssert(StringP(First(lp)));
FObject le = R.LibraryExtensions;
while (PairP(le))
{
FAssert(StringP(First(le)));
FObject libfn = LibraryNameFlat(First(lp), nam, First(le));
FObject port = OpenInputFile(libfn);
if (TextualPortP(port) == 0)
{
libfn = LibraryNameDeep(First(lp), nam, First(le));
port = OpenInputFile(libfn);
}
if (TextualPortP(port))
{
WantIdentifiersPort(port, 1);
for (;;)
{
FObject obj = Read(port);
if (obj == EndOfFileObject)
break;
if (PairP(obj) == 0 || EqualToSymbol(First(obj), R.DefineLibrarySymbol) == 0)
RaiseExceptionC(R.Syntax, "define-library", "expected a library",
List(libfn, obj));
CompileLibrary(obj);
}
}
FObject lib = FindLibrary(nam);
if (LibraryP(lib))
return(lib);
le = Rest(le);
}
lp = Rest(lp);
}
FAssert(lp == EmptyListObject);
return(NoValueObject);
}
static void EnvironmentImport(FObject env, FObject form)
{
// (import <import-set> ...)
FAssert(PairP(form));
FObject islst = Rest(form);
while (PairP(islst))
{
EnvironmentImportSet(env, First(islst), form);
islst = Rest(islst);
}
FAssert(islst == EmptyListObject);
}
static int_t CheckForIdentifier(FObject nam, FObject ids)
{
FAssert(SymbolP(nam));
while (PairP(ids))
{
if (SymbolP(First(ids)))
{
if (First(ids) == nam)
return(1);
}
else
{
FAssert(IdentifierP(First(ids)));
if (AsIdentifier(First(ids))->Symbol == nam)
return(1);
}
ids = Rest(ids);
}
FAssert(ids == EmptyListObject);
return(0);
}
inline FObject CurrentOutputPort()
{
FAssert(PairP(IndexParameter(INDEX_PARAMETER_CURRENT_OUTPUT_PORT)));
FObject port = First(IndexParameter(INDEX_PARAMETER_CURRENT_OUTPUT_PORT));
FAssert(OutputPortP(port) && OutputPortOpenP(port));
return(port);
}
static FObject CompileAkas(FObject env, FObject lst)
{
FObject akalst = EmptyListObject;
while (PairP(lst))
{
FAssert(PairP(First(lst)));
FAssert(IdentifierP(First(First(lst))) || SymbolP(First(First(lst))));
FObject form = First(lst);
if (EqualToSymbol(First(form), R.AkaSymbol))
{
if (PairP(Rest(form)) == 0 || Rest(Rest(form)) != EmptyListObject)
RaiseExceptionC(R.Syntax, "aka", "expected (aka <library-name>)", List(form));
FObject ln = LibraryName(First(Rest(form)));
if (PairP(ln) == 0)
RaiseExceptionC(R.Syntax, "aka",
"library name must be a list of symbols and/or integers",
List(First(Rest(form))));
akalst = MakePair(ln, akalst);
}
else
{
FAssert(EqualToSymbol(First(form), R.ImportSymbol)
|| EqualToSymbol(First(form), R.ExportSymbol)
|| EqualToSymbol(First(form), R.IncludeLibraryDeclarationsSymbol)
|| EqualToSymbol(First(form), R.CondExpandSymbol)
|| EqualToSymbol(First(form), R.BeginSymbol)
|| EqualToSymbol(First(form), R.IncludeSymbol)
|| EqualToSymbol(First(form), R.IncludeCISymbol));
}
lst = Rest(lst);
}
FAssert(lst == EmptyListObject);
return(akalst);
}
static FObject CompileTransformer(FObject obj, FObject env)
{
if (PairP(obj) == 0 || (IdentifierP(First(obj)) == 0 && SymbolP(First(obj)) == 0))
return(NoValueObject);
FObject op = EnvironmentGet(env, First(obj));
if (op == SyntaxRulesSyntax)
return(CompileSyntaxRules(MakeSyntacticEnv(env), obj));
return(NoValueObject);
}
FObject MakePair(FObject first, FObject rest)
{
FPair * pair = (FPair *) MakeObject(sizeof(FPair), PairTag);
pair->First = first;
pair->Rest = rest;
FObject obj = PairObject(pair);
FAssert(PairP(obj));
FAssert(AsPair(obj) == pair);
return(obj);
}
static FObject ExpandLibraryDeclarations(FObject env, FObject lst, FObject body)
{
while (PairP(lst))
{
if (PairP(First(lst)) == 0 || (IdentifierP(First(First(lst))) == 0
&& SymbolP(First(First(lst))) == 0))
RaiseExceptionC(R.Syntax, "define-library",
"expected a library declaration", List(First(lst)));
FObject form = First(lst);
if (EqualToSymbol(First(form), R.ImportSymbol))
EnvironmentImport(env, form);
else if (EqualToSymbol(First(form), R.IncludeLibraryDeclarationsSymbol))
body = ExpandLibraryDeclarations(env, ReadInclude(First(form), Rest(form), 0), body);
else if (EqualToSymbol(First(form), R.CondExpandSymbol))
{
FObject ce = CondExpand(MakeSyntacticEnv(R.Bedrock), form, Rest(form));
if (ce != EmptyListObject)
body = ExpandLibraryDeclarations(env, ce , body);
}
else if (EqualToSymbol(First(form), R.ExportSymbol) == 0
&& EqualToSymbol(First(form), R.AkaSymbol) == 0
&& EqualToSymbol(First(form), R.BeginSymbol) == 0
&& EqualToSymbol(First(form), R.IncludeSymbol) == 0
&& EqualToSymbol(First(form), R.IncludeCISymbol) == 0)
RaiseExceptionC(R.Syntax, "define-library",
"expected a library declaration", List(First(lst)));
else
body = MakePair(form, body);
lst = Rest(lst);
}
if (lst != EmptyListObject)
RaiseExceptionC(R.Syntax, "define-library",
"expected a proper list of library declarations", List(lst));
return(body);
}
static FObject CondExpandProgram(FObject lst, FObject prog)
{
while (lst != EmptyListObject)
{
FAssert(PairP(lst));
FObject obj = First(lst);
if (PairP(obj) && EqualToSymbol(First(obj), R.CondExpandSymbol))
{
FObject ce = CondExpand(MakeSyntacticEnv(R.Bedrock), obj, Rest(obj));
if (ce != EmptyListObject)
prog = CondExpandProgram(ce, prog);
}
else
prog = MakePair(obj, prog);
lst = Rest(lst);
}
return(prog);
}
static FObject CompileEvalBegin(FObject obj, FObject env, FObject body, FObject form, FObject ss)
{
if (PairP(obj) == 0)
{
if (ss == BeginSyntax)
return(body);
RaiseExceptionC(R.Syntax, SpecialSyntaxToName(ss),
"expected at least one expression", List(form));
}
while (PairP(obj))
{
body = CompileEvalExpr(First(obj), env, body);
obj = Rest(obj);
}
if (obj != EmptyListObject)
RaiseExceptionC(R.Syntax, SpecialSyntaxToName(ss),
"expected a proper list", List(form));
return(body);
}
void CompileLibrary(FObject expr)
{
if (PairP(Rest(expr)) == 0)
RaiseExceptionC(R.Syntax, "define-library", "expected a library name",
List(expr));
FObject ln = LibraryName(First(Rest(expr)));
if (PairP(ln) == 0)
RaiseExceptionC(R.Syntax, "define-library",
"library name must be a list of symbols and/or integers", List(First(Rest(expr))));
FObject env = MakeEnvironment(ln, FalseObject);
FObject body = ReverseListModify(ExpandLibraryDeclarations(env, Rest(Rest(expr)),
EmptyListObject));
FObject proc = CompileLibraryCode(env, body);
FObject exports = CompileExports(env, body);
FObject akalst = CompileAkas(env, body);
UndefinedList = EmptyListObject;
EqHashMapVisit(AsEnvironment(env)->HashMap, Visit, NoValueObject);
if (UndefinedList != EmptyListObject)
RaiseExceptionC(R.Syntax, "define-library", "identifier(s) used but never defined",
List(UndefinedList, expr));
FObject lib = MakeLibrary(ln, exports, proc);
while (akalst != EmptyListObject)
{
FAssert(PairP(akalst));
FAssert(LibraryP(lib));
MakeLibrary(First(akalst), AsLibrary(lib)->Exports, NoValueObject);
akalst = Rest(akalst);
}
}
FObject ReverseListModify(FObject list)
{
FObject rlist = EmptyListObject;
while (list != EmptyListObject)
{
FAssert(PairP(list));
FObject obj = list;
list = Rest(list);
// AsPair(obj)->Rest = rlist;
SetRest(obj, rlist);
rlist = obj;
}
return(rlist);
}
void EnvironmentImportSet(FObject env, FObject is, FObject form)
{
FObject ilst = DoImportSet(env, is, form);
while (PairP(ilst))
{
FAssert(GlobalP(First(ilst)));
if (EnvironmentImportGlobal(env, First(ilst)))
RaiseExceptionC(R.Syntax, "import", "expected an undefined identifier",
List(AsGlobal(First(ilst))->Name, form));
ilst = Rest(ilst);
}
FAssert(ilst == EmptyListObject);
}
static FObject FindLibrary(FObject nam)
{
FObject ll = R.LoadedLibraries;
while (PairP(ll))
{
FAssert(LibraryP(First(ll)));
if (EqualP(AsLibrary(First(ll))->Name, nam))
return(First(ll));
ll = Rest(ll);
}
FAssert(ll == EmptyListObject);
return(NoValueObject);
}
FObject LibraryName(FObject lst)
{
FObject nlst = EmptyListObject;
while (PairP(lst))
{
if (IdentifierP(First(lst)) == 0 && FixnumP(First(lst)) == 0 && SymbolP(First(lst)) == 0)
return(NoValueObject);
nlst = MakePair(IdentifierP(First(lst)) ? AsIdentifier(First(lst))->Symbol : First(lst),
nlst);
lst = Rest(lst);
}
if (lst != EmptyListObject)
return(NoValueObject);
return(ReverseListModify(nlst));
}
// (<name1> <name2> ... <namen>) --> <dir>\<name1>\<name2>\...\<namen>.<ext>
static FObject LibraryNameDeep(FObject dir, FObject nam, FObject ext)
{
FObject out = MakeStringOutputPort();
WriteSimple(out, dir, 1);
while (PairP(nam))
{
FAssert(SymbolP(First(nam)) || IntegerP(First(nam)));
WriteCh(out, PathCh);
WriteSimple(out, First(nam), 1);
nam = Rest(nam);
}
FAssert(nam == EmptyListObject);
WriteStringC(out, ".");
WriteSimple(out, ext, 1);
return(GetOutputString(out));
}
int main(int argc, char * argv[])
#endif // FOMENT_UNIX
{
int_t pdx = 0;
int adx = 1;
while (adx < argc)
{
if (StringCompareS(argv[adx], "-A") == 0)
adx += 2;
else if (StringCompareS(argv[adx], "-I") == 0)
adx += 2;
else if (StringCompareS(argv[adx], "-X") == 0)
adx += 2;
else if (argv[adx][0] != '-')
{
pdx = adx;
break;
}
else if (StringCompareS(argv[adx], "-no-inline-procedures") == 0)
{
InlineProcedures = 0;
adx += 1;
}
else if (StringCompareS(argv[adx], "-no-inline-imports") == 0)
{
InlineImports = 0;
adx += 1;
}
else if (StringCompareS(argv[adx], "--validate-heap") == 0)
{
ValidateHeap = 1;
adx += 1;
}
#ifdef FOMENT_WINDOWS
else if (StringCompareS(argv[adx], "--section-table") == 0)
{
adx += 1;
if (adx < argc)
{
#ifdef FOMENT_32BIT
SectionTableBase = (void *) wcstol(argv[adx], 0, 16);
#endif // FOMENT_32BIT
#ifdef FOMENT_64BIT
SectionTableBase = (void *) _wcstoui64(argv[adx], 0, 16);
#endif // FOMENT_64BIT
adx += 1;
}
}
#endif // FOMENT_WINDOWS
else if (StringCompareS(argv[adx], "--random-seed") == 0)
{
adx += 1;
if (adx < argc)
{
RandomSeed = StringToInt(argv[adx]);
adx += 1;
}
}
else
break;
}
FThreadState ts;
try
{
SetupFoment(&ts);
if (pdx > 0)
{
AddToLibraryPath(argv[pdx]);
}
}
catch (FObject obj)
{
printf("Unexpected exception: SetupFoment: %p\n", obj);
WriteSimple(R.StandardOutput, obj, 0);
if (ValidateHeap)
{
FailedGC();
FailedExecute();
}
return(1);
}
FAssert(argc >= 1);
try
{
int adx = 1;
while (adx < argc)
{
if (StringCompareS(argv[adx], "-A") == 0)
{
adx += 1;
if (adx == argc)
return(MissingArgument(argv[adx - 1]));
FObject lp = R.LibraryPath;
for (;;)
{
FAssert(PairP(lp));
if (Rest(lp) == EmptyListObject)
break;
lp = Rest(lp);
}
// AsPair(lp)->Rest = MakePair(MakeStringS(argv[adx]), EmptyListObject);
SetRest(lp, MakePair(MakeStringS(argv[adx]), EmptyListObject));
adx += 1;
}
else if (StringCompareS(argv[adx], "-I") == 0)
{
adx += 1;
if (adx == argc)
return(MissingArgument(argv[adx - 1]));
R.LibraryPath = MakePair(MakeStringS(argv[adx]), R.LibraryPath);
adx += 1;
}
else if (StringCompareS(argv[adx], "-X") == 0)
{
adx += 1;
if (adx == argc)
return(MissingArgument(argv[adx - 1]));
R.LibraryExtensions = MakePair(MakeStringS(argv[adx]), R.LibraryExtensions);
adx += 1;
}
else if (StringCompareS(argv[adx], "-no-inline-procedures") == 0
|| StringCompareS(argv[adx], "-no-inline-imports") == 0
|| StringCompareS(argv[adx], "--validate-heap") == 0)
adx += 1;
#ifdef FOMENT_WINDOWS
else if (StringCompareS(argv[adx], "--section-table") == 0)
adx += 2;
#endif // FOMENT_WINDOWS
else if (StringCompareS(argv[adx], "--random-seed") == 0)
adx += 2;
else if (argv[adx][0] != '-')
return(ProgramMode(adx, argc, argv));
else
break;
}
R.LibraryPath = ReverseListModify(MakePair(MakeStringC("."), R.LibraryPath));
R.CommandLine = MakePair(MakeInvocation(adx, argv),
MakeCommandLine(argc - adx, argv + adx));
ExecuteThunk(R.InteractiveThunk);
ExitFoment();
return(0);
// return(RunRepl(GetInteractionEnv()));
}
catch (FObject obj)
{
if (ExceptionP(obj) == 0)
WriteStringC(R.StandardOutput, "exception: ");
WriteSimple(R.StandardOutput, obj, 0);
WriteCh(R.StandardOutput, '\n');
if (ValidateHeap)
{
FailedGC();
FailedExecute();
}
return(-1);
}
}
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));
}
static FObject CompileExports(FObject env, FObject lst)
{
FObject elst = EmptyListObject;
while (PairP(lst))
{
FAssert(PairP(First(lst)));
FAssert(IdentifierP(First(First(lst))) || SymbolP(First(First(lst))));
FObject form = First(lst);
if (EqualToSymbol(First(form), R.ExportSymbol))
{
FObject especs = Rest(form);
while (PairP(especs))
{
FObject spec = First(especs);
if (IdentifierP(spec) == 0 && SymbolP(spec) == 0
&& (PairP(spec) == 0
|| PairP(Rest(spec)) == 0
|| (IdentifierP(First(Rest(spec))) == 0 && SymbolP(First(Rest(spec))) == 0)
|| PairP(Rest(Rest(spec))) == 0
|| (IdentifierP(First(Rest(Rest(spec)))) == 0
&& SymbolP(First(Rest(Rest(spec)))) == 0)
|| Rest(Rest(Rest(spec))) != EmptyListObject
|| EqualToSymbol(First(spec), R.RenameSymbol) == 0))
RaiseExceptionC(R.Syntax, "export",
"expected an identifier or (rename <id1> <id2>)",
List(spec, form));
FObject lid = spec;
FObject eid = spec;
if (PairP(spec))
{
lid = First(Rest(spec));
eid = First(Rest(Rest(spec)));
}
if (IdentifierP(lid))
lid = AsIdentifier(lid)->Symbol;
if (IdentifierP(eid))
eid = AsIdentifier(eid)->Symbol;
FObject gl = EnvironmentLookup(env, lid);
if (GlobalP(gl) == 0)
RaiseExceptionC(R.Syntax, "export", "identifier is undefined",
List(lid, form));
if (GlobalP(Assq(eid, elst)))
RaiseExceptionC(R.Syntax, "export", "identifier already exported",
List(eid, form));
elst = MakePair(MakePair(eid, gl), elst);
especs = Rest(especs);
}
if (especs != EmptyListObject)
RaiseExceptionC(R.Syntax, "export", "expected a proper list of exports",
List(form));
}
else
{
FAssert(EqualToSymbol(First(form), R.ImportSymbol)
|| EqualToSymbol(First(form), R.AkaSymbol)
|| EqualToSymbol(First(form), R.IncludeLibraryDeclarationsSymbol)
|| EqualToSymbol(First(form), R.CondExpandSymbol)
|| EqualToSymbol(First(form), R.BeginSymbol)
|| EqualToSymbol(First(form), R.IncludeSymbol)
|| EqualToSymbol(First(form), R.IncludeCISymbol));
}
lst = Rest(lst);
}
FAssert(lst == EmptyListObject);
return(elst);
}
static FObject DoImportSet(FObject env, FObject is, FObject form)
{
// <library-name>
// (only <import-set> <identifier> ...)
// (except <import-set> <identifier> ...)
// (prefix <import-set> <identifier>)
// (rename <import-set> (<identifier1> <identifier2>) ...)
if (PairP(is) == 0 || (IdentifierP(First(is)) == 0 && SymbolP(First(is)) == 0))
RaiseExceptionC(R.Syntax, "import", "expected a list starting with an identifier",
List(is, form));
if (EqualToSymbol(First(is), R.OnlySymbol))
{
FObject ilst = DoOnlyOrExcept(env, is, 1);
if (ilst == NoValueObject)
RaiseExceptionC(R.Syntax, "import",
"expected (only <import-set> <identifier> ...)", List(is, form));
return(ilst);
}
else if (EqualToSymbol(First(is), R.ExceptSymbol))
{
FObject ilst = DoOnlyOrExcept(env, is, 0);
if (ilst == NoValueObject)
RaiseExceptionC(R.Syntax, "import",
"expected (except <import-set> <identifier> ...)", List(is, form));
return(ilst);
}
else if (EqualToSymbol(First(is), R.PrefixSymbol))
{
if (PairP(Rest(is)) == 0 || PairP(Rest(Rest(is))) == 0
|| Rest(Rest(Rest(is))) != EmptyListObject ||
(IdentifierP(First(Rest(Rest(is)))) == 0 && SymbolP(First(Rest(Rest(is)))) == 0))
RaiseExceptionC(R.Syntax, "import",
"expected (prefix <import-set> <identifier>)", List(is, form));
FObject prfx;
if (SymbolP(First(Rest(Rest(is)))))
prfx = AsSymbol(First(Rest(Rest(is))))->String;
else
prfx = AsSymbol(AsIdentifier(First(Rest(Rest(is))))->Symbol)->String;
FObject ilst = DoImportSet(env, First(Rest(is)), is);
FObject lst = ilst;
while (PairP(lst))
{
FAssert(GlobalP(First(lst)));
// AsGlobal(First(lst))->Name = PrefixSymbol(prfx, AsGlobal(First(lst))->Name);
Modify(FGlobal, First(lst), Name, PrefixSymbol(prfx, AsGlobal(First(lst))->Name));
lst = Rest(lst);
}
FAssert(lst == EmptyListObject);
return(ilst);
}
else if (EqualToSymbol(First(is), R.RenameSymbol))
{
if (PairP(Rest(is)) == 0)
RaiseExceptionC(R.Syntax, "import",
"expected (rename <import-set> (<identifier> <identifier>) ...)",
List(is, form));
FObject ilst = DoImportSet(env, First(Rest(is)), is);
FObject rlst = Rest(Rest(is));
while (PairP(rlst))
{
FObject rnm = First(rlst);
if (PairP(rnm) == 0 || PairP(Rest(rnm)) == 0 || Rest(Rest(rnm)) != EmptyListObject
|| (IdentifierP(First(rnm)) == 0 && SymbolP(First(rnm)) == 0)
|| (IdentifierP(First(Rest(rnm))) == 0 && SymbolP(First(Rest(rnm))) == 0))
RaiseExceptionC(R.Syntax, "import",
"expected (rename <import-set> (<identifier> <identifier>) ...)",
List(is, form));
rlst = Rest(rlst);
}
if (rlst != EmptyListObject)
RaiseExceptionC(R.Syntax, "import",
"expected (rename <import-set> (<identifier> <identifier>) ...)",
List(is, form));
FObject lst = ilst;
while (PairP(lst))
{
FAssert(GlobalP(First(lst)));
FObject nm = CheckForRename(AsGlobal(First(lst))->Name, Rest(Rest(is)));
if (SymbolP(nm))
{
// AsGlobal(First(lst))->Name = nm;
Modify(FGlobal, First(lst), Name, nm);
}
lst = Rest(lst);
}
FAssert(lst == EmptyListObject);
return(ilst);
}
FObject nam = LibraryName(is);
if (PairP(nam) == 0)
RaiseExceptionC(R.Syntax, "import",
"library name must be a list of symbols and/or integers", List(is));
FObject lib = FindOrLoadLibrary(nam);
if (LibraryP(lib) == 0)
RaiseExceptionC(R.Syntax, "import", "library not found", List(nam, form));
FObject ilst = EmptyListObject;
FObject elst = AsLibrary(lib)->Exports;
while (PairP(elst))
{
FAssert(PairP(First(elst)));
FAssert(SymbolP(First(First(elst))));
FAssert(GlobalP(Rest(First(elst))));
ilst = MakePair(ImportGlobal(env, First(First(elst)), Rest(First(elst))), ilst);
elst = Rest(elst);
}
FAssert(elst == EmptyListObject);
return(ilst);
}
FObject CompileProgram(FObject nam, FObject port)
{
FAssert(TextualPortP(port) && InputPortOpenP(port));
WantIdentifiersPort(port, 1);
FDontWait dw;
FObject env = MakeEnvironment(nam, FalseObject);
FObject prog = EmptyListObject;
FObject body = EmptyListObject;
try
{
for (;;)
{
FObject obj = Read(port);
if (obj == EndOfFileObject)
break;
if (PairP(obj) && EqualToSymbol(First(obj), R.CondExpandSymbol))
{
FObject ce = CondExpand(MakeSyntacticEnv(R.Bedrock), obj, Rest(obj));
if (ce != EmptyListObject)
prog = CondExpandProgram(ce, prog);
}
else
prog = MakePair(obj, prog);
}
prog = ReverseListModify(prog);
while (prog != EmptyListObject)
{
FAssert(PairP(prog));
FObject obj = First(prog);
if (PairP(obj) == 0)
break;
if (EqualToSymbol(First(obj), R.ImportSymbol))
EnvironmentImport(env, obj);
else if (EqualToSymbol(First(obj), R.DefineLibrarySymbol))
CompileLibrary(obj);
else
break;
prog = Rest(prog);
}
if (R.LibraryStartupList != EmptyListObject)
{
body = MakePair(MakePair(BeginSyntax, ReverseListModify(R.LibraryStartupList)), body);
R.LibraryStartupList = EmptyListObject;
}
while (prog != EmptyListObject)
{
FAssert(PairP(prog));
body = CompileEvalExpr(First(prog), env, body);
prog = Rest(prog);
}
}
catch (FObject obj)
{
if (ExceptionP(obj) == 0)
WriteStringC(R.StandardOutput, "exception: ");
Write(R.StandardOutput, obj, 0);
WriteCh(R.StandardOutput, '\n');
}
FObject proc = CompileLambda(env, NoValueObject, EmptyListObject, ReverseListModify(body));
UndefinedList = EmptyListObject;
EqHashMapVisit(AsEnvironment(env)->HashMap, Visit, NoValueObject);
if (UndefinedList != EmptyListObject)
RaiseExceptionC(R.Syntax, "program", "identifier(s) used but never defined",
List(UndefinedList, nam));
return(proc);
}
