PSImpl.mesa
Copyright © 1986 by Xerox Corporation. All rights reserved.
Doug Wyatt, October 30, 1986 4:28:00 pm PST
DIRECTORY
Atom USING [PropList],
IO USING [STREAM],
PS,
RefTab USING [Ref],
Rope USING [ROPE];
PSImpl: PROGRAM
~ BEGIN OPEN PS;
Internal stuff
Registration
Register: PROC [self: Root, name: LONG STRING, value: Any] ~ {
key: Name ~ MakeName[self, name];
Put[self.sysdict, key, value];
};
RegisterOp: PROC [rope: ROPE, op: Op] ~ {
Register[rope, AnyFromOp[op]];
};
InitErrorNames: PROC [self: Root] ~ {
dictfull ← NameFromRope["dictfull"];
dictstackoverflow ← NameFromRope["dictstackoverflow"];
dictstackunderflow ← NameFromRope["dictstackunderflow"];
execstackoverflow ← NameFromRope["execstackoverflow"];
handleerror ← NameFromRope["handleerror"];
interrupt ← NameFromRope["interrupt"];
invalidaccess ← NameFromRope["invalidaccess"];
invalidexit ← NameFromRope["invalidexit"];
invalidfileaccess ← NameFromRope["invalidfileaccess"];
invalidfont ← NameFromRope["invalidfont"];
invalidrestore ← NameFromRope["invalidrestore"];
ioerror ← NameFromRope["ioerror"];
limitcheck ← NameFromRope["limitcheck"];
nocurrentpoint ← NameFromRope["nocurrentpoint"];
rangecheck ← NameFromRope["rangecheck"];
stackoverflow ← NameFromRope["stackoverflow"];
stackunderflow ← NameFromRope["stackunderflow"];
syntaxerror ← NameFromRope["syntaxerror"];
timeout ← NameFromRope["timeout"];
typecheck ← NameFromRope["typecheck"];
undefined ← NameFromRope["undefined"];
undefinedfilename ← NameFromRope["undefinedfilename"];
undefinedresult ← NameFromRope["undefinedresult"];
unmatchedmark ← NameFromRope["unmatchedmark"];
unregistered ← NameFromRope["unregistered"];
VMerror ← NameFromRope["VMerror"];
};
Initialize: PROC [self: Root] ~ {
self.xfor ← MakeOp[self, Xfor];
self.xrepeat ← MakeOp[self, Xrepeat];
self.xloop ← MakeOp[self, Xloop];
self.xforall ← MakeOp[self, Xforall];
systemdict:
Register["[", Pmark];
Register["]", Pconstructarray];
Register["aload", Paload];
Register["anchorsearch", Panchorsearch];
Register["and", Pand];
Register["arc", Parc];
Register["arcn", Parcn];
Register["arcto", Parcto];
Register["array", Parray];
Register["ashow", Pashow];
Register["astore", Pastore];
Register["awidthshow", Pawidthshow];
Register["begin", Pbegin];
Register["bind", Pbind];
Register["bitshift", Pbitshift];
Register["bytesavailable", Pbytesavailable];
Register["cachestatus", Pcachestatus];
Register["cexec", Pcexec]; -- *
Register["charpath", Pcharpath];
Register["clear", Pclear];
Register["clearinterrupt", Pclearinterrupt]; -- *
Register["cleartomark", Pcleartomark];
Register["clip", Pclip];
Register["clippath", Pclippath];
Register["closefile", Pclosefile];
Register["closepath", Pclosepath];
Register["concat", Pconcat];
Register["concatmatrix", Pconcatmatrix];
Register["copy", Pcopy];
Register["copypage", Pcopypage];
Register["count", Pcount];
Register["countdictstack", Pcountdictstack];
Register["countexecstack", Pcountexecstack];
Register["counttomark", Pcounttomark];
Register["currentcacheparams", Pcurrentcacheparams]; -- *
Register["currentdash", Pcurrentdash];
Register["currentdict", Pcurrentdict];
Register["currentfile", Pcurrentfile];
Register["currentflat", Pcurrentflat];
Register["currentfont", Pcurrentfont];
Register["currentgray", Pcurrentgray];
Register["currenthsbcolor", Pcurrenthsbcolor];
Register["currentlinecap", Pcurrentlinecap];
Register["currentlinejoin", Pcurrentlinejoin];
Register["currentlinewidth", Pcurrentlinewidth];
Register["currentmatrix", Pcurrentmatrix];
Register["currentmiterlimit", Pcurrentmiterlimit];
Register["currentpacking", Pcurrentpacking]; -- *
Register["currentpoint", Pcurrentpoint];
Register["currentrgbcolor", Pcurrentrgbcolor];
Register["currentscreen", Pcurrentscreen];
Register["currenttransfer", Pcurrenttransfer];
Register["curveto", Pcurveto];
Register["cvi", Pcvi];
Register["cvlit", Pcvlit];
Register["cvn", Pcvn];
Register["cvr", Pcvr];
Register["cvrs", Pcvrs];
Register["cvs", Pcvs];
Register["cvx", Pcvx];
Register["daytime", Pdaytime]; -- *
Register["def", Pdef];
Register["defaultmatrix", Pdefaultmatrix];
Register["definefont", Pdefinefont];
Register["dict", Pdict];
Register["dictstack", Pdictstack];
Register["disableinterrupt", Pdisableinterrupt]; -- *
Register["div", Pdiv];
Register["dtransform", Pdtransform];
Register["dup", Pdup];
Register["echo", Pecho];
Register["eexec", Peexec]; -- *
Register["enableinterrupt", Penableinterrupt]; -- *
Register["end", Pend];
Register["eoclip", Peoclip];
Register["eofill", Peofill];
Register["eq", Peq];
Register["erasepage", Perasepage];
Register["exch", Pexch];
Register["exec", Pexec];
Register["execstack", Pexecstack];
Register["executeonly", Pexecuteonly];
Register["exit", Pexit];
Register["exp", Pexp];
Register["file", Pfile];
Register["fill", Pfill];
Register["findfont", Pfindfont];
Register["flattenpath", Pflattenpath];
Register["floor", Pfloor];
Register["flush", Pflush];
Register["flushfile", Pflushfile];
Register["for", Pfor];
Register["forall", Pforall];
Register["framedevice", Pframedevice];
Register["ge", Pge];
Register["get", Pget];
Register["getinterval", Pgetinterval];
Register["grestore", Pgrestore];
Register["grestoreall", Pgrestoreall];
Register["gsave", Pgsave];
Register["gt", Pgt];
Register["identmatrix", Pidentmatrix];
Register["idiv", Pidiv];
Register["idtransform", Pidtransform];
Register["if", Pif];
Register["ifelse", Pifelse];
Register["image", Pimage];
Register["imagemask", Pimagemask];
Register["index", Pindex];
Register["initclip", Pinitclip];
Register["initgraphics", Pinitgraphics];
Register["initmatrix", Pinitmatrix];
Register["internaldict", Pinternaldict]; -- *
Register["invermatrix", Pinvermatrix];
Register["itransform", Pitransform];
Register["known", Pknown];
Register["kshow", Pkshow];
Register["le", Ple];
Register["length", Plength];
Register["lineto", Plineto];
Register["ln", Pln];
Register["load", Pload];
Register["log", Plog];
Register["loop", Ploop];
Register["lt", Plt];
Register["makefont", Pmakefont];
Register["makevm", Pmakevm]; -- *
Register["mark", Pmark];
Register["matrix", Pmatrix];
Register["maxlength", Pmaxlength];
Register["mod", Pmod];
Register["moveto", Pmoveto];
Register["mul", Pmul];
Register["ne", Pne];
Register["neg", Pneg];
Register["newpath", Pnewpath];
Register["noaccess", Pnoaccess];
Register["not", Pnot];
Register["nulldevice", Pnulldevice];
Register["or", Por];
Register["packedarray", Ppackedarray]; -- *
Register["pathbbox", Ppathbbox];
Register["pathforall", Ppathforall];
Register["pop", Ppop];
Register["print", Pprint];
Register["psdevice", Ppsdevice]; -- *
Register["put", Pput];
Register["putinterval", Pputinterval];
Register["quit", Pquit];
Register["rand", Prand];
Register["rcheck", Prcheck];
Register["rcurveto", Prcurveto];
Register["read", Pread];
Register["readhexstring", Preadhexstring];
Register["readline", Preadline];
Register["readonly", Preadonly];
Register["readstring", Preadstring];
Register["repeat", Prepeat];
Register["resetfile", Presetfile];
Register["restore", Prestore];
Register["reversepath", Preversepath];
Register["rlineto", Prlineto];
Register["rmoveto", Prmoveto];
Register["roll", Proll];
Register["rotate", Protate];
Register["round", Pround];
Register["rrand", Prrand];
Register["run", Prun];
Register["save", Psave];
Register["scale", Pscale];
Register["scalefont", Pscalefont];
Register["search", Psearch];
Register["setcachedevice", Psetcachedevice];
Register["setcachelimit", Psetcachelimit];
Register["setcacheparams", Psetcacheparams]; -- *
Register["setcharwidth", Psetcharwidth];
Register["setdash", Psetdash];
Register["setflat", Psetflat];
Register["setfont", Psetfont];
Register["setgray", Psetgray];
Register["sethsbcolor", Psethsbcolor];
Register["setlinecap", Psetlinecap];
Register["setlinejoin", Psetlinejoin];
Register["setlinewidth", Psetlinewidth];
Register["setmatrix", Psetmatrix];
Register["setmiterlimit", Psetmiterlimit];
Register["setpacking", Psetpacking]; -- *
Register["setram", Psetram]; -- *
Register["setrgbcolor", Psetrgbcolor];
Register["setrom", Psetrom]; -- *
Register["setscreen", Psetscreen];
Register["settransfer", Psettransfer];
Register["show", Pshow];
Register["showpage", Pshowpage];
Register["sin", Psin];
Register["sqrt", Psqrt];
Register["srand", Psrand];
Register["status", Pstatus];
Register["stop", Pstop];
Register["stopped", Pstopped];
Register["store", Pstore];
Register["string", Pstring];
Register["stringwidth", Pstringwidth];
Register["stroke", Pstroke];
Register["strokepath", Pstrokepath];
Register["sub", Psub];
Register["token", Ptoken];
Register["transform", Ptransform];
Register["translate", Ptranslate];
Register["truncate", Ptruncate];
Register["type", Ptype];
Register["usertime", Pusertime];
Register["vmstatus", Pvmstatus];
Register["wcheck", Pwcheck];
Register["where", Pwhere];
Register["widthshow", Pwidthshow];
Register["write", Pwrite];
Register["writehexstring", Pwritehexstring];
Register["writestring", Pwritestring];
Register["xcheck", Pxcheck];
Register["xor", Pxor];
RegisterOb["null", null];
RegisterOb["true", AnyFromBool[TRUE]];
RegisterOb["false", AnyFromBool[FALSE]];
RegisterOb["$error", Ob]; -- *
RegisterOb[".error", Ob]; -- *
RegisterOb["=", Ob];
RegisterOb["==", Ob];
RegisterOb["=print", Ob]; -- * {dup type /stringtype ne {<=string> cvs} if print}
RegisterOb["=string", Ob]; -- * <128 string>
RegisterOb["errordict", Ob];
RegisterOb["FontDirectory", Ob];
RegisterOb["handleerror", Ob];
RegisterOb["initialized", Ob]; -- *
RegisterOb["Run", Ob]; -- *
RegisterOb["stack", Ob];
RegisterOb["StandardEncoding", Ob];
RegisterOb["statusdict", Ob]; -- *
RegisterOb["systemdict", Ob];
RegisterOb["userdict", Ob];
RegisterOb["version", Ob];
userdict:
RegisterOb["$idleTimeDict"L, Ob];
RegisterOb["legal"L, Ob];
RegisterOb["execdict"L, Ob];
RegisterOb["pstack"L, Ob];
RegisterOb["$printerdict"L, Ob];
RegisterOb["ReadIdleFonts"L, Ob];
RegisterOb["b5"L, Ob];
RegisterOb["a4small"L, Ob];
RegisterOb["a4"L, Ob];
RegisterOb["cleardictstack"L, Ob];
RegisterOb["letter"L, Ob];
RegisterOb["UseIdleTime"L, Ob];
RegisterOb["executive"L, Ob];
RegisterOb["lettersmall"L, Ob];
RegisterOb["#copies"L, Ob];
RegisterOb["note"L, Ob];
RegisterOb["serverdict"L, Ob];
RegisterOb["start"L, Ob];
RegisterOb["prompt"L, Ob];
RegisterOb["quit"L, Ob];
};
Primitive operators
Dictionary operators
Munch: PROC [n: Basics.LongNumber] RETURNS [CARDINAL] ~ INLINE {
RETURN [Basics.BITXOR[n.hi, n.lo]];
};
Hash: PROC [x: Any] RETURNS [CARDINAL] ~ {
WITH x: x SELECT FROM
integer => RETURN [Munch[[li[x.int]]]];
real => RETURN [Munch[[real[x.real]]]];
boolean => RETURN [ORD[n.bool]];
array => RETURN [Munch[[lp[x.finger]]]];
string => RETURN [HashString[x]];
name => RETURN [x.id];
dictionary => RETURN [Munch[[lp[x.finger]]]];
operator => RETURN [LOOPHOLE[x.op]];
file => RETURN [x.id];
ENDCASE => RETURN [42];
};
InlineHash: PROC [x: Any] RETURNS [CARDINAL] ~ {
RETURN [WITH x: x SELECT FROM name => x.id, ENDCASE => Hash[x]];
};
Key: PROC [x: Any] RETURNS [Any] ~ {
WITH x: x SELECT FROM
null => ERROR Error[typecheck];
string => RETURN [NameFromString[x]];
ENDCASE => RETURN [x];
};
InlineKey: PROC [x: Any] RETURNS [Any] ~ INLINE {
RETURN [WITH x: x SELECT FROM name => x, ENDCASE => Key[x]];
};
Lookup: PROC [d: DictPointer, key: Any] RETURNS [found: BOOL, tuple: TuplePointer] ~ {
loc: DictIndex ← InlineHash[key] MOD d.maxLength;
THROUGH [0..d.maxLength) DO
tuple ← @d[loc];
IF tuple.key.type=null THEN RETURN [FALSE, tuple];
IF Eq[key, tuple.key] THEN RETURN [TRUE, tuple];
loc ← IF loc<d.maxLength THEN loc+1 ELSE 0;
ENDLOOP;
RETURN [FALSE, NIL];
};
Put: PROC [dict: Dict, key: Any, value: Any] ~ {
d: DictPointer ~ DictAccess[dict, unlimited];
found: BOOL; tuple: TuplePointer;
[found, tuple] ← Lookup[d, key ← InlineKey[key]];
IF found THEN tuple.value ← value
ELSE IF d.length>=d.maxLength THEN ERROR Error[dictfull]
ELSE { tuple^ ← [key: key, value: value]; d.length ← d.length+1 };
};
TryToGet: PROC [dict: Dict, key: Any] RETURNS [found: BOOL, value: Any] ~ {
};
Get: PROC [dict: Dict, key: Any] RETURNS [value: Any] ~ {
};
Store: PROC [self: Root, key: Any, value: Any] ~ {
};
TryToLoad: PROC [self: Root, key: Any] RETURNS [found: BOOL, value: Any] ~ {
};
Load: PROC [self: Root, key: Any] RETURNS [value: Any] ~ {
};
Known: PROC [dict: Dict, key: Any] RETURNS [BOOL] ~ {
};
Where: PROC [self: Root, key: Any] RETURNS [found: BOOL, dict: Dict] ~ {
};
Pdict: PROC [self: Root] ~ {
int: INT ~ PopInt[self.ostack];
IF int IN DictIndex THEN Push[self.ostack, NewDict[self, int]]
ELSE ERROR Error[rangecheck];
};
Pmaxlength: PROC [self: Root] ~ {
dict: Dict ~ PopDict[self.ostack];
PushInt[self.ostack, DictAccess[dict, readOnly].maxLength];
};
Pbegin: PROC [self: Root] ~ {
dict: Dict ~ PopDict[self.ostack];
Push[self.dstack, dict];
};
Pend: PROC [self: Root] ~ {
IF self.dstack.count>2 THEN [] ← Pop[self.dstack]
ELSE ERROR Error[dictstackunderflow];
};
Pdef: PROC [self: Root] ~ {
value: Any ~ Pop[self.ostack];
key: Any ~ Pop[self.ostack];
dict: Dict ~ CurrentDict[self];
Put[dict, key, value];
};
Pload: PROC [self: Root] ~ {
key: Any ~ Pop[self.ostack];
value: Any ~ Load[self, key];
Push[self.ostack, value];
};
Pstore: PROC [self: Root] ~ {
value: Any ~ Pop[self.ostack];
key: Any ~ Pop[self.ostack];
Store[self, key, value];
};
Pknown: PROC [self: Root] ~ {
key: Any ~ Pop[self.ostack];
dict: Dict ~ PopDict[self.ostack];
PushBool[self.ostack, Known[dict, key]];
};
Pwhere: PROC [self: Root] ~ {
};
Pcurrentdict: PROC [self: Root] ~ {
Push[self.ostack, CurrentDict[self]];
};
Pcountdictstack: PROC [self: Root] ~ {
PushInt[self.ostack, self.dstack.count];
};
Pdictstack: PROC [self: Root] ~ {
array: Array ← PopArray[self.ostack];
count: ArrayIndex ~ self.dstack.count;
IF array.length<count THEN ERROR Error[rangecheck];
array.length ← count;
AStore[self.dstack, array];
self.dstack.count ← count;
Push[self.ostack, array];
};
Scanning
CharInfo: TYPE ~ RECORD [
newline: BOOL ← FALSE,
whitespace: BOOL ← FALSE,
special: BOOL ← FALSE,
decimal: BOOL ← FALSE,
hex: BOOL ← FALSE,
digit: [0..15] ← 0
];
CharInfoArray: TYPE ~ ARRAY CHAR OF CharInfo;
charInfo: REF CharInfoArray ~ InitCharInfo[];
InitCharClass: PROC RETURNS [c: REF CharInfoArray] ~ {
info ← NEW [CharInfoArray ← ALL[[]]];
info[Ascii.LF].newline ← TRUE;
info[Ascii.CR].newline ← TRUE;
info[Ascii.SP].whitespace ← TRUE;
info[Ascii.TAB].whitespace ← TRUE;
info[Ascii.LF].whitespace ← TRUE;
info[Ascii.CR].whitespace ← TRUE;
info['(].special ← TRUE;
info[')].special ← TRUE;
info['<].special ← TRUE;
info['>].special ← TRUE;
info['{].special ← TRUE;
info['}].special ← TRUE;
info['/].special ← TRUE;
info['%].special ← TRUE;
FOR c: CHAR IN ['0..'9] DO
info[c].decimal ← TRUE;
info[c].hex ← TRUE;
info[c].digit ← (c-'0);
ENDLOOP;
FOR c: CHAR IN ['A..'F] DO
info[c].hex ← TRUE;
info[c].digit ← 10+(c-'A);
ENDLOOP;
FOR c: CHAR IN ['a..'f] DO
info[c].hex ← TRUE;
info[c].digit ← 10+(c-'a);
ENDLOOP;
};
StringToken: PROC [self: Root, string: String, access: Access ← readOnly]
RETURNS [found: BOOL, token: Any, post: String] ~ {
pointer: StringBase ~ StringAccess[string, access];
state: ScanState ← null;
pnest: INT ← 0; -- nesting depth of parens
end: BOOL ← FALSE;
i: StringIndex ← string.start;
stop: StringIndex ~ string.start+string.length;
WHILE i<stop DO
char: CHAR ~ pointer[i];
SELECT charClass[char] FROM
whitespace, newline => i ← i+1;
ENDCASE => EXIT;
REPEAT FINISHED => {
post ← string; post.start ← i; post.length ← 0;
RETURN [found: FALSE, token: null, post: post];
};
ENDLOOP;
FOR i: StringIndex IN [0..string.length) DO
char: CHAR ~ pointer[i];
info: CharInfo ~ charInfo[char];
{
SELECT state FROM
null => {
IF char.whitespace THEN { GOTO Skip };
IF char.decimal THEN { state ← int; GOTO NameChar };
SELECT char FROM
'( => { state ← string; stringNest ← 0; GOTO StringBegin }; -- begin string
') => { GOTO SyntaxError }; -- syntax error
'< => { state ← hex1 }; -- begin string
'> => { GOTO SyntaxError }; -- syntax error
'{ => { procNest ← procNest+1 };
'} => { procNest ← procNest-1 };
'/ => { state ← name; literal ← TRUE }; -- single character names
'[, '] => { state ← name; EXIT }; -- single character names
'% => { state ← comment }; -- begin comment
'+ => { state ← plus }; -- might begin number or name
'- => { state ← minus }; -- might begin number or name
'. => { state ← dot }; -- might begin real or name
IN['0..'9] => { state ← int }; -- begin integer
ENDCASE => { state ← name }; -- begin name
};
SELECT char FROM
Ascii.SP, Ascii.TAB, Ascii.CR, Ascii.LF => NULL;
'( => { state ← string; stringNest ← 0; GOTO StringBegin }; -- begin string
') => { GOTO SyntaxError }; -- syntax error
'< => { state ← hex1 }; -- begin string
'> => { GOTO SyntaxError }; -- syntax error
'{ => { procNest ← procNest+1 };
'} => { procNest ← procNest-1 };
'/ => { state ← name; literal ← TRUE }; -- single character names
'[, '] => { state ← name; EXIT }; -- single character names
'% => { state ← comment }; -- begin comment
'+ => { state ← plus }; -- might begin number or name
'- => { state ← minus }; -- might begin number or name
'. => { state ← dot }; -- might begin real or name
IN['0..'9] => { state ← int }; -- begin integer
ENDCASE => { state ← name }; -- begin name
string => SELECT char FROM
'( => { stringNest ← stringNest+1; GOTO StringChar };
') => { stringNest ← stringNest-1;
IF stringNest>0 THEN GOTO StringChar ELSE GOTO StringEnd };
'\\ => { state ← esc0; GOTO Skip };
ENDCASE => GOTO StringChar;
esc0 => SELECT char FROM
Ascii.LF => { state ← string; GOTO Skip };
'n => { state ← string; code ← ORD[Ascii.LF]; GOTO StringCode };
'r => { state ← string; code ← ORD[Ascii.CR]; GOTO StringCode };
't => { state ← string; code ← ORD[Ascii.TAB]; GOTO StringCode };
'b => { state ← string; code ← ORD[Ascii.BS]; GOTO StringCode };
'f => { state ← string; code ← ORD[Ascii.FF]; GOTO StringCode };
IN['0..'9] => { state ← esc1; code ← (char-'0); GOTO Skip };
ENDCASE => { state ← string; GOTO StringChar };
esc1 => SELECT char FROM
IN['0..'9] => { state ← esc2; code ← code*8+(char-'0); GOTO Skip };
ENDCASE => { state ← string; GOTO StringCodeAndChar };
esc2 => SELECT char FROM
IN['0..'9] => { state ← string; code ← code*8+(char-'0); GOTO StringCode };
ENDCASE => { state ← string; GOTO StringCodeAndChar };
hex0 => {
IF info.hex THEN { state ← hex1; code ← info.digit*16; GOTO Skip }
ELSE GOTO SyntaxError;
};
hex1 => {
IF info.hex THEN { state ← hex0; code ← code+info.digit; GOTO StringCode }
ELSE GOTO SyntaxError;
};
name => GOTO TestForEnd; -- test for end of name
plus => SELECT char FROM
IN['0..'9] => { state ← int }; -- first integer digit
'. => { state ← dot }; -- might start a real
ENDCASE => GOTO TestForEnd; -- make it a name
minus => SELECT char FROM
IN['0..'9] => { state ← int }; -- first integer digit
'. => { state ← dot }; -- might start a real
ENDCASE => { state ← name }; -- make it a name
dot => SELECT char FROM
IN['0..'9] => { state ← frac }; -- first fraction digit
ENDCASE => { state ← name }; -- no digits after dot
int => SELECT char FROM
IN['0..'9] => { }; -- extend integer
'. => { state ← frac }; -- fraction coming
'E, 'e => { state ← exp1 }; -- exponent coming
ENDCASE => { state ← name }; -- integer ends here
frac => SELECT char FROM
IN['0..'9] => { }; -- extend fraction
'E, 'e => { state ← exp1 }; -- exponent coming
ENDCASE => GOTO TestForEnd; -- real with fraction ends here
exp1 => SELECT char FROM
'+, '- => { state ← exp2 }; -- exponent sign
IN['0..'9] => { state ← exp3 }; -- first exponent digit
ENDCASE => GOTO TestForEnd; -- make it a name
exp2 => SELECT char FROM
IN['0..'9] => { state ← exp3 }; -- first exponent digit
ENDCASE => GOTO TestForEnd; -- make it a name
exp3 => SELECT char FROM
IN['0..'9] => { }; -- extend exponent
ENDCASE => GOTO TestForEnd; -- real with exponent ends here
comment => SELECT char FROM
'\n => { token.type ← comment; EXIT }; -- end of comment
ENDCASE => { }; -- skip
ENDCASE => ERROR; -- unknown state
EXITS
ExtendString =>
IF end THEN { token.truncated ← TRUE; token.type ← string; EXIT };
TestForEnd =>
IF class[char]=nil THEN state ← name -- if it doesn't end here, make it a name
ELSE {
token.type ← SELECT state FROM
int, oct => int, frac, exp3 => real, ENDCASE => name;
IF NOT end THEN [] ← reader.Backwards[]; -- put the last character back
EXIT;
};
};
ENDLOOP;
token.len ← reader.GetIndex[]-token.start;
RETURN[token];
};
String operators
Ptoken: PROC [self: Root] ~ {
};
Polymorphic operators
Pforall: PROC [self: Root] ~ {
proc: Proc ~ PopProc[self.ostack];
x: Any ~ Pop[self.ostack];
WITH x: x SELECT FROM
array => {
PushMark[self.estack];
Push[self.estack, proc];
Push[self.estack, x];
Push[self.estack, self.xarrayforall];
};
string => {
PushMark[self.estack];
Push[self.estack, proc];
Push[self.estack, x];
Push[self.estack, self.xstringforall];
};
dictionary => {
DictCopy[to, from];
};
ENDCASE => ERROR Error[typecheck];
};
Xarrayforall: PROC [self: Root] ~ {
array: Array ~ PopArray[self.estack];
proc: Proc ~ TopProc[self.estack];
IF array.length=0 THEN {
[--proc--] ← PopProc[self.estack];
PopMark[self.estack];
}
ELSE {
pointer: ArrayBase ~ ArrayAccess[array, readOnly];
element: Any ~ pointer[array.start];
post: Array ← array;
post.start ← array.start+1;
post.length ← array.length-1;
Push[self.estack, post];
Push[self.estack, self.xarrayforall];
Push[self.estack, proc];
Push[self.ostack, element];
};
};
Xstringforall: PROC [self: Root] ~ {
string: Array ~ PopString[self.estack];
proc: Any ~ Top[self.estack];
IF string.length=0 THEN {
[--proc--] ← Pop[self.estack];
PopMark[self.estack];
}
ELSE {
pointer: StringBase ~ StringAccess[string, readOnly];
element: CHAR ~ pointer[string.start];
post: String ← string;
post.start ← string.start+1;
post.length ← string.length-1;
Push[self.estack, post];
Push[self.estack, self.xstringforall];
Push[self.estack, proc];
PushInt[self.ostack, ORD[element]];
};
};
Relational, boolean, and bitwise operators
ArrayEq: PROC [a1, a2: Array] RETURNS [BOOL] ~ {
pointer1: ArrayBase ~ ArrayAccess[a1, readOnly];
pointer2: ArrayBase ~ ArrayAccess[a2, readOnly];
RETURN [pointer1=pointer2 AND a1.start=a2.start AND a1.length=a2.length];
};
StringCompare: PROC [s1, s2: String] RETURNS [Basics.Comparison] ~ {
pointer1: StringBase ~ StringAccess[s1, readOnly];
pointer2: StringBase ~ StringAccess[s2, readOnly];
FOR i: NAT IN [0..MIN[s1.length, s2.length]) DO
c1: CHAR ~ pointer1[s1.start+i];
c2: CHAR ~ pointer2[s2.start+i];
IF c1#c2 THEN RETURN [IF c1<c2 THEN less ELSE greater];
ENDLOOP
IF s1.length=s2.length THEN RETURN [equal]
ELSE RETURN [IF s1.length<s2.length THEN less ELSE greater];
};
StringEq: PROC [s1, s2: String] RETURNS [BOOL] ~ {
pointer1: StringBase ~ StringAccess[s1, readOnly];
pointer2: StringBase ~ StringAccess[s2, readOnly];
IF s1.length#s2.length THEN RETURN [FALSE];
FOR i: NAT IN [0..s1.length) DO
c1: CHAR ~ pointer1[s1.start+i];
c2: CHAR ~ pointer2[s2.start+i];
IF c1#c2 THEN RETURN [FALSE];
ENDLOOP
RETURN [TRUE];
};
Eq: PROC [x1, x2: Any] RETURNS [eq: BOOL ← FALSE] ~ {
WITH x1: x1 SELECT FROM
null => WITH x2: x2 SELECT FROM
null => RETURN [TRUE];
ENDCASE;
integer => WITH x2: x2 SELECT FROM
integer => RETURN [x1.int=x2.int];
real => RETURN [x1.int=x2.real];
ENDCASE;
real => WITH x2: x2 SELECT FROM
integer => RETURN [x1.real=x2.int];
real => RETURN [x1.real=x2.real];
ENDCASE;
boolean => WITH x2: x2 SELECT FROM
boolean => RETURN [x1.bool=x2.bool];
ENDCASE;
array => WITH x2: x2 SELECT FROM
array => RETURN [ArrayEq[x1, x2]];
ENDCASE;
string => WITH x2: x2 SELECT FROM
string => RETURN [StringEq[x1, x2]];
name => RETURN [StringEq[x1, StringFromName[x2]]];
ENDCASE;
name => WITH x2: x2 SELECT FROM
string => RETURN [StringEq[StringFromName[x1], x2]];
name => RETURN [x1.id=x2.id];
ENDCASE;
dictionary => WITH x2: x2 SELECT FROM
dictionary => RETURN [x1.finger=x2.finger];
ENDCASE;
operator => WITH x2: x2 SELECT FROM
operator => RETURN [x1.op=x2.op];
ENDCASE;
file => WITH x2: x2 SELECT FROM
file => RETURN [x1.id=x2.id];
ENDCASE;
mark => WITH x2: x2 SELECT FROM
mark => RETURN [TRUE];
ENDCASE;
ENDCASE;
RETURN [FALSE];
};
InlineEq: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE {
WITH x1: x1 SELECT FROM
name => WITH x2: x2 SELECT FROM
name => RETURN[x1.id=x2.id];
ENDCASE;
ENDCASE;
RETURN[Eq[x1, x2]];
};
Ge: PROC [x1, x2: Any] RETURNS [BOOL] ~ {
WITH x1: x1 SELECT FROM
integer => WITH x2: x2 SELECT FROM
integer => RETURN [x1.int>=x2.int];
real => RETURN [x1.int>=x2.real];
ENDCASE => ERROR Error[typecheck];
real => WITH x2: x2 SELECT FROM
integer => RETURN [x1.int>=x2.real];
real => RETURN [x1.int>=x2.real];
ENDCASE => ERROR Error[typecheck];
string => WITH x2: x2 SELECT FROM
string => RETURN [StringCompare[x1, x2]#less];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Gt: PROC [x1, x2: Any] RETURNS [BOOL] ~ {
WITH x1: x1 SELECT FROM
integer => WITH x2: x2 SELECT FROM
integer => RETURN [x1.int>x2.int];
real => RETURN [x1.int>x2.real];
ENDCASE => ERROR Error[typecheck];
real => WITH x2: x2 SELECT FROM
integer => RETURN [x1.int>x2.real];
real => RETURN [x1.int>x2.real];
ENDCASE => ERROR Error[typecheck];
string => WITH x2: x2 SELECT FROM
string => RETURN [StringCompare[x1, x2]=greater];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Ne: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE { RETURN [NOT Eq[x1, x2]] };
Lt: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE { RETURN [NOT Ge[x1, x2]] };
Le: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE { RETURN [NOT Gt[x1, x2]] };
Peq: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
PushBool[self.ostack, Eq[x1, x2]];
};
Pne: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
PushBool[self.ostack, Ne[x1, x2]];
};
Pge: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
PushBool[self.ostack, Ge[x1, x2]];
};
Pgt: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
PushBool[self.ostack, Gt[x1, x2]];
};
Ple: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
PushBool[self.ostack, Le[x1, x2]];
};
Plt: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
PushBool[self.ostack, Lt[x1, x2]];
};
Pand: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
WITH x1: x1 SELECT FROM
integer => WITH x2: x2 SELECT FROM
integer => PushInt[self.ostack, Basics.DoubleAnd[[li[x1.int]], [li[x2.int]]].li];
ENDCASE => ERROR Error[typecheck];
boolean => WITH x2: x2 SELECT FROM
boolean => PushBool[self.ostack, x1.bool AND x2.bool];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Pnot: PROC [self: Root] ~ {
x1: Any ~ Pop[self.ostack];
WITH x1: x1 SELECT FROM
integer => PushInt[self.ostack, Basics.DoubleNot[[li[x1.int]]].li];
boolean => PushBool[self.ostack, NOT x1.bool];
ENDCASE => ERROR Error[typecheck];
};
Por: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
WITH x1: x1 SELECT FROM
integer => WITH x2: x2 SELECT FROM
integer => PushInt[self.ostack, Basics.DoubleOr[[li[x1.int]], [li[x2.int]]].li];
ENDCASE => ERROR Error[typecheck];
boolean => WITH x2: x2 SELECT FROM
boolean => PushBool[self.ostack, x1.bool OR x2.bool];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Pxor: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
x1: Any ~ Pop[self.ostack];
WITH x1: x1 SELECT FROM
integer => WITH x2: x2 SELECT FROM
integer => PushInt[self.ostack, Basics.DoubleXor[[li[x1.int]], [li[x2.int]]].li];
ENDCASE => ERROR Error[typecheck];
boolean => WITH x2: x2 SELECT FROM
boolean => PushBool[self.ostack, x1.bool#x2.bool];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Pbitshift: PROC [self: Root] ~ {
shift: INT ~ PopInt[self.ostack];
int1: INT ~ PopInt[self.ostack];
PushInt[self.ostack, IF shift IN(-32..32) THEN Basics.DoubleShift[[li[int1]], shift].li ELSE 0];
};
File operators
Pfile: PROC [self: Root] ~ {
};
Pclosefile: PROC [self: Root] ~ {
};
Pread: PROC [self: Root] ~ {
};
Pwrite: PROC [self: Root] ~ {
};
Preadhexstring: PROC [self: Root] ~ {
};
Pwritehexstring: PROC [self: Root] ~ {
};
Preadstring: PROC [self: Root] ~ {
};
Pwritestring: PROC [self: Root] ~ {
};
Preadline: PROC [self: Root] ~ {
};
Pbytesavailable: PROC [self: Root] ~ {
};
Pflush: PROC [self: Root] ~ {
};
Pflushfile: PROC [self: Root] ~ {
};
Presetfile: PROC [self: Root] ~ {
};
Pstatus: PROC [self: Root] ~ {
};
Prun: PROC [self: Root] ~ {
};
Pcurrentfile: PROC [self: Root] ~ {
};
Pprint: PROC [self: Root] ~ {
};
Pecho: PROC [self: Root] ~ {
};
Virtual memory operators
Psave: PROC [self: Root] ~ {
};
Prestore: PROC [self: Root] ~ {
};
Pvmstatus: PROC [self: Root] ~ {
};
Miscellaneous operators
Pbind: PROC [self: Root] ~ {
};
Pusertime: PROC [self: Root] ~ {
};
Painting operators
Perasepage: PROC [self: Root] ~ {
};
Pfill: PROC [self: Root] ~ {
};
Peofill: PROC [self: Root] ~ {
};
Pstroke: PROC [self: Root] ~ {
};
Pimage: PROC [self: Root] ~ {
};
Pimagemask: PROC [self: Root] ~ {
};
Device setup and output operators
Pshowpage: PROC [self: Root] ~ {
};
Pcopypage: PROC [self: Root] ~ {
};
Pbanddevice: PROC [self: Root] ~ {
};
Pframedevice: PROC [self: Root] ~ {
};
Pnulldevice: PROC [self: Root] ~ {
};
Prenderbands: PROC [self: Root] ~ {
};
Character and font operators
Pdefinefont: PROC [self: Root] ~ {
};
Pfindfont: PROC [self: Root] ~ {
};
Pscalefont: PROC [self: Root] ~ {
};
Pmakefont: PROC [self: Root] ~ {
};
Psetfont: PROC [self: Root] ~ {
};
Pcurrentfont: PROC [self: Root] ~ {
};
Pshow: PROC [self: Root] ~ {
};
Pashow: PROC [self: Root] ~ {
};
Pwidthshow: PROC [self: Root] ~ {
};
Pawidthshow: PROC [self: Root] ~ {
};
Pkshow: PROC [self: Root] ~ {
};
Pstringwidth: PROC [self: Root] ~ {
};
Font cache operators
Pcachestatus: PROC [self: Root] ~ {
};
Psetcachedevice: PROC [self: Root] ~ {
};
Psetcharwidth: PROC [self: Root] ~ {
};
Psetcachelimit: PROC [self: Root] ~ {
};
END.