static bool pbind_vars(obj* vars, obj lt){
obj utype;
switch(lt->type){
default:
break;
case tSymbol:
if(vars) add_assoc(vars, lt, nil);
return true;
case tRef:
assert(0);
let(&(uref(lt)), nil);
return true;
case INT:
assert(0);
// return equal(lt,rt);
case tOp:
utype = search_assoc(curr_interp->types, ult(lt));
if(utype){
return pbind_vars(vars, urt(lt));
}
pbind_vars(vars, ult(lt));
return pbind_vars(vars, urt(lt));
case LIST:
list x=ul(lt);
for(; (x); x=rest(x)){
pbind_vars(vars, first(x));
}
return true;
}
print(lt);
assert(0);
return nil;
}
static
obj strip_return(obj r){
if(!r) return r;
if(type(r)!=tSigRet) return r;
obj rr = retain(uref(r));
release(r);
return rr;
}
static bool bind_vars(obj* vars, obj lt, obj rt){
obj utype;
switch(lt->type){
default:
break;
case tSymbol:
if(macromode){
if(obj rr = search_assoc(car(macro_env), lt)){
//macromode = false;
if(vars) add_assoc(vars, rr, rt);
//macromode = true;
return true;
}
}
if(vars) add_assoc(vars, lt, rt);
return true;
case tRef:
let(&(uref(lt)), rt);
return true;
case INT:
return equal(lt, rt);
case tOp:
utype = search_assoc(curr_interp->types, ult(lt));
if(utype){
if(vrInt(utype) != rt->type) return false;
return bind_vars(vars, urt(lt), uref(rt));
}
if(rt->type!=tOp) return false;
if(! bind_vars(vars, ult(lt), ult(rt))) return false;
return bind_vars(vars, urt(lt), urt(rt));
case LIST:
if(rt->type!=LIST) return false;
list x=ul(lt), a=ul(rt);
for(; (x && a); x=rest(x),a=rest(a)){
if(!bind_vars(vars, first(x), first(a))) return false;
}
if(x||a) return false;
return true;
}
print(lt);
assert(0);
return nil;
}
static obj* lfind_var(obj id){
if(id->type==tRef) return &(uref(id));
if(env){
for(obj e=env; e; e=cdr(e)){
//if(e->refcount !=1) break; 140105 wrong because can't change enclosed vars
obj* v = left_search(car(e), id);
if (v) return v;
}
/*/ obj *v;
obj e = lfind_local(env, id, &v);
if(e) {release(env); env = e; return v;}
if(v) return v;
//*/ return add_assoc(&car(env), id, nil); //local
} else { // when in global space
obj* v = left_search(curr_interp->gl_vars, id);//global
if(v) return v;
return add_assoc(&(curr_interp->gl_vars), id, nil); //global
}
}
static obj do_assign(obj lt, obj rt){
switch(type(lt)) {
case tRef:
return retain(*let(&(uref(lt)), rt));
case tSymbol:
return retain(*let(lfind_var(lt),rt));
default:
break;
case tInd:{
obj *var;
var = lfind_var(ult(lt));
if(!*var) error("the vector does not exist.");
if((*var)->refcount > 1){
obj nv = copy(*var);
release(*var);
*var = nv;
myPrintf("performance alert: copy");
}
obj inds = eval(urt(lt));
doLInd(var, ul(inds), rt);
release(inds);
return retain(rt);
}
case LIST:
return applyCC(do_assign, lt, rt);
if(type(rt)!=LIST) error("list<-nonlist");
list s = ul(rt);
for(list l = ul(lt); l; l=rest(l), s=rest(s)){
if(! s) error("number is not enough for rhs.");
do_assign(first(l),first(s));
}
if(s) error("too much for rhs.");
return nil;
}
print(lt);
assert(0);
return nil;
}
TProof *getProof(const char *url = "proof://localhost:40000", Int_t nwrks = -1, const char *dir = 0,
const char *opt = "ask", Bool_t dyn = kFALSE, Bool_t tutords = kFALSE)
{
#ifdef __CINT__
Printf("getProof: this script can only be executed via ACliC:");
Printf("getProof: root [] .x <path>/getProof.C+");
Printf("getProof: or root [] .L <path>/getProof.C+");
Printf("getProof: root [] getProof(...)");
return;
#endif
TProof *p = 0;
// Valgrind options, if any
TString vopt, vopts;
#ifndef WIN32
if (gSystem->Getenv("GETPROOF_VALGRIND")) {
TString s(gSystem->Getenv("GETPROOF_VALGRIND")), t;
Int_t from = 0;
while (s.Tokenize(t, from , " ")) {
if (t.BeginsWith("valgrind_opts:"))
vopts = t;
else
vopt = t;
}
if (vopts.IsNull()) vopts = "valgrind_opts:--leak-check=full --track-origins=yes";
TProof::AddEnvVar("PROOF_WRAPPERCMD", vopts.Data());
Printf("getProof: valgrind run: '%s' (opts: '%s')", vopt.Data(), vopts.Data());
}
#endif
// If an URL has specified get a session there
TUrl uu(url), uref(refloc);
Bool_t ext = (strcmp(uu.GetHost(), uref.GetHost()) ||
(uu.GetPort() != uref.GetPort())) ? kTRUE : kFALSE;
Bool_t lite = kFALSE;
if (ext && url) {
if (!strcmp(url, "lite://") || !url[0]) {
if (!url[0]) uu.SetUrl("lite://");
if (dir && strlen(dir) > 0) gEnv->SetValue("Proof.Sandbox", dir);
TString swrk("<default> workers");
if (nwrks > 0) {
uu.SetOptions(Form("workers=%d", nwrks));
swrk.Form("%d workers", nwrks);
}
lite = kTRUE;
gEnv->SetValue("Proof.MaxOldSessions", 1);
Printf("getProof: trying to open a PROOF-Lite session with %s", swrk.Data());
} else {
Printf("getProof: trying to open a session on the external cluster at '%s'", url);
}
p = TProof::Open(uu.GetUrl(), vopt);
if (p && p->IsValid()) {
// Check consistency
if (ext && !lite && nwrks > 0) {
Printf("getProof: WARNING: started/attached a session on external cluster (%s):"
" 'nwrks=%d' ignored", url, nwrks);
}
if (ext && !lite && dir && strlen(dir) > 0) {
Printf("getProof: WARNING: started/attached a session on external cluster (%s):"
" 'dir=\"%s\"' ignored", url, dir);
}
if (ext && !strcmp(opt,"force")) {
Printf("getProof: WARNING: started/attached a session on external cluster (%s):"
" 'opt=\"force\"' ignored", url);
}
if (ext && dyn) {
Printf("getProof: WARNING: started/attached a session on external cluster (%s):"
" 'dyn=kTRUE' ignored", url);
}
// Done
return p;
} else {
if (ext) {
Printf("getProof: could not get/start a valid session at %s", url);
return p;
} else {
Printf("getProof: could not get/start a valid session at %s - try resarting the daemon", url);
}
}
if (p) delete p;
p = 0;
}
#ifdef WIN32
// No support for local PROOF on Win32 (yet; the optimized local Proof will work there too)
Printf("getProof: local PROOF not yet supported on Windows, sorry!");
return p;
#else
// Temp dir for tutorial daemons
TString tutdir = dir;
if (!tutdir.IsNull()) {
if (gSystem->AccessPathName(tutdir)) {
// Directory does not exist: try to make it
gSystem->mkdir(tutdir.Data(), kTRUE);
if (gSystem->AccessPathName(tutdir, kWritePermission)) {
if (gSystem->AccessPathName(tutdir)) {
Printf("getProof: unable to create the working area at the requested path: '%s'"
" - cannot continue", tutdir.Data());
} else {
Printf("getProof: working area at the requested path '%s'"
" created but it is not writable - cannot continue", tutdir.Data());
}
return p;
}
} else {
// Check if it is writable ...
if (gSystem->AccessPathName(dir, kWritePermission)) {
// ... fail if not
Printf("getProof: working area at the requested path '%s'"
" exists but is not writable - cannot continue", tutdir.Data());
return p;
}
}
} else {
// Notify
Printf("getProof: working area not specified temp ");
// Force "/tmp/<user>" whenever possible to avoid length problems on MacOsX
tutdir="/tmp";
if (gSystem->AccessPathName(tutdir, kWritePermission)) tutdir = gSystem->TempDirectory();
TString us;
UserGroup_t *ug = gSystem->GetUserInfo(gSystem->GetUid());
if (!ug) {
Printf("getProof: could not get user info");
return p;
}
us.Form("/%s", ug->fUser.Data());
if (!tutdir.EndsWith(us.Data())) tutdir += us;
// Add our own subdir
tutdir += "/.getproof";
if (gSystem->AccessPathName(tutdir)) {
gSystem->mkdir(tutdir.Data(), kTRUE);
if (gSystem->AccessPathName(tutdir, kWritePermission)) {
Printf("getProof: unable to get a writable working area (tried: %s)"
" - cannot continue", tutdir.Data());
return p;
}
}
}
Printf("getProof: working area (tutorial dir): %s", tutdir.Data());
// Dataset dir
TString datasetdir;
if (tutords) {
datasetdir = Form("%s/dataset", tutdir.Data());
if (gSystem->AccessPathName(datasetdir, kWritePermission)) {
gSystem->mkdir(datasetdir, kTRUE);
if (gSystem->AccessPathName(datasetdir, kWritePermission)) {
Printf("getProof: unable to get a writable dataset directory (tried: %s)"
" - cannot continue", datasetdir.Data());
return p;
}
Printf("getProof: dataset dir: %s", datasetdir.Data());
}
}
// Local url (use a special port to try to not disturb running daemons)
TUrl u(refloc);
u.SetProtocol("proof");
if (!strcmp(uu.GetHost(), uref.GetHost()) && (uu.GetPort() != uref.GetPort()))
u.SetPort(uu.GetPort());
Int_t lportp = u.GetPort();
Int_t lportx = lportp + 1;
TString lurl = u.GetUrl();
// Prepare to start the daemon
TString workarea = Form("%s/proof", tutdir.Data());
TString xpdcf(Form("%s/xpd.cf",tutdir.Data()));
TString xpdlog(Form("%s/xpd.log",tutdir.Data()));
TString xpdlogprt(Form("%s/xpdtut/xpd.log",tutdir.Data()));
TString xpdpid(Form("%s/xpd.pid",tutdir.Data()));
TString proofsessions(Form("%s/sessions",tutdir.Data()));
TString cmd;
Int_t rc = 0;
// Is there something listening already ?
Int_t pid = -1;
Bool_t restart = kTRUE;
if ((rc = checkXproofdAt(lportp)) == 1) {
Printf("getProof: something else the a XProofd service is running on"
" port %d - cannot continue", lportp);
return p;
} else if (rc == 0) {
restart = kFALSE;
pid = getXrootdPid(lportx);
Printf("getProof: daemon found listening on dedicated ports {%d,%d} (pid: %d)",
lportx, lportp, pid);
if (isatty(0) == 0 || isatty(1) == 0) {
// Cannot ask: always restart
restart = kTRUE;
} else {
if (!strcmp(opt,"ask")) {
char *answer = (char *) Getline("getProof: would you like to restart it (N,Y)? [N] ");
if (answer && (answer[0] == 'Y' || answer[0] == 'y'))
restart = kTRUE;
}
}
if (!strcmp(opt,"force"))
// Always restart
restart = kTRUE;
// Cleanup, if required
if (restart) {
Printf("getProof: cleaning existing instance ...");
// Cleaning up existing daemon
cmd = Form("kill -9 %d", pid);
if ((rc = gSystem->Exec(cmd)) != 0)
Printf("getProof: problems stopping xrootd process %d (%d)", pid, rc);
// Wait for all previous connections being cleaned
Printf("getProof: wait 5 secs so that previous connections are cleaned ...");
gSystem->Sleep(5000);
}
}
if (restart) {
// Try to start something locally; make sure that everything is there
char *xrootd = gSystem->Which(gSystem->Getenv("PATH"), "xrootd", kExecutePermission);
if (!xrootd) {
Printf("getProof: xrootd not found: please check the environment!");
return p;
}
// Cleanup the working area
cmd = Form("rm -fr %s/xpdtut %s %s %s %s", tutdir.Data(), workarea.Data(),
xpdcf.Data(), xpdpid.Data(), proofsessions.Data());
gSystem->Exec(cmd);
// Try to start something locally; create the xrootd config file
FILE *fcf = fopen(xpdcf.Data(), "w");
if (!fcf) {
Printf("getProof: could not create config file for XPD (%s)", xpdcf.Data());
return p;
}
fprintf(fcf,"### Use admin path at %s/admin to avoid interferences with other users\n", tutdir.Data());
fprintf(fcf,"xrd.adminpath %s/admin\n", tutdir.Data());
#if defined(R__MACOSX)
fprintf(fcf,"### Use dedicated socket path under /tmp to avoid length problems\n");
fprintf(fcf,"xpd.sockpathdir /tmp/xpd-sock\n");
#endif
fprintf(fcf,"### Run data serving on port %d\n", lportp+1);
fprintf(fcf,"xrd.port %d\n", lportp+1);
fprintf(fcf,"### Load the XrdProofd protocol on port %d\n", lportp);
fprintf(fcf,"xrd.protocol xproofd libXrdProofd.so\n");
fprintf(fcf,"xpd.port %d\n", lportp);
if (nwrks > 0) {
fprintf(fcf,"### Force number of local workers\n");
fprintf(fcf,"xpd.localwrks %d\n", nwrks);
}
fprintf(fcf,"### Root path for working dir\n");
fprintf(fcf,"xpd.workdir %s\n", workarea.Data());
fprintf(fcf,"### Allow different users to connect\n");
fprintf(fcf,"xpd.multiuser 1\n");
fprintf(fcf,"### Limit the number of query results kept in the master sandbox\n");
fprintf(fcf,"xpd.putrc ProofServ.UserQuotas: maxquerykept=10\n");
fprintf(fcf,"### Limit the number of sessions kept in the sandbox\n");
fprintf(fcf,"xpd.putrc Proof.MaxOldSessions: 1\n");
if (tutords) {
fprintf(fcf,"### Use dataset directory under the tutorial dir\n");
fprintf(fcf,"xpd.datasetsrc file url:%s opt:-Cq:Av:As:\n", datasetdir.Data());
}
if (dyn) {
fprintf(fcf,"### Use dynamic, per-job scheduling\n");
fprintf(fcf,"xpd.putrc Proof.DynamicStartup 1\n");
}
fprintf(fcf,"### Local data server for the temporary output files\n");
fprintf(fcf,"xpd.putenv LOCALDATASERVER=root://%s:%d\n", gSystem->HostName(), lportx);
fclose(fcf);
Printf("getProof: xrootd config file at %s", xpdcf.Data());
// Start xrootd in the background
Printf("getProof: xrootd log file at %s", xpdlogprt.Data());
cmd = Form("%s -c %s -b -l %s -n xpdtut -p %d",
xrootd, xpdcf.Data(), xpdlog.Data(), lportx);
Printf("(NB: any error line from XrdClientSock::RecvRaw and XrdClientMessage::ReadRaw should be ignored)");
if ((rc = gSystem->Exec(cmd)) != 0) {
Printf("getProof: problems starting xrootd (%d)", rc);
return p;
}
delete[] xrootd;
// Wait a bit
Printf("getProof: waiting for xrootd to start ...");
gSystem->Sleep(2000);
pid = getXrootdPid(lportx);
Printf("getProof: xrootd pid: %d", pid);
// Save it in the PID file
FILE *fpid = fopen(xpdpid.Data(), "w");
if (!fpid) {
Printf("getProof: could not create pid file for XPD");
} else {
fprintf(fpid,"%d\n", pid);
fclose(fpid);
}
}
Printf("getProof: start / attach the PROOF session ...");
// Start / attach the session now
p = TProof::Open(lurl, vopt.Data());
if (!p || !(p->IsValid())) {
Printf("getProof: starting local session failed");
if (p) delete p;
p = 0;
return p;
}
// Return the session
return p;
#endif
}
void
WUploadThread::DoUpload()
{
PRINT("WUploadThread::DoUpload\n");
if (fShutdownFlag && *fShutdownFlag) // Do we need to interrupt?
{
ConnectTimer();
return;
}
// Still connected?
if (!IsInternalThreadRunning())
{
ConnectTimer();
return;
}
// Small files get to bypass queue
if (IsLocallyQueued())
{
if (
(fFile && (fFileSize >= gWin->fSettings->GetMinQueuedSize())) ||
IsManuallyQueued()
)
{
// not yet
fForced = false;
WUploadEvent *lq = new WUploadEvent(WUploadEvent::FileQueued);
if (lq)
{
SendReply(lq);
}
return;
}
fForced = true; // Set this here to avoid duplicate call to DoUpload()
}
// Recheck if IP is ignored or not
//
if (gWin->IsIgnoredIP(fStrRemoteIP) && !IsBlocked())
{
SetBlocked(true);
}
if (IsBlocked())
{
WUploadEvent *wue = new WUploadEvent(WUploadEvent::FileBlocked);
if (wue)
{
if (fTimeLeft != -1)
wue->SetTime(fTimeLeft);
SendReply(wue);
}
return;
}
if (fStartTime == 0)
fStartTime = GetRunTime64();
if (fFile)
{
MessageRef uref(GetMessageFromPool(WTransfer::TransferFileData));
if (uref())
{
// think about doing this in a dynamic way (depending on connection)
double dpps = GetPacketSize() * 1024.0;
uint32 bufferSize = lrint(dpps);
ByteBufferRef buf = GetByteBufferFromPool(bufferSize);
uint8 * scratchBuffer = buf()->GetBuffer();
if (scratchBuffer == NULL)
{
_nobuffer();
return;
}
int32 numBytes = 0;
numBytes = fFile->ReadBlock32(scratchBuffer, bufferSize);
if (numBytes > 0)
{
buf()->SetNumBytes(numBytes, true);
// munge mode
switch (fMungeMode)
{
case WTransfer::MungeModeNone:
{
uref()->AddInt32("mm", WTransfer::MungeModeNone);
break;
}
case WTransfer::MungeModeXOR:
{
for (int32 x = 0; x < numBytes; x++)
scratchBuffer[x] ^= 0xFF;
uref()->AddInt32("mm", WTransfer::MungeModeXOR);
break;
}
default:
{
break;
}
}
if (uref()->AddFlat("data", buf) == B_OK)
{
// possibly do checksums here
uref()->AddInt32("chk", CalculateFileChecksum(buf)); // a little paranoia, due to file-resumes not working.... (TCP should handle this BUT...)
SendMessageToSessions(uref);
// NOTE: RequestOutputQueuesDrainedNotification() can recurse, so we need to update the offset before
// calling it!
fCurrentOffset += numBytes;
if (fTunneled)
{
SignalUpload();
}
else
{
MessageRef drain(GetMessageFromPool());
if (drain())
qmtt->RequestOutputQueuesDrainedNotification(drain);
}
WUploadEvent *update = new WUploadEvent(WUploadEvent::FileDataSent);
if (update)
{
update->SetOffset(fCurrentOffset);
update->SetSize(fFileSize);
update->SetSent(numBytes);
if (fCurrentOffset >= fFileSize)
{
update->SetDone(true); // file done!
update->SetFile(SimplifyPath(fFileUl));
if (gWin->fSettings->GetUploads())
{
SystemEvent( gWin, tr("%1 has finished downloading %2.").arg( GetRemoteUser() ).arg( SimplifyPath(fFileUl) ) );
}
}
SendReply(update);
}
return;
}
else
{
_nobuffer();
return;
}
}
if (numBytes <= 0)
{
NextFile();
SignalUpload();
return;
}
}
}
else
{
while (!fFile)
{
if (fUploads.GetNumItems() != 0)
{
// grab the ref and remove it from the list
fUploads.RemoveHead(fCurrentRef);
fFileUl = MakeUploadPath(fCurrentRef);
#ifdef _DEBUG
// <*****@*****.**> 20021023, 20030702 -- Add additional debug message
WString wul(fFileUl);
PRINT("WUploadThread::DoUpload: filePath = %S\n", wul.getBuffer());
#endif
fFile = new WFile();
Q_CHECK_PTR(fFile);
if (!fFile->Open(fFileUl, QIODevice::ReadOnly)) // probably doesn't exist
{
delete fFile;
fFile = NULL;
fCurFile++;
continue; // onward
}
// got our file!
fFileSize = fFile->Size();
fCurrentOffset = 0; // from the start
if (fCurrentRef()->FindInt64("secret:offset", fCurrentOffset) == B_OK)
{
if (!fFile->Seek(fCurrentOffset)) // <*****@*****.**> 20021026
{
fFile->Seek(0); // this can't fail :) (I hope)
fCurrentOffset = 0;
}
}
// copy the message in our current file ref
MessageRef headRef = fCurrentRef.Clone();
if (headRef())
{
headRef()->what = WTransfer::TransferFileHeader;
headRef()->AddInt64("beshare:StartOffset", fCurrentOffset);
SendMessageToSessions(headRef);
}
fCurFile++;
// Reset statistics
InitTransferRate();
InitTransferETA();
WUploadEvent *started = new WUploadEvent(WUploadEvent::FileStarted);
if (started)
{
started->SetFile(SimplifyPath(fFileUl));
started->SetStart(fCurrentOffset);
started->SetSize(fFileSize);
#ifdef _DEBUG
started->SetSession(fRemoteSessionID);
#endif
SendReply(started);
}
if (gWin->fSettings->GetUploads())
{
SystemEvent( gWin, tr("%1 is downloading %2.").arg( GetRemoteUser() ).arg( SimplifyPath(fFileUl) ) );
}
// nested call
SignalUpload();
return;
}
else
{
PRINT("No more files!\n");
fWaitingForUploadToFinish = true;
SetFinished(true);
if (fTunneled)
{
_OutputQueuesDrained();
}
else
{
MessageRef drain(GetMessageFromPool());
if (drain())
qmtt->RequestOutputQueuesDrainedNotification(drain);
}
break;
}
}
}
}
obj eval(obj exp){
ev: assert(!! exp);
obj rr,lt, rt;
switch (exp->type) {
case tInd:
return doInd(eval(ult(exp)), ul(eval(urt(exp))));
case LIST:
return List2v(evalList(ul(exp)));
case tArray:
return map_obj(eval, exp);
case tAnd:
return prod_eval(ul(exp), mult);
case MULT:
return prod_eval(ul(exp), mult);
case ARITH:
return prod_eval(ul(exp), add);
case POW:
return prod_eval(ul(exp), power);
case DIVIDE:
return prod_eval(ul(exp), divide);
case tRef:
return retain(uref(exp));
case tSymbol:
if( macromode) {
if(obj rr = search_assoc(car(macro_env), exp)){
macromode = false;
// macro lexical scope should be pushed to the stack here
rr = exec(rr);
macromode = true;
return rr;
}
}
return eval_symbol(exp);
case tMinus:
lt = eval(uref(exp));
rr = uMinus(lt); // releasing
if(rr) {release(lt); return rr;}
static obj symumn = Symbol("-");
rr = udef_op0(symumn, lt);
if(rr) {release(lt); return rr;}
error("uMinus: not defined to that type");
case tReturn:
if(! uref(exp)) return encap(tSigRet, nil);
return encap(tSigRet, eval(uref(exp)));
case tBreak:
return retain(exp);
case CONDITION:
return evalCond(exp);
case tOp:
if(type(ult(exp)) ==tSymbol) {
lt = search_assoc(curr_interp->types, ult(exp));
if(lt) return encap((ValueType)vrInt(lt), eval(urt(exp)));}
lt = eval(ult(exp));
push(lt);
switch(lt->type){
case tCont:
assert(0);
case tSpecial:
rr = ufn(lt)(urt(exp));
break;
case tSyntaxLam:
rr = macro_exec(lt, urt(exp));
break;
case tInternalFn:
case tClosure:
rt = eval(urt(exp));
rr = eval_function(lt, rt);
break;
default:
rt = eval(urt(exp));
rr = call_fn(mult, lt, rt);
release(rt);
}
release(pop(&is));
return rr;
case tClosure:
assert(0);
case tCurry:
return eval_curry(exp, em0(exp));
/* obj vars = Assoc();
bind_vars(&vars, em0(exp), em2(exp));
rr = eval_curry(exp, vars);
release(vars);
return rr;
*/ case tArrow:
// return enclose(exp);
/* if(macromode){
if(obj rr = search_assoc(car(macro_env), exp)){
}
}
*/ return render(tClosure, list3(retain(em0(exp)), retain(em1(exp)), retain(env)));
case tDefine:
return func_def(em0(exp), em1(exp), em2(exp));
case tSyntaxDef:
let(lfind_var(em0(exp)), render(tSyntaxLam, list3(retain(em1(exp)), retain(em2(exp)), nil)));
return nil;
case tExec:
return exec(exp);
case tAssign:
lt = car(exp);
if(type(lt)==tOp){
return func_def(ult(lt), urt(lt), cdr(exp));
} else if(type(lt)==tMinus){
static obj symumn = Symbol("-");
return func_def(symumn, uref(lt), cdr(exp));
} else return do_assign(lt, eval(cdr(exp)));
case tIf:
rr = eval(em0(exp));
if (type(rr) != INT) error("if: Boolean Expected");
if (vrInt(rr)) {
rr = em1(exp);
} else {
rr = em2(exp);
}
return eval(rr);
case tWhile:
for(;;) {
rr = eval(car(exp));
if (type(rr) != INT) error("while: Boolean expected");
if(!vrInt(rr)) break;
rr = exec(cdr(exp));
if(rr && type(rr)==tSigRet) return rr;
if(rr && type(rr)==tBreak) {release(rr); break;}
if(rr) release(rr);
}
return nil;
default:
return retain(exp);
}
}
static
void enclose0(obj v){
assert(!! v);
switch(v->type){
case tSymbol:
/* if( macromode) {
for(obj e = macro_env; e; e = cdr(e)){
obj rr = search_assoc(car(e), v);
if (v) { rr = v; break;}
}
//if(obj rr = search_assoc(car(macro_env), v)){ v=rr;}
}
//*/ if(is_in(penv, v)) return;
if(search_pair(vto_close, car(v))) return;
add_assoc(&vto_close, v, nil);
return;
case tAssign:
enclose0(cdr(v));
if(is_in(penv, car(v))) return;
if(search_pair(vto_close, car(v))) return;
if(is_in(env, car(v))) {
add_assoc(&vto_close, car(v), nil);
return;
}
add_assoc(&car(penv), car(v), nil); // new assignment
return;
case tClosure:
assert(0);
case tArrow:{
obj vs = Assoc();
pbind_vars(&vs, em0(v));
penv = op(vs, penv);
enclose0(em1(v));
release(pop(&penv));
return;
}
case tDefine:
case tSyntaxDef:
assert(0);
case tArray:
for(int i=0; i < uar(v).size; i++) enclose0(uar(v).v[i]);
return;
case LIST: //list
case POW:
case MULT:
case DIVIDE:
case ARITH:
case CONDITION:
case tIf:
case tExec:
case tAnd:
for(list s=ul(v); s; s=rest(s)) enclose0(first(s));
return;
case tReturn:
if(!uref(v)) return;
case tMinus:
enclose0(uref(v));
return;
case tInd:
case tWhile:
case tOp:
enclose0(car(v));
enclose0(cdr(v));
return;
case INT:
case tDouble:
case TOKEN:
case tNull:
case tLAVec:
case tDblArray:
case tIntArr:
case tDblAr2:
case IMAGE:
case STRING:
case tBreak:
return;
default:
break;
}
print(v);
assert(0);
return;
}
obj subs0(obj v, obj * vars){
assert(!! v);
switch(v->type){
case tSymbol:
if(vars){ // macro
obj vp = search_assoc(*vars, v);
if(vp) return vp;
// vp = searchFunc(v, specials);
// if(vp) {release(vp); return retain(v);}
obj (*func)(obj) = searchFunc(v, specials);
if(func) return retain(v);
vp = find_var(v);
if(vp) {release(vp); return retain(v);}
assert(0);
// return ref2var(add_assoc(*vars, v, Null()));
} else { // quasi-quote
obj vp = find_var(v);
if(vp) return vp;
return retain(v);
}
case tAssign:{
obj vp = search_assoc(*vars, car(v)); //macro-locals
if(vp) goto nex;
/* vp = searchFunc(car(v), specials); // not needed because cant assign to global
if(vp) {release(vp); vp = retain(v); return vp;}
vp = find_var(v);
if(vp) {release(vp); vp = retain(v); return vp;}
*/ vp = ref2var(nil);
add_assoc(vars, car(v), vp);
nex: return operate(tAssign, vp, subs0(cdr(v), vars));
}
case tArray:{
obj r = aArray(uar(v).size);
for(int i=0; i < uar(v).size; i++) uar(r).v[i] = subs0(uar(v).v[i], vars);
return r;
}
case LIST: //list
case POW:
case MULT:
case DIVIDE:
case ARITH:
case CONDITION:
case tIf:
case tExec:
{
list l = phi();
for(list s=ul(v); s; s=rest(s)) l = cons(subs0(first(s), vars), l);
return render(type(v), reverse(l));
}
case tReturn:
if(!uref(v)) return retain(v);
case tMinus:
return encap(v->type, subs0(uref(v), vars));
case tClosure:
case tArrow:
return render(type(v), list3(subs0(em0(v),vars), subs0(em1(v), vars), nil));
case tDefine:
case tSyntaxDef:
assert(0);
case tInd:
case tWhile:
{
obj st = subs0(cdr(v), vars);
if(type(st)==LIST) st->type = tExec;
return operate(v->type, subs0(car(v), vars), st);
}
case tOp:
return operate(v->type, subs0(car(v), vars), subs0(cdr(v), vars));
case INT:
case tDouble:
case TOKEN:
case tNull:
case tLAVec:
case tDblArray:
case tIntArr:
case tDblAr2:
case IMAGE:
case STRING:
case tBreak:
return retain(v);
default:
break;
}
print(v);
assert(0);
return v;
}
inline obj ref2var(obj var){
obj r = alloc();
r->type = tRef;
uref(r) = var;
return r;
}
