static boolean dbgetvalueverb (hdltreenode hparam1, tyvaluerecord *vreturned) {
/*
4.1.1b1 dmb: fixed memory leak; push value on temp stack
5.0b17 dmb: use pushtmpstackvalue to put external types returned from
the other odb onto our temp stack
5.0.1 dmb: but only pushtmpstack if heapallocated
*/
tyodbrecord odbrec;
bigstring bsaddress;
odbValueRecord value;
tyvaluetype type;
if (!getodbvalue (hparam1, 1, &odbrec, true))
return (false);
flnextparamislast = true;
if (!getstringvalue (hparam1, 2, bsaddress))
return (false);
if (odberror (odbgetvalue (odbrec.odb, bsaddress, &value)))
return (false);
type = langexternalgetvaluetype (value.valuetype);
if (type == (tyvaluetype) -1) {
return (setbinaryvalue (value.data.binaryvalue, value.valuetype, vreturned));
}
else {
initvalue (vreturned, type);
(*vreturned).data.binaryvalue = value.data.binaryvalue;
if (langheapallocated (vreturned, nil))
pushtmpstackvalue (vreturned); //5.0b17
return (true);
/*
initvalue (&val, type);
val.data.binaryvalue = value.data.binaryvalue;
return (copyvaluerecord (val, vreturned));
*/
}
} /*dbgetvalueverb*/
pascal boolean odbSetValue (odbref odb, bigstring bspath, odbValueRecord *value) {
hdlhashtable htable;
bigstring bsname;
tyvaluerecord val;
tyvaluetype type = langexternalgetvaluetype (value->valuetype);
setemptystring (bserror);
#ifndef isFrontier
if (type == externalvaluetype) {
langerrormessage (canthandlethistypeerror);
return (false);
}
#endif
setcancoonglobals ((hdlcancoonrecord) odb);
if (!odbexpandtodotparams (bspath, &htable, bsname))
return (false);
if (type == (tyvaluetype) -1) {
if (!setbinaryvalue (value->data.binaryvalue, value->valuetype, &val))
return (false);
}
else {
initvalue (&val, type);
val.data.binaryvalue = value->data.binaryvalue;
}
if (!copyvaluerecord (val, &val))
return (false);
if (!hashtableassign (htable, bsname, val)) {
disposevaluerecord (val, true);
return (false);
}
exemptfromtmpstack (&val);
return (true);
} /*odbSetValue*/
boolean claycreatefile (const tybrowserspec *fs) {
tyvaluerecord val;
boolean fl;
initvalue (&val, novaluetype);
opstartinternalchange ();
fl = hashtableassign ((*fs).parID, (*fs).name, val);
opendinternalchange ();
return (fl);
} /*claycreatefile*/
boolean winregwrite (Handle h, tyvaluerecord *val, bigstring bstype) {
/*
7.0.2b1 Radio PBS: write a value to the registry.
*/
DWORD regtype;
HKEY hbasekey = HKEY_CURRENT_USER;
bigstring subkey, bsitem;
tyvaluerecord vcopy;
boolean fl = false;
if (equalstrings (bstype, emptystring)) /*no type specified*/
winregfrontiertypetotype ((*val).valuetype, ®type);
else
winregtypestringtotype (bstype, ®type);
if (!winregpullhkeyfromtext (h, &hbasekey))
return (false);
if (!winregiskey (h)) {
texthandletostring (h, subkey);
if (!pullstringsuffix (subkey, bsitem, '\\'))
return (false);
disposehandle (h);
newtexthandle (subkey, &h);
} /*if*/
initvalue (&vcopy, novaluetype);
if (!copyvaluerecord (*val, &vcopy))
return (false);
winregcoercevalue (&vcopy, regtype);
fl = winregdowrite (hbasekey, h, bsitem, &vcopy, regtype);
disposevaluerecord (vcopy, false);
return (fl);
} /*winregwrite*/
boolean langpushlisttext (hdllistrecord hlist, Handle hstring) {
Handle hdata;
tyvaluerecord val;
boolean fl;
initvalue (&val, stringvaluetype);
val.data.stringvalue = hstring;
fl = langpackvalue (val, &hdata, HNoNode);
disposehandle (hstring);
if (fl)
fl = oppushhandle (hlist, nil, hdata);
return (fl);
} /*langpushlisttext*/
pascal void odbDisposeValue (odbref odb, odbValueRecord *value) {
tyvaluetype type;
tyvaluerecord val;
setemptystring (bserror);
setcancoonglobals ((hdlcancoonrecord) odb);
type = langexternalgetvaluetype ((OSType) (*value).valuetype);
if (type == -1) /*no match; must have been a binary value*/
type = binaryvaluetype;
initvalue (&val, type);
val.data.binaryvalue = (*value).data.binaryvalue;
disposevaluerecord (val, false);
} /*odbDisposeValue*/
static void winregcoercetofrontiertype (Handle hvalue, DWORD regtype, tyvaluerecord* v) {
/*
7.0.2b1 Radio PBS: convert a registry value to a Frontier value record, coercing the type.
*/
initvalue (v, novaluetype);
switch (regtype) {
case REG_DWORD:
case REG_DWORD_BIG_ENDIAN:
setlongvalue ((**hvalue), v);
disposehandle (hvalue); /*7.0.1 (Frontier) PBS: In this case hvalue should be consumed.*/
break;
case REG_EXPAND_SZ:
case REG_MULTI_SZ:
case REG_SZ:
setheapvalue (hvalue, stringvaluetype, v);
break;
case REG_BINARY:
case REG_LINK:
case REG_NONE:
case REG_RESOURCE_LIST:
default:
setbinaryvalue (hvalue, '\?\?\?\?', v);
break;
} /*switch*/
} /*winregcoercetofrontiertype*/
int main(int argc, char *argv[]) {
Env env;
XDefreader input;
int doprompt = (argc <= 1) || (strcmp(argv[1], "-q") != 0);
Prompts prompts = doprompt ? STD_PROMPTS : NO_PROMPTS;
initvalue();
initallocate();
/*
* We have many printers.
* <install printers>=
*/
installprinter('c', printclosure);
installprinter('d', printdecimal);
installprinter('e', printexp);
installprinter('E', printexplist);
installprinter('\\', printlambda);
installprinter('n', printname);
installprinter('N', printnamelist);
installprinter('p', printpar);
installprinter('P', printparlist);
installprinter('r', printenv);
installprinter('s', printstring);
installprinter('t', printdef);
installprinter('v', printvalue);
installprinter('V', printvaluelist);
installprinter('%', printpercent);
env = primenv();
/*
* As in the Impcore interpreter, the C representation
* of the initial basis is generated automatically from
* code in [[<<additions to the micro-Scheme initial
* basis>>]].
* <install into [[env]] the additions to the initial basis>=
*/
{
/*
* <C representation of initial basis for {\uscheme}>=
*/
const char *basis=
"(define caar (xs) (car (car xs)))\n"
"(define cadr (xs) (car (cdr xs)))\n"
"(define cdar (xs) (cdr (car xs)))\n"
"(define list1 (x) (cons x '()))\n"
"(define list2 (x y) (cons x (list1 y)))\n"
"(define list3 (x y z) (cons x (list2 y z)))\n"
"(define length (xs)\n"
" (if (null? xs) 0\n"
" (+ 1 (length (cdr xs)))))\n"
"(define and (b c) (if b c b))\n"
"(define or (b c) (if b b c))\n"
"(define not (b) (if b #f #t))\n"
"(define atom? (x) (or (number? x) (or (symbol? x) (or (boolean? x) (null? x)))))\n"
"(define equal? (s1 s2)\n"
" (if (or (atom? s1) (atom? s2))\n"
" (= s1 s2)\n"
" (and (equal? (car s1) (car s2)) (equal? (cdr s1) (cdr s2)))))\n"
"(define append (xs ys)\n"
" (if (null? xs)\n"
" ys\n"
" (cons (car xs) (append (cdr xs) ys))))\n"
"(define revapp (xs ys)\n"
" (if (null? xs)\n"
" ys\n"
" (revapp (cdr xs) (cons (car xs) ys))))\n"
"(define reverse (xs) (revapp xs '()))\n"
"(define mk-alist-pair (k a) (list2 k a))\n"
"(define alist-pair-key (pair) (car pair))\n"
"(define alist-pair-attribute (pair) (cadr pair))\n"
"(define alist-first-key (alist) (alist-pair-key (car alist)))\n"
"(define alist-first-attribute (alist) (alist-pair-attribute (car alist)))\n"
"(define bind (k a alist)\n"
" (if (null? alist)\n"
" (list1 (mk-alist-pair k a))\n"
" (if (equal? k (alist-first-key alist))\n"
" (cons (mk-alist-pair k a) (cdr alist))\n"
" (cons (car alist) (bind k a (cdr alist))))))\n"
"(define find (k alist)\n"
" (if (null? alist) '()\n"
" (if (equal? k (alist-first-key alist))\n"
" (alist-first-attribute alist)\n"
" (find k (cdr alist)))))\n"
"(define o (f g) (lambda (x) (f (g x))))\n"
"(define curry (f) (lambda (x) (lambda (y) (f x y))))\n"
"(define uncurry (f) (lambda (x y) ((f x) y)))\n"
"(define filter (p? xs)\n"
" (if (null? xs)\n"
" '()\n"
" (if (p? (car xs))\n"
" (cons (car xs) (filter p? (cdr xs)))\n"
" (filter p? (cdr xs)))))\n"
"(define map (f xs)\n"
" (if (null? xs)\n"
" '()\n"
" (cons (f (car xs)) (map f (cdr xs)))))\n"
"(define exists? (p? xs)\n"
" (if (null? xs)\n"
" #f\n"
" (if (p? (car xs)) \n"
" #t\n"
" (exists? p? (cdr xs)))))\n"
"(define all? (p? xs)\n"
" (if (null? xs)\n"
" #t\n"
" (if (p? (car xs))\n"
" (all? p? (cdr xs))\n"
" #f)))\n"
"(define foldr (op zero xs)\n"
" (if (null? xs)\n"
" zero\n"
" (op (car xs) (foldr op zero (cdr xs)))))\n"
"(define foldl (op zero xs)\n"
" (if (null? xs)\n"
" zero\n"
" (foldl op (op (car xs) zero) (cdr xs))))\n"
"(define <= (x y) (not (> x y)))\n"
"(define >= (x y) (not (< x y)))\n"
"(define != (x y) (not (= x y)))\n"
"(define max (x y) (if (> x y) x y))\n"
"(define min (x y) (if (< x y) x y))\n"
"(define mod (m n) (- m (* n (/ m n))))\n"
"(define gcd (m n) (if (= n 0) m (gcd n (mod m n))))\n"
"(define lcm (m n) (if (= m 0) 0 (* m (/ n (gcd m n)))))\n"
"(define caar (sx) (car (car sx)))\n"
"(define cdar (sx) (cdr (car sx)))\n"
"(define cadr (sx) (car (cdr sx)))\n"
"(define cddr (sx) (cdr (cdr sx)))\n"
"(define caaar (sx) (car (caar sx)))\n"
"(define cdaar (sx) (cdr (caar sx)))\n"
"(define caadr (sx) (car (cadr sx)))\n"
"(define cdadr (sx) (cdr (cadr sx)))\n"
"(define cadar (sx) (car (cdar sx)))\n"
"(define cddar (sx) (cdr (cdar sx)))\n"
"(define caddr (sx) (car (cddr sx)))\n"
"(define cdddr (sx) (cdr (cddr sx)))\n"
"(define list1 (x) (cons x '()))\n"
"(define list2 (x y) (cons x (list1 y)))\n"
"(define list3 (x y z) (cons x (list2 y z)))\n"
"(define list4 (x y z a) (cons x (list3 y z a)))\n"
"(define list5 (x y z a b) (cons x (list4 y z a b)))\n"
"(define list6 (x y z a b c) (cons x (list5 y z a b c)))\n"
"(define list7 (x y z a b c d) (cons x (list6 y z a b c d)))\n"
"(define list8 (x y z a b c d e) (cons x (list7 y z a b c d e)))\n";
if (setjmp(errorjmp))
assert(0); /* fail if error occurs in basis */
readevalprint(xdefreader(stringreader("initial basis", basis),
NO_PROMPTS), &env, SILENT);
}
input = xdefreader(filereader("standard input", stdin), prompts);
while (setjmp(errorjmp))
;
readevalprint(input, &env, ECHOING);
return 0;
}
void xcmdcallback (void) {
/*
5/4/92 dmb: HyperCard 1.0 XCMD callback emulation
7/8/92 dmb: set return code; use xresNotImp for unknown request
9/25/92 dmb: added SendHCEvent callback support. also spotted & fixed
a bug in ExtToStr handler.
10/3/92 dmb: it turns out that the protocol requires that the caller
of the xcmd put the xcmdptr into a global for us; the xcmd code
doesn't pass it to us consistently.
11/6/92 dmb: use new truncatecstringhandle instead of just popping last char.
also, fixed NumToHex, NumToStr
*/
register XCmdPtr pxcb;
register long *args;
register long *out;
tyvaluerecord val;
bigstring bs;
hdlhashtable htable;
hdlhashnode hnode;
pxcb = plangxcmdrec; /*copy global into register*/
args = (*pxcb).inArgs;
out = (long *) &(*pxcb).outArgs;
(*pxcb).result = xresSucc;
switch ((*pxcb).request) {
/* HyperTalk Utilities */
case 0x02: /*Handle EvalExpr (StringPtr expr)*/
if (!langrunstringnoerror ((ptrstring) args [0], bs))
(*pxcb).result = xresFail;
else {
pushchar (chnul, bs);
newtexthandle (bs, (Handle *) out);
}
break;
case 0x01: /*void SendCardMessage (StringPtr msg)*/
case 0x05: /*void SendHCMessage (StringPtr msg)*/
if (!langrunstringnoerror ((ptrstring) args [0], bs))
(*pxcb).result = xresFail;
break;
/*
case 0x26: /*void RunHandler (Handle handler)%/
break;
*/
/* Memory Utilities */
case 0x12: /*Handle GetGlobal (StringPtr globName)*/
resolvexcmdglobal ((ptrstring) args [0], &htable, bs);
if (hashtablelookup (htable, bs, &val, &hnode)
&& copyvaluerecord (val, &val)
&& coercetostring (&val)
&& enlargehandle (val.data.stringvalue, 1, zerostring)) {
exemptfromtmpstack (&val);
*out = (long) val.data.stringvalue;
}
else
*out = 0L;
break;
case 0x13: /*void SetGlobal (StringPtr globName, Handle globValue)*/
resolvexcmdglobal ((ptrstring) args [0], &htable, bs);
initvalue (&val, stringvaluetype);
if (!copyhandle ((Handle) args [1], &val.data.stringvalue))
(*pxcb).result = xresFail;
else {
truncatecstringhandle (val.data.stringvalue); /*strip zero terminator*/
if (!hashtableassign (htable, bs, val))
disposevaluerecord (val, false);
}
break;
case 0x06: /*void ZeroBytes (Ptr dstPtr, long longCount)*/
clearbytes ((byte *) args [0], args [1]);
break;
/* String Utilities */
case 0x1c: /*void ScanToReturn (Ptr *scanPtr)*/
scantext (chreturn, (ptrbyte *) args [0]);
/*** test: ++*(ptrbyte *) args [0]; /*point past return*/
break;
case 0x27: /*void ScanToZero (Ptr *scanPtr)*/
scantext (chnul, (ptrbyte *) args [0]);
break;
case 0x1a: /*Boolean StringEqual (StringPtr str1, StringPtr str2)*/
*out = (long) equalstrings ((ptrstring) args [0], (ptrstring) args [1]);
break;
case 0x03: { /*long StringLength (Ptr strPtr)*/
*out = scanlength (chnul, (ptrbyte) args [0]);
break;
}
case 0x04: { /*Ptr StringMatch (StringPtr pattern, Ptr target)*/
tysearchparameters saveparams = searchparams;
long ix = 0;
long len;
searchparams.flunicase = false;
searchparams.flwholewords = false;
searchparams.flregexp = false;
copystring ((ptrstring) args [0], searchparams.bsfind);
textsearch ((ptrbyte) args [1], infinity, &ix, &len);
*out = (long) ((ptrbyte) args [1] + ix);
searchparams = saveparams;
break;
}
case 0x20: /*void ZeroTermHandle (Handle hndl)*/
enlargehandle ((Handle) args [0], 1, zerostring);
break;
/* String Conversions */
case 0x10: /*void BoolToStr (Boolean bool, StringPtr str)*/
setbooleanvalue ((Boolean) args [0], &val);
valtostring (&val, (ptrstring) args [1]);
break;
case 0x11: { /*void ExtToStr (extended num, StringPtr str)*/
#if __powerc
long double x;
safex80told ((extended80 *) args [0], &x);
setdoublevalue (x, &val);
#else
setdoublevalue (* (long double *) args [0], &val);
#endif
valtostring (&val, (ptrstring) args [1]);
break;
}
case 0x0d: /*void LongToStr (long posNum, StringPtr str)*/
setlongvalue ((unsigned long) args [0], &val); /*11/6/92 dmb*/
valtostring (&val, (ptrstring) args [1]);
break;
case 0x0f: { /*void NumToHex (long num, short nDigits, StringPtr str)*/
long n = args [0];
byte hex [16];
if (args [1] <= 4)
n = (short) n;
numbertohexstring (n, hex); /*11/6/92 dmb*/
deletestring (hex, 1, 2); /*remove the "0x"*/
copystring (hex, (ptrstring) args [2]);
break;
}
case 0x0e: /*void NumToStr (long num, StringPtr str)*/
setlongvalue ((long) args [0], &val); /*11/6/92 dmb*/
valtostring (&val, (ptrstring) args [1]);
break;
case 0x07: /*Handle PasToZero (StringPtr str)*/
copystring ((ptrstring) args [0], bs);
pushchar (chnul, bs);
newtexthandle (bs, (Handle *) out);
break;
case 0x2b: /*void PointToStr (Point pt, StringPtr str)*/
setpointvalue (*(Point *) args [0], &val);
valtostring (&val, (ptrstring) args [1]);
break;
case 0x2c: /*void RectToStr (Rect *rct, StringPtr str)*/
newheapvalue ((Rect *) args [0], longsizeof (Rect), rectvaluetype, &val);
valtostring (&val, (ptrstring) args [1]);
break;
case 0x1b: /*void ReturnToPas (Ptr zeroStr, StringPtr pasStr)*/
texttostring ((ptrbyte) args [0], scanlength (chreturn, (ptrbyte) args [0]), (ptrstring) args [1]);
break;
case 0x0b: /*Boolean StrToBool (StringPtr str)*/
stringtoval ((ptrstring) args [0], booleanvaluetype, &val);
*out = (long) val.data.flvalue;
break;
case 0x0c: { /*extended StrToExt (StringPtr str)*/
#if __powerc
long double x;
stringtoval ((ptrstring) args [0], doublevaluetype, &val);
x = **val.data.doublevalue;
safeldtox80 (&x, (extended80 *) args [1]);
#else
stringtoval ((ptrstring) args [0], doublevaluetype, &val);
*(double *) args [1] = **val.data.doublevalue;
#endif
break;
}
case 0x09: /*long StrToLong (StringPtr str)*/
stringtoval ((ptrstring) args [0], longvaluetype, &val);
*out = abs (val.data.longvalue);
break;
case 0x0a: /*long StrToNum (StringPtr str)*/
stringtoval ((ptrstring) args [0], longvaluetype, &val);
*out = (long) val.data.longvalue;
break;
case 0x2d: /*void StrToPoint (StringPtr str, Point *pt)*/
stringtoval ((ptrstring) args [0], pointvaluetype, &val);
*(Point *) args [1] = val.data.pointvalue;
break;
case 0x2e: /*void StrToRect (StringPtr str, Rect *rct)*/
stringtoval ((ptrstring) args [0], rectvaluetype, &val);
*(Rect *) args [1] = **val.data.rectvalue;
break;
case 0x08: /*void ZeroToPas (Ptr zeroStr, StringPtr pasStr)*/
texttostring ((ptrbyte) args [0], scanlength (chnul, (ptrbyte) args [0]), (ptrstring) args [1]);
break;
#if 0
/* Field Utilities */
case 0x16: /*Handle GetFieldByID (Boolean cardFieldFlag, short fieldID)*/
newfilledhandle (zerostring, 1L, (Handle *) out);
break;
case 0x14: /*Handle GetFieldByName (Boolean cardFieldFlag, StringPtr fieldName)*/
newfilledhandle (zerostring, 1L, (Handle *) out);
break;
case 0x15: /*Handle GetFieldByNum (Boolean cardFieldFlag, short fieldNum)*/
newfilledhandle (zerostring, 1L, (Handle *) out);
break;
case 0x19: /*void SetFieldByID (Boolean cardFieldFlag, short fieldID, Handle fieldVal)*/
break;
case 0x17: /*void SetFieldByName (Boolean cardFieldFlag, StringPtr fieldName, Handle fieldVal)*/
break;
case 0x18: /*void SetFieldByNum (Boolean cardFieldFlag, short fieldNum, Handle fieldVal)*/
break;
case 0x2f: /*TEHandle GetFieldTE (Boolean cardFieldFlag, short fieldID, short fieldNum, StringPtr fieldNamePtr)*/
*out = 0;
break;
case 0x30: /*void SetFieldTE (Boolean cardFieldFlag, short fieldID, short fieldNum, StringPtr fieldNamePtr, TEHandle fieldTE)*/
break;
#endif
case 0x22: /*void SendHCEvent(EventRecord *event)*/
/****component***/
shellpostevent ((EventRecord *) &args [0]); /*yes, the event itself is in args*/
shellforcebackgroundtask (); /*come back as soon as possible*/
if (!processyield ()) /*we've been killed*/
(*pxcb).result = xresFail;
break;
default:
*out = 0L;
(*pxcb).result = xresNotImp;
break;
}
plangxcmdrec = pxcb; /*reset in case another xcmd ran in the background*/
} /*xcmdcallback*/
boolean listsubtractvalue (tyvaluerecord *v1, tyvaluerecord *v2, tyvaluerecord *vreturned) {
/*
add the two list values. both lists should be of the same type, since langvalue
does the necessary coercion first. But if one is an AEList and the other an AERecord,
the AE Manager will generate errors if appropriate.
when adding records, only add fields from the 2nd record that don't already exist
in the first
*/
hdllistrecord list1 = (*v1).data.listvalue;
hdllistrecord list2 = (*v2).data.listvalue;
hdllistrecord list3;
long ix1, ix2, n1, n2;
Handle item1, item2;
bigstring key;
//if (!copyvaluerecord (*v1, vreturned))
// return (false);
*vreturned = *v1;
initvalue (v1, novaluetype);
list3 = (*vreturned).data.listvalue;
n1 = opcountlistitems (list1);
n2 = opcountlistitems (list2);
if (opgetisrecord (list3)) {
for (ix1 = 1; ix1 <= n2; ++ix1) { /*delete values that appear in second record*/
if (!opgetlisthandle (list2, ix1, key, &item1))
goto error;
if (opgetlisthandle (list3, -1, key, &item2)) {
if (equalhandles (item1, item2))
opdeletelistitem (list3, -1, key);
}
}
}
else {
ix2 = n1 - n2;
for (ix1 = 0; ix1 <= ix2; ++ix1) {
if (equalsublists (list1, list2, ix1, n2, false)) {
while (--n2 >= 0)
if (!opdeletelistitem (list3, ix1 + 1, nil))
goto error;
break;
}
}
}
return (true);
error:
return (false);
} /*listsubtractvalue*/
boolean listaddvalue (tyvaluerecord *v1, tyvaluerecord *v2, tyvaluerecord *vreturned) {
/*
add the two list values. both lists should be of the same type, since langvalue
does the necessary coercion first. But if one is an AEList and the other an AERecord,
the AE Manager will generate errors if appropriate.
when adding records, only add fields from the 2nd record that don't already exist
in the first
2.1b8 dmb: initialize errcode to noErr, or random error results if adding
two records where the 1st item in record 2 is already in record 1
5.0.2b10 dmb: since we throw away v1 and v2, we can boost performance
by adding directly to v1 and making that the return value.
10.0a1 hra: we were always looping through v2, so adding a long list to a small
list was significantly slower (2x or more) than adding the small list to the long
list. Now we always loop through the shortest of the 2 lists.
*/
hdllistrecord list2;
hdllistrecord list3;
long i, n, m;
Handle hitem, hignore;
bigstring key;
m = opcountlistitems ((*v1).data.listvalue);
n = opcountlistitems ((*v2).data.listvalue);
if ( (m > n) || opgetisrecord ((*v2).data.listvalue) ) {
/* Either the first list is longer than the second:
append to the first, or we are adding records so we want to
de-dupe the entries always in the same way
*/
list2 = (*v2).data.listvalue;
*vreturned = *v1;
initvalue (v1, novaluetype);
list3 = (*vreturned).data.listvalue;
for (i = 1; i <= n; ++i) { /*copy values over from second list*/
if (!opgetlisthandle (list2, i, key, &hitem))
return (false);
if (!copyhandle (hitem, &hitem))
return (false);
if (opgetisrecord (list3)) { /* discard duplicate keys */
if (opgetlisthandle (list3, -1, key, &hignore))
disposehandle (hitem); /* discard the duplicate. don't push it over */
else
oppushhandle (list3, key, hitem);
}
else
oppushhandle (list3, key, hitem);
} /*for*/
} else { /* the second list is longer than the first: prepend to the second */
list2 = (*v1).data.listvalue;
*vreturned = *v2;
initvalue (v2, novaluetype);
list3 = (*vreturned).data.listvalue;
for (i = m; i >= 1; --i) { /*copy values over from first list, in reverse*/
if (!opgetlisthandle (list2, i, key, &hitem))
return (false);
if (!copyhandle (hitem, &hitem))
return (false);
opunshifthandle (list3, key, hitem);
} /*for*/
}
return (true);
} /*listaddvalue*/
int main(int argc, char *argv[]) {
Env env = NULL;
int doprompt = (argc <= 1) || (strcmp(argv[1], "-q") != 0);
initvalue();
initallocate();
/*
* We have many printers.
* <install printers>=
*/
installprinter('c', printclosure);
installprinter('d', printdecimal);
installprinter('e', printexp);
installprinter('E', printexplist);
installprinter('\\', printlambda);
installprinter('n', printname);
installprinter('N', printnamelist);
installprinter('p', printpar);
installprinter('P', printparlist);
installprinter('r', printenv);
installprinter('s', printstring);
installprinter('t', printdef);
installprinter('v', printvalue);
installprinter('V', printvaluelist);
installprinter('%', printpercent);
/*
* <install printers>=
*/
installprinter('S', printstack);
installprinter('F', printoneframe);
installprinter('R', printnoenv);
roots.globals = &env;
roots.stack = emptystack();
addprimitives(&env);
/*
* Standard input should be read after the initial
* basis, but because reading is done on a stack, we
* push it on before the basis.
* <initialize [[roots.sources]] to read first the initial basis, then
[[stdin]]>=
*/
roots.sources =
mkSL(mkSource(xdefreader(filereader("standard input", stdin), doprompt),
stdin, ECHOING),
NULL);
{ /*
* <C representation of initial basis for {\uscheme}>=
*/
const char *basis=
"(define caar (xs) (car (car xs)))\n"
"(define cadr (xs) (car (cdr xs)))\n"
"(define cdar (xs) (cdr (car xs)))\n"
"(define list1 (x) (cons x '()))\n"
"(define list2 (x y) (cons x (list1 y)))\n"
"(define list3 (x y z) (cons x (list2 y z)))\n"
"(define length (xs)\n"
" (if (null? xs) 0\n"
" (+ 1 (length (cdr xs)))))\n"
"(define and (b c) (if b c b))\n"
"(define or (b c) (if b b c))\n"
"(define not (b) (if b #f #t))\n"
"(define atom? (x) (or (number? x) (or (symbol? x) (or (boolean? x) (null? x)))))\n"
"(define equal? (s1 s2)\n"
" (if (or (atom? s1) (atom? s2))\n"
" (= s1 s2)\n"
" (and (equal? (car s1) (car s2)) (equal? (cdr s1) (cdr s2)))))\n"
"(define append (xs ys)\n"
" (if (null? xs)\n"
" ys\n"
" (cons (car xs) (append (cdr xs) ys))))\n"
"(define revapp (xs ys)\n"
" (if (null? xs)\n"
" ys\n"
" (revapp (cdr xs) (cons (car xs) ys))))\n"
"(define reverse (xs) (revapp xs '()))\n"
"(define mk-alist-pair (k a) (list2 k a))\n"
"(define alist-pair-key (pair) (car pair))\n"
"(define alist-pair-attribute (pair) (cadr pair))\n"
"(define alist-first-key (alist) (alist-pair-key (car alist)))\n"
"(define alist-first-attribute (alist) (alist-pair-attribute (car alist)))\n"
"(define bind (k a alist)\n"
" (if (null? alist)\n"
" (list1 (mk-alist-pair k a))\n"
" (if (equal? k (alist-first-key alist))\n"
" (cons (mk-alist-pair k a) (cdr alist))\n"
" (cons (car alist) (bind k a (cdr alist))))))\n"
"(define find (k alist)\n"
" (if (null? alist) '()\n"
" (if (equal? k (alist-first-key alist))\n"
" (alist-first-attribute alist)\n"
" (find k (cdr alist)))))\n"
"(define o (f g) (lambda (x) (f (g x))))\n"
"(define curry (f) (lambda (x) (lambda (y) (f x y))))\n"
"(define uncurry (f) (lambda (x y) ((f x) y)))\n"
"(define filter (p? xs)\n"
" (if (null? xs)\n"
" '()\n"
" (if (p? (car xs))\n"
" (cons (car xs) (filter p? (cdr xs)))\n"
" (filter p? (cdr xs)))))\n"
"(define map (f xs)\n"
" (if (null? xs)\n"
" '()\n"
" (cons (f (car xs)) (map f (cdr xs)))))\n"
"(define exists? (p? xs)\n"
" (if (null? xs)\n"
" #f\n"
" (if (p? (car xs)) \n"
" #t\n"
" (exists? p? (cdr xs)))))\n"
"(define all? (p? xs)\n"
" (if (null? xs)\n"
" #t\n"
" (if (p? (car xs))\n"
" (all? p? (cdr xs))\n"
" #f)))\n"
"(define foldr (op zero xs)\n"
" (if (null? xs)\n"
" zero\n"
" (op (car xs) (foldr op zero (cdr xs)))))\n"
"(define foldl (op zero xs)\n"
" (if (null? xs)\n"
" zero\n"
" (foldl op (op (car xs) zero) (cdr xs))))\n"
"(define <= (x y) (not (> x y)))\n"
"(define >= (x y) (not (< x y)))\n"
"(define != (x y) (not (= x y)))\n"
"(define max (x y) (if (> x y) x y))\n"
"(define min (x y) (if (< x y) x y))\n"
"(define mod (m n) (- m (* n (/ m n))))\n"
"(define gcd (m n) (if (= n 0) m (gcd n (mod m n))))\n"
"(define lcm (m n) (if (= m 0) 0 (* m (/ n (gcd m n)))))\n"
"(define caar (sx) (car (car sx)))\n"
"(define cdar (sx) (cdr (car sx)))\n"
"(define cadr (sx) (car (cdr sx)))\n"
"(define cddr (sx) (cdr (cdr sx)))\n"
"(define caaar (sx) (car (caar sx)))\n"
"(define cdaar (sx) (cdr (caar sx)))\n"
"(define caadr (sx) (car (cadr sx)))\n"
"(define cdadr (sx) (cdr (cadr sx)))\n"
"(define cadar (sx) (car (cdar sx)))\n"
"(define cddar (sx) (cdr (cdar sx)))\n"
"(define caddr (sx) (car (cddr sx)))\n"
"(define cdddr (sx) (cdr (cddr sx)))\n"
"(define list1 (x) (cons x '()))\n"
"(define list2 (x y) (cons x (list1 y)))\n"
"(define list3 (x y z) (cons x (list2 y z)))\n"
"(define list4 (x y z a) (cons x (list3 y z a)))\n"
"(define list5 (x y z a b) (cons x (list4 y z a b)))\n"
"(define list6 (x y z a b c) (cons x (list5 y z a b c)))\n"
"(define list7 (x y z a b c d) (cons x (list6 y z a b c d)))\n"
"(define list8 (x y z a b c d e) (cons x (list7 y z a b c d e)))\n";
roots.sources =
mkSL(mkSource(xdefreader(stringreader("initial basis", basis), 0),
NULL, SILENT),
roots.sources);
}
/*
* The loop looks a bit like the body of the old
* [[readevalprint]]. This version is more resilient to
* errors that occur when a file is read.
* <read definitions until [[roots.sources]] is exhausted>=
*/
while (roots.sources != NULL) {
XDef d;
Source *cursource = &roots.sources->hd;
Source newsource; /* initialized when we hit USE */
while (setjmp(errorjmp))
;
d = readxdef(cursource->xdefs);
if (d == NULL) {
if (cursource->sourcefile != NULL)
fclose(cursource->sourcefile);
/*
* <using error mode [[TESTING]], run unit tests from
[[cursource->tests]], last test first>=
*/
set_error_mode(TESTING);
{ int npassed = tests_passed(cursource->tests, *roots.globals);
int ntests = lengthUL(cursource->tests);
report_test_results(npassed, ntests);
}
set_error_mode(NORMAL);
roots.sources = popSL(roots.sources);
} else switch (d->alt) {
case USE:
/*
* File [[fin]] is closed above, after [[readxdef
* (cursource->xdefs)]] returns [[NULL]].
* <set [[newsource]] to a definition reader for [[d->u.use]]>=
*/
{
const char *filename = nametostr(d->u.use);
FILE *fin = fopen(filename, "r");
if (fin == NULL)
error("cannot open file \"%s\"", filename);
newsource = mkSource(xdefreader(filereader(filename, fin), 0
), fin, ECHOING);
}
roots.sources = mkSL(newsource, roots.sources);
break;
case TEST:
cursource->tests = mkUL(d->u.test, cursource->tests);
break;
case DEF:
env = evaldef(d->u.def, env, cursource->echo);
break;
default:
assert(0);
}
}
return 0;
}
