static cell parm2(FILE *fbin,const char *params,cell opcode,cell cip)
{
ucell p1=getparamvalue(params,¶ms);
ucell p2=getparamvalue(params,NULL);
(void)cip;
if (fbin!=NULL) {
write_cell(fbin,opcode);
write_cell(fbin,p1);
write_cell(fbin,p2);
} /* if */
return opcodes(1)+opargs(2);
}
static cell parmx(FILE *fbin,const char *params,cell opcode,cell cip)
{
int idx;
ucell count=getparamvalue(params,¶ms);
(void)cip;
if (fbin!=NULL) {
write_cell(fbin,opcode);
write_cell(fbin,(ucell)count);
} /* if */
for (idx=0; idx<count; idx++) {
ucell p=getparamvalue(params,¶ms);
if (fbin!=NULL)
write_cell(fbin,p);
} /* for */
return opcodes(1)+opargs(count+1);
}
static cell set_currentfile(FILE *fbin,const char *params,cell opcode,cell cip)
{
(void)fbin;
(void)opcode;
(void)cip;
fcurrent=(short)getparamvalue(params,NULL);
return 0;
}
static cell parmx_p(FILE *fbin,const char *params,cell opcode,cell cip)
{
int idx;
ucell p;
ucell count=getparamvalue(params,¶ms);
(void)cip;
assert(count<((ucell)1<<(pc_cellsize*4)));
assert(opcode>=0 && opcode<=255);
/* write the instruction (optionally) */
if (fbin!=NULL) {
p=(count<<pc_cellsize*4) | opcode;
write_cell(fbin,p);
} /* if */
for (idx=0; idx<count; idx++) {
p=getparamvalue(params,¶ms);
if (fbin!=NULL)
write_cell(fbin,p);
} /* for */
return opcodes(1)+opargs(count);
}
static cell parm1_p(FILE *fbin,const char *params,cell opcode,cell cip)
{
ucell p=getparamvalue(params,NULL);
(void)cip;
assert(p<((ucell)1<<(pc_cellsize*4)));
assert(opcode>=0 && opcode<=255);
if (fbin!=NULL) {
p=(p<<pc_cellsize*4) | opcode;
write_cell(fbin,p);
} /* if */
return opcodes(1);
}
static cell do_dump(FILE *fbin,const char *params,cell opcode,cell cip)
{
ucell p;
int num = 0;
(void)opcode;
(void)cip;
while (*params!='\0') {
p=getparamvalue(params,¶ms);
if (fbin!=NULL)
write_cell(fbin,p);
num++;
while (isspace(*params))
params++;
} /* while */
return num*pc_cellsize;
}
static boolean getmainmenuvalue (hdltreenode hparam1, hdlmenu *hmenu, short *idmenu) {
tyvaluerecord val;
bigstring bsmenu;
flnextparamislast = true;
if (!getparamvalue (hparam1, 1, &val))
return (false);
if (val.valuetype != stringvaluetype)
return (false);
texthandletostring ((Handle) val.data.stringvalue, bsmenu);
return (shelltgetmainmenu (bsmenu, hmenu, idmenu));
} /*getmainmenuvalue*/
static boolean tableassignverb (hdltreenode hparam1, tyvaluerecord *v) {
/*
10/3/91 dmb: use new fllanghashassignprotect flag to override protection
*/
hdlhashtable htable;
bigstring bsname;
tyvaluerecord val;
boolean fl;
if (!getvarparam (hparam1, 1, &htable, bsname))
return (false);
flnextparamislast = true;
if (!getparamvalue (hparam1, 2, &val))
return (false);
if (!copyvaluerecord (val, &val))
return (false);
/*
fllanghashassignprotect = false;
*/
fl = hashtableassign (htable, bsname, val);
/*
fllanghashassignprotect = true;
*/
if (!fl)
return (false);
exemptfromtmpstack (&val);
(*v).data.flvalue = true;
return (true);
} /*tableassignverb*/
static boolean dbsetvalueverb (hdltreenode hparam1, tyvaluerecord *vreturned) {
tyodbrecord odbrec;
bigstring bsaddress;
odbValueRecord value;
tyvaluerecord val;
boolean flerror;
if (!getodbvalue (hparam1, 1, &odbrec, false))
return (false);
if (!getstringvalue (hparam1, 2, bsaddress))
return (false);
flnextparamislast = true;
if (!getparamvalue (hparam1, 3, &val))
return (false);
if (!copyvaluedata (&val))
return (false);
value.valuetype = (odbValueType) langexternalgettypeid (val);
/*
if (val.valuetype == binaryvaluetype)
pullfromhandle (val.data.binaryvalue, 0L, sizeof (value.valuetype), &value.valuetype);
*/
value.data.binaryvalue = val.data.binaryvalue; /*largest field covers everything*/
flerror = odberror (odbsetvalue (odbrec.odb, bsaddress, &value));
disposevaluerecord (val, false);
if (flerror)
return (false);
return (setbooleanvalue (true, vreturned));
} /*dbsetvalueverb*/
static int matchsequence(char *start,char *end,const char *pattern,
char symbols[MAX_OPT_VARS+1][MAX_ALIAS+1],
int *match_length)
{
int var,i,optsym;
char str[MAX_ALIAS+1];
char *start_org=start;
cell value;
char *ptr;
*match_length=0;
optsym=FALSE;
for (var=0; var<=MAX_OPT_VARS; var++)
symbols[var][0]='\0';
while (*start=='\t' || *start==' ')
start++;
while (*pattern) {
if (start>=end)
return FALSE;
switch (*pattern) {
case '%': /* new "symbol" */
pattern++;
assert(isdigit(*pattern));
var=atoi(pattern);
assert(var>=0 && var<=MAX_OPT_VARS);
assert(*start=='-' || alphanum(*start) || optsym);
for (i=0; start<end && (*start=='-' || *start=='+' || alphanum(*start)); i++,start++) {
assert(i<=MAX_ALIAS);
str[i]=*start;
} /* for */
str[i]='\0';
if (var==0) {
/* match only if the parameter is numeric and in the range of a half cell */
const char *ptr;
/* getparamvalue() resolves leading '-' on values and adds multiple
* values (the peephole optimizer may create such variants)
*/
ucell v=getparamvalue(str,&ptr);
if (*ptr>' ' || v>=((ucell)1<<((pc_cellsize*4)-1)) && v<=~((ucell)1<<((pc_cellsize*4)-1)))
return FALSE;
/* reconvert the value to a string (without signs or expressions) */
ptr=itoh(v);
#if !defined NDEBUG
assert(strlen(ptr)==2*pc_cellsize);
assert((ptr[0]=='0' || ptr[0]=='f') && (ptr[1]=='0' || ptr[1]=='f'));
if (pc_cellsize>=32)
assert((ptr[2]=='0' || ptr[2]=='f') && (ptr[3]=='0' || ptr[3]=='f'));
if (pc_cellsize>=64) {
assert((ptr[4]=='0' || ptr[4]=='f') && (ptr[5]=='0' || ptr[5]=='f'));
assert((ptr[6]=='0' || ptr[6]=='f') && (ptr[7]=='0' || ptr[7]=='f'));
} /* if */
#endif
if (v==0) {
str[0]='0'; /* make zero transform to '0' rather than '0000' */
str[1]='\0';
} else {
memmove(str,ptr+pc_cellsize,pc_cellsize+1);
} /* if */
} /* if */
if (symbols[var][0]!='\0') {
if (strcmp(symbols[var],str)!=0)
return FALSE; /* symbols should be identical */
} else {
strcpy(symbols[var],str);
} /* if */
optsym=FALSE;
break;
case '-':
value=-hex2cell(pattern+1,&pattern);
ptr=itoh((ucell)value);
while (*ptr!='\0') {
if (tolower(*start) != tolower(*ptr))
return FALSE;
start++;
ptr++;
} /* while */
pattern--; /* there is an increment following at the end of the loop */
break;
case '+':
value=hex2cell(pattern+1,&pattern);
ptr=itoh((ucell)value);
while (*ptr!='\0') {
if (tolower(*start) != tolower(*ptr))
return FALSE;
start++;
ptr++;
} /* while */
pattern--; /* there is an increment following at the end of the loop */
break;
case ' ': /* required whitespace */
if (*start!='\t' && *start!=' ')
return FALSE;
while (start<end && (*start=='\t' || *start==' '))
start++;
break;
case '~': /* optional whitespace (followed by optional symbol) */
while (start<end && (*start=='\t' || *start==' '))
start++;
optsym= (pattern[1]=='%');
break;
case '!':
while (start<end && (*start=='\t' || *start==' '))
start++; /* skip trailing white space */
if (*start==';')
while (start<end && *start!='\n')
start++; /* skip trailing comment */
if (*start!='\n')
return FALSE;
assert(*(start+1)=='\0');
start+=2; /* skip '\n' and '\0' */
if (*(pattern+1)!='\0')
while (start<end && *start=='\t' || *start==' ')
start++; /* skip leading white space of next instruction */
break;
default:
if (tolower(*start) != tolower(*pattern))
return FALSE;
start++;
} /* switch */
pattern++;
} /* while */
*match_length=(int)(start-start_org);
return TRUE;
}
static boolean sysfunctionvalue (short token, hdltreenode hparam1, tyvaluerecord *vreturned, bigstring bserror) {
//
// 2006-06-28 creedon: for Mac, FSRef-ized
//
// 5.0b16 dmb: undo that change. it affect performance adversely if many threads do it.
//
// 5.0b12 dmb: in systemtaskfunc, set flresting to false to make sure we don't slow down too much
//
// 1/18/93 dmb: in systemtaskfunc, don't call processyield directly; use langbackgroundtask
//
// 8/11/92 dmb: make apprunningfunc accept a string or an ostype
//
// 5/20/92 dmb: do processyield directly on systemtaskfunc
//
// 2/12/92 dmb: do partialeventloop on systemtask & bringapptofrontfunc
//
register tyvaluerecord *v = vreturned;
setbooleanvalue (false, v); /*assume the worst*/
switch (token) { /*these verbs don't need any special globals pushed*/
case systemversionfunc: {
bigstring bs;
getsystemversionstring (bs, nil);
if (!langcheckparamcount (hparam1, 0))
return (false);
return (setstringvalue (bs, v));
}
case systemtaskfunc:
if (!langcheckparamcount (hparam1, 0)) /*shouldn't have any parameters*/
return (false);
shellsysverbwaitroutine ();
/*
if (!processyield ())
return (false);
*/
if (!langbackgroundtask (true))
return (false);
(*v).data.flvalue = true;
return (true);
case browsenetworkfunc:
#ifdef MACVERSION
return (langipcbrowsenetwork (hparam1, v));
#endif
#ifdef WIN95VERSION
#pragma message ("WIN95: browsenetworkfunc - not yet implemented!")
break;
#endif
case apprunningfunc: {
OSType appid;
bigstring bsapp;
tyvaluerecord val;
flnextparamislast = true;
/*
if (!getostypevalue (hparam1, 1, &appid))
return (false);
(*v).data.flvalue = findrunningapplication (&appid, nil);
*/
if (!getparamvalue (hparam1, 1, &val))
return (false);
if (val.valuetype == ostypevaluetype) {
setemptystring (bsapp);
appid = val.data.ostypevalue;
}
else {
if (!coercetostring (&val))
return (false);
pullstringvalue (&val, bsapp);
if (!stringtoostype (bsapp, &appid))
appid = 0;
}
(*v).data.flvalue = findrunningapplication (&appid, bsapp, nil);
return (true);
}
case frontappfunc: {
bigstring bs;
if (!langcheckparamcount (hparam1, 0))
return (false);
if (!getfrontapplication (bs, false))
return (false);
return (setstringvalue (bs, v));
}
case bringapptofrontfunc: {
bigstring bs;
flnextparamislast = true;
if (!getstringvalue (hparam1, 1, bs))
return (false);
(*v).data.flvalue = activateapplication (bs);
return (true);
}
case countappsfunc:
if (!langcheckparamcount (hparam1, 0))
return (false);
return (setlongvalue (countapplications (), v));
case getnthappfunc: {
short n;
bigstring bs;
if (!getintvalue (hparam1, 1, &n))
return (false);
if (!getnthapplication (n, bs))
setemptystring (bs);
return (setstringvalue (bs, v));
}
case getapppathfunc: {
bigstring bs;
tyfilespec fs;
flnextparamislast = true;
if ( ! getstringvalue ( hparam1, 1, bs ) )
return ( false );
if ( ! getapplicationfilespec ( bs, &fs ) ) // 2006-02-17 aradke: initializes fs even if it fails
setemptystring (bs);
return ( setfilespecvalue ( &fs, v ) );
}
case memavailfunc:
{
unsigned long memavail;
#ifdef WIN95VERSION
MEMORYSTATUS meminfo;
meminfo.dwLength = sizeof (MEMORYSTATUS);
GlobalMemoryStatus (&meminfo);
memavail = meminfo.dwAvailVirtual;
#endif
#ifdef MACVERSION
memavail = TempFreeMem();
#endif
if (!langcheckparamcount (hparam1, 0)) /*shouldn't have any parameters*/
return (false);
return (setlongvalue (memavail, v));
}
case machinefunc:
#ifdef MACVERSION
//Code change by Timothy Paustian Friday, June 16, 2000 3:13:09 PM
//Changed to Opaque call for Carbon
//Carbon only runs on PPC
#if TARGET_API_MAC_CARBON
return (setstringvalue (machinePPC, v));
#else
#if GENERATINGPOWERPC
return (setstringvalue (machinePPC, v));
#endif
#if GENERATING68K
return (setstringvalue (machine68K, v));
#endif
#endif
#endif
#ifdef WIN95VERSION
return (setstringvalue (machinex86, v));
#endif
break;
case osfunc:
return (sysos (v));
break;
#ifdef WIN95VERSION
case getenvironmentvariablefunc: {
bigstring bsenvname;
bigstring buf;
DWORD res;
flnextparamislast = true;
if (!getstringvalue (hparam1, 1, bsenvname))
return (false);
nullterminate(bsenvname);
res = GetEnvironmentVariable (stringbaseaddress(bsenvname), stringbaseaddress(buf), sizeof(buf)-2);
if (res > sizeof(buf) - 2) {
return (setbooleanvalue (false, v)); //safety valve
}
setstringlength (buf, res);
return (setstringvalue (buf, v));
}
break;
case setenvironmentvariablefunc: {
bigstring bsenvname;
bigstring bsenvval;
bigstring bserror, bserror2;
boolean res;
if (!getstringvalue (hparam1, 1, bsenvname))
return (false);
flnextparamislast = true;
if (!getstringvalue (hparam1, 2, bsenvval))
return (false);
nullterminate(bsenvname);
nullterminate(bsenvval);
res = SetEnvironmentVariable (stringbaseaddress(bsenvname), stringbaseaddress(bsenvval));
if (res) {
return (setbooleanvalue (true, v));
}
getsystemerrorstring (GetLastError(), bserror);
nullterminate(bserror);
wsprintf (bserror2, "Can't set environment variable \"%s\" to \"%s\" because %s", stringbaseaddress (bsenvname), stringbaseaddress (bsenvval), stringbaseaddress (bserror));
setstringlength (bserror2, strlen(stringbaseaddress(bserror2)));
shellerrormessage (bserror2);
return (setbooleanvalue (false, v));
}
break;
#endif
#if TARGET_API_MAC_CARBON == 1
case unixshellcommandfunc: { /*7.0b51 PBS: call shell on OS X*/
Handle hcommand, hreturn;
flnextparamislast = true;
if (!getexempttextvalue (hparam1, 1, &hcommand))
return (false);
newemptyhandle (&hreturn);
if (!unixshellcall (hcommand, hreturn)) {
disposehandle (hreturn);
disposehandle (hcommand);
return (false);
} /*if*/
disposehandle (hcommand);
return (setheapvalue (hreturn, stringvaluetype, v));
}
#endif
#ifdef WIN95VERSION
case winshellcommandfunc: {
Handle hcommand;
Handle houttext = nil;
Handle herrtext = nil;
long exitcode = 0;
tyaddress adrexitcode, adrstderr;
short ctconsumed = 1;
short ctpositional = 1;
boolean flneedexitcode, flneedstderr;
tyvaluerecord val;
if (!getexempttextvalue (hparam1, 1, &hcommand))
return (false);
if (!getoptionaladdressparam (hparam1, &ctconsumed, &ctpositional, "\x0b" "adrExitCode", &adrexitcode.ht, adrexitcode.bs))
return (false);
flnextparamislast = true;
if (!getoptionaladdressparam (hparam1, &ctconsumed, &ctpositional, "\x0b" "adrStdErr", &adrstderr.ht, adrstderr.bs))
return (false);
flneedexitcode = (adrexitcode.ht != nil) || !isemptystring (adrexitcode.bs);
flneedstderr = (adrstderr.ht != nil) || !isemptystring (adrstderr.bs);
newemptyhandle (&houttext);
if (flneedstderr)
newemptyhandle (&herrtext);
if (!winshellcall (hcommand, houttext, herrtext,
(flneedexitcode ? &exitcode : nil))) {
disposehandle (houttext);
disposehandle (herrtext);
disposehandle (hcommand);
return (false);
} /*if*/
disposehandle (hcommand);
if (flneedexitcode) {
setlongvalue (exitcode, &val);
if (!langsetsymboltableval (adrexitcode.ht, adrexitcode.bs, val))
return (false);
}
if (flneedstderr) {
setheapvalue (herrtext, stringvaluetype, &val);
if (!langsetsymboltableval (adrstderr.ht, adrstderr.bs, val))
return (false);
exemptfromtmpstack (&val);
}
return (setheapvalue (houttext, stringvaluetype, v));
}
#endif //WIN95VERSION
default:
break;
}
getstringlist (langerrorlist, unimplementedverberror, bserror);
return (false);
} /*sysfunctionvalue*/
static boolean threadfunctionvalue (short token, hdltreenode hparam1, tyvaluerecord *vreturned, bigstring bserror) {
/*
4.1b3 dmb: new verbs
4.1b5 dmb: added thread.sleep
4.1b6 dmb: make thread.sleepFor take seconds, not ticks
5.0d13 dmb: added v == nil check
*/
register tyvaluerecord *v = vreturned;
typrocessid processid;
unsigned long ticks;
if (v == nil) { /*need Frontier process?*/
switch (token) {
case evaluatefunc:
case callscriptfunc:
case sleepfunc:
case sleepforfunc:
case sleepticksfunc:
case issleepingfunc:
case wakefunc:
case killfunc:
/*
case begincriticalfunc:
case endcriticalfunc:
*/
case statsfunc:
return (true);
case existsfunc:
case getcurrentfunc:
case getcountfunc:
case getnththreadfunc:
case gettimeslicefunc:
case getdefaulttimeslicefunc:
case settimeslicefunc:
case setdefaulttimeslicefunc:
default:
return (false);
}
}
setbooleanvalue (false, v); // assume the worst
processid = getcurrentprocessid ();
if (!iscurrentapplication (processid)) {
getstringlist (langerrorlist, cantbackgroundclipboard, bserror); // ***
return (false);
}
switch (token) {
case existsfunc: {
long id;
flnextparamislast = true;
if (!getlongvalue (hparam1, 1, &id))
return (false);
return (setbooleanvalue (getprocessthread (id) != nil, v));
}
case evaluatefunc: {
Handle htext;
hdlprocessrecord hp;
hdlprocessthread hthread;
flnextparamislast = true;
if (!getexempttextvalue (hparam1, 1, &htext))
return (false);
newlyaddedprocess = nil; //process manager global
if (!processruntext (htext))
return (false);
hp = newlyaddedprocess; //process.c global; will be nil if a process wasn't just added
if ((hp == nil) || !scheduleprocess (hp, &hthread))
return (setlongvalue (0, v));
(**hp).processstartedroutine = &threadverbprocessstarted;
return (setlongvalue (getthreadid (hthread), v));
}
case callscriptfunc: {
bigstring bsscriptname;
tyvaluerecord vparams;
hdlhashtable hcontext = nil;
boolean fl;
if (!getstringvalue (hparam1, 1, bsscriptname))
return (false);
if (!getparamvalue (hparam1, 2, &vparams))
return (false);
if (vparams.valuetype != recordvaluetype)
if (!coercetolist (&vparams, listvaluetype))
return (false);
if (langgetparamcount (hparam1) > 2) {
flnextparamislast = true;
if (!gettablevalue (hparam1, 3, &hcontext))
return (false);
}
(**(getcurrentthreadglobals ())).debugthreadingcookie = token;
fl = threadcallscriptverb (bsscriptname, vparams, hcontext, v);
(**(getcurrentthreadglobals ())).debugthreadingcookie = 0;
return (fl);
}
case getcurrentfunc:
if (!langcheckparamcount (hparam1, 0))
return (false);
return (setlongvalue (getthreadid (getcurrentthread ()), v));
case getcountfunc:
if (!langcheckparamcount (hparam1, 0))
return (false);
return (setlongvalue (processthreadcount (), v));
case getnththreadfunc: {
short n;
flnextparamislast = true;
if (!getintvalue (hparam1, 1, &n))
return (false);
return (setlongvalue (getthreadid (nthprocessthread (n)), v));
}
case sleepfunc: {
hdlprocessthread hthread;
flnextparamislast = true;
if (!getthreadvalue (hparam1, 1, &hthread))
return (false);
return (setbooleanvalue (processsleep (hthread, -1), v));
}
case sleepforfunc: {
long n;
boolean fl;
flnextparamislast = true;
if (!getlongvalue (hparam1, 1, &n))
return (false);
(**(getcurrentthreadglobals ())).debugthreadingcookie = token;
fl = processsleep (getcurrentthread (), n * 60);
(**(getcurrentthreadglobals ())).debugthreadingcookie = 0;
return (setbooleanvalue (fl, v));
}
case sleepticksfunc: {
long n;
boolean fl;
flnextparamislast = true;
if (!getlongvalue (hparam1, 1, &n))
return (false);
(**(getcurrentthreadglobals ())).debugthreadingcookie = token;
fl = processsleep (getcurrentthread (), n);
(**(getcurrentthreadglobals ())).debugthreadingcookie = 0;
return (setbooleanvalue (fl, v));
}
case issleepingfunc: {
hdlprocessthread hthread;
flnextparamislast = true;
if (!getthreadvalue (hparam1, 1, &hthread))
return (false);
return (setbooleanvalue (processissleeping (hthread), v));
}
case wakefunc: {
hdlprocessthread hthread;
flnextparamislast = true;
if (!getthreadvalue (hparam1, 1, &hthread))
return (false);
return (setbooleanvalue (wakeprocessthread (hthread), v));
}
case killfunc: {
hdlprocessthread hthread;
flnextparamislast = true;
if (!getthreadvalue (hparam1, 1, &hthread))
return (false);
return (setbooleanvalue (killprocessthread (hthread), v));
}
case gettimeslicefunc:
if (!langcheckparamcount (hparam1, 0))
return (false);
getprocesstimeslice (&ticks);
return (setlongvalue (ticks, v));
case settimeslicefunc:
flnextparamislast = true;
if (!getlongvalue (hparam1, 1, (long *) (&ticks)))
return (false);
return (setbooleanvalue (setprocesstimeslice (ticks), v));
case getdefaulttimeslicefunc:
if (!langcheckparamcount (hparam1, 0))
return (false);
getdefaulttimeslice (&ticks);
return (setlongvalue (ticks, v));
case setdefaulttimeslicefunc:
flnextparamislast = true;
if (!getlongvalue (hparam1, 1, (long *) (&ticks)))
return (false);
return (setbooleanvalue (setdefaulttimeslice (ticks), v));
/*
case begincriticalfunc:
if (!langcheckparamcount (hparam1, 0))
return (false);
++fldisableyield;
return (setbooleanvalue (true, v));
case endcriticalfunc:
if (!langcheckparamcount (hparam1, 0))
return (false);
if (fldisableyield > 0) {
--fldisableyield;
(*v).data.flvalue = true;
}
return (true);
*/
case statsfunc:
return (threadstatsverb (hparam1, v));
default:
return (false);
}
} /*threadfunctionvalue*/
