MesaPSImpl.mesa
Copyright © 1986 by Xerox Corporation. All rights reserved.
Doug Wyatt, October 17, 1986 12:35:33 pm PDT
DIRECTORY
Atom USING [PropList],
IO USING [STREAM],
PS,
RefTab USING [Ref],
Rope USING [ROPE];
PSImpl: PROGRAM
~ BEGIN OPEN PS;
Internal stuff
Allocation
Zero: PROC [where: LONG POINTER, words: INT] ~ {
WHILE words>0 DO
n: CARDINAL ~ MIN[words, CARDINAL.LAST];
PrincOpsUtils.LongZero[where: where, nwords: n];
where ← where+n; words ← words-n;
ENDLOOP;
};
WordCopy: PROC [to: LONG POINTER, from: LONG POINTER, words: INT] ~ {
WHILE words>0 DO
n: CARDINAL ~ MIN[words, CARDINAL.LAST];
PrincOpsUtils.LongCopy[from: from, nwords: n, to: to];
from ← from+n; to ← to+n; words ← words-n;
ENDLOOP;
};
Allocate: PROC [self: Root, words: INT] RETURNS [LONG POINTER] ~ {
pointer: LONG POINTER ~ self.pointer;
Zero[pointer, Basics.NonNegative[words]];
self.pointer ← pointer+words;
RETURN [pointer];
};
NewArray: PROC [self: Root, size: ArrayIndex] RETURNS [Array] ~ {
finger: ArrayFinger ~ self.zone.NEW[ArrayPointer];
finger^ ← self.zone.NEW[ArrayBody[size]];
RETURN [[executable: FALSE, variant: array[
access: unlimited, start: 0, length: size, finger: finger]]];
};
ArrayCopy: PROC [to: ArrayPointer, toStart: ArrayIndex,
from: ArrayPointer, fromStart: ArrayIndex, length: ArrayIndex] ~ {
WordCopy[to: @to[toStart], from: @from[fromStart],
words: Basics.LongMult[SIZE[Any], length]];
};
NewString: PROC [self: Root, size: StringIndex] RETURNS [String] ~ {
finger: StringFinger ~ self.zone.NEW[StringPointer];
finger^ ← self.zone.NEW[StringBody[size]];
RETURN [[executable: FALSE, variant: string[
access: unlimited, start: 0, length: size, finger: finger]]];
};
StringCopy: PROC [to: StringPointer, toStart: StringIndex,
from: StringPointer, fromStart: StringIndex, length: StringIndex] ~ {
PrincOpsUtils.ByteBlt[
to: [blockPointer: to, startIndex: toStart, stopIndexPlusOne: toStart+length],
from: [blockPointer: from, startIndex: fromStart, stopIndexPlusOne: fromStart+length]
];
};
Type conversion
Fix: PROC [real: REAL] RETURNS [INT] ~ { RETURN [Real.Fix[real]] };
IntFromReal: PROC [real: REAL] RETURNS [int: INT ← 0] ~ {
int ← Fix[real ! Real.RealException => CONTINUE];
IF int#real THEN ERROR Error[rangecheck];
};
IntFromAny: PROC [x: Any] RETURNS [INT] ~ {
WITH x: x SELECT FROM
integer => RETURN [x.int];
real => RETURN [IntFromReal[x.real]];
ENDCASE => ERROR Error[typecheck];
};
RealFromAny: PROC [x: Any] RETURNS [REAL] ~ {
WITH x: x SELECT FROM
integer => RETURN [REAL[x.int]];
real => RETURN [x.real];
ENDCASE => ERROR Error[typecheck];
};
BoolFromAny: PROC [x: Any] RETURNS [BOOL] ~ {
WITH x: x SELECT FROM
boolean => RETURN [x.bool];
ENDCASE => ERROR Error[typecheck];
};
AnyFromInt: PROC [int: INT] RETURNS [Any] ~ INLINE {
RETURN [[executable: FALSE, variant: integer[int: int]]];
};
AnyFromReal: PROC [real: REAL] RETURNS [Any] ~ INLINE {
RETURN [[executable: FALSE, variant: real[real: real]]];
};
AnyFromBool: PROC [bool: BOOL] RETURNS [Any] ~ INLINE {
RETURN [[executable: FALSE, variant: boolean[bool: BOOL]]];
};
AnyFromOp: PROC [op: Op] RETURNS [Any] ~ INLINE {
RETURN [[executable: TRUE, variant: operator[op: op]]];
};
Access
InvalidAccess: PROC ~ { ERROR Error[invalidaccess] };
StringAccess: PROC [s: String, access: Access] RETURNS [StringPointer] ~ INLINE {
IF s.access<access THEN InvalidAccess[];
RETURN [IF s.length=0 THEN NIL ELSE s.finger^];
};
ArrayAccess: PROC [a: Array, access: Access] RETURNS [ArrayPointer] ~ INLINE {
IF a.access<access THEN InvalidAccess[];
RETURN [IF a.length=0 THEN NIL ELSE a.finger^];
};
FileAccess: PROC [f: File, access: Access] RETURNS [STREAM] ~ {
IF f.access<access THEN InvalidAccess[];
RETURN [NIL];
};
DictAccess: PROC [d: Dict, access: Access] RETURNS [DictPointer] ~ INLINE {
IF d.finger^.access<access THEN InvalidAccess[];
RETURN [d.finger^];
};
RCheck: PROC [access: Access] RETURNS [BOOL] ~ INLINE { RETURN [access>=readOnly] };
WCheck: PROC [access: Access] RETURNS [BOOL] ~ INLINE { RETURN [access=unlimited] };
Names and Strings
MakeName: PROC [self: Root, text: LONG STRING] RETURNS [Name] ~ {
};
MakeString: PROC [self: Root, text: LONG STRING] RETURNS [String] ~ {
string: String ~ NewString[self, text.length];
pointer: StringPointer ~ StringAccess[string, unlimited];
FOR i: NAT IN[0..text.length) DO pointer[i] ← text[i] ENDLOOP;
RETURN [string];
};
NameFromString: PROC [string: String] RETURNS [Name] ~ {
};
StringFromName: PROC [name: Name] RETURNS [String] ~ {
};
MakeOp: PROC [op: Op] RETURNS [Operator] ~ {
};
Stack operations
Push: PROC [stack: Stack, x: Any] ~ {
count: StackIndex ~ stack.count;
IF count<stack.size THEN { stack.elements[count] ← x; stack.count ← count+1 }
ELSE ERROR Error[stack.overflow];
};
InlinePush: PROC [stack: Stack, x: Any] ~ INLINE {
count: StackIndex ~ stack.count;
IF count<stack.size THEN { stack.elements[count] ← x; stack.count ← count+1 }
ELSE Push[stack, x];
};
Pop: PROC [stack: Stack] RETURNS [x: Any] ~ {
count: StackIndex ~ stack.count;
IF count>0 THEN RETURN [stack.elements[stack.count ← count-1]]
ELSE ERROR Error[stack.underflow];
};
InlinePop: PROC [stack: Stack] RETURNS [Any] ~ INLINE {
count: StackIndex ~ stack.count;
IF count>0 THEN RETURN [stack.elements[stack.count ← count-1]]
ELSE RETURN [Pop[stack]];
};
Top: PROC [stack: Stack] RETURNS [x: Any] ~ {
count: StackIndex ~ stack.count;
IF count>0 THEN RETURN [stack.elements[count-1]]
ELSE ERROR Error[stack.underflow];
};
InlineTop: PROC [stack: Stack] RETURNS [x: Any] ~ INLINE {
count: StackIndex ~ stack.count;
IF count>0 THEN RETURN [stack.elements[count-1]]
ELSE RETURN [Top[stack]];
};
PushInt: PROC [stack: Stack, int: INT] ~ {
InlinePush[stack, AnyFromInt[int]];
};
PushReal: PROC [stack: Stack, real: REAL] ~ {
InlinePush[stack, AnyFromReal[real]];
};
PushBool: PROC [stack: Stack, bool: BOOL] ~ {
InlinePush[stack, AnyFromBool[bool]];
};
PushMark: PROC [stack: Stack] ~ {
InlinePush[stack, [executable: FALSE, variant: mark[]]];
};
PopInt: PROC [stack: Stack] RETURNS [INT] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
integer => RETURN [x.int];
real => RETURN [IntFromReal[x.real]];
ENDCASE => RETURN [IntFromAny[x]];
};
PopReal: PROC [stack: Stack] RETURNS [REAL] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
integer => RETURN [REAL[x.int]];
real => RETURN [x.real];
ENDCASE => RETURN [RealFromAny[x]];
};
PopNum: PROC [stack: Stack] RETURNS [Any] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
integer, real => RETURN [x];
ENDCASE => ERROR Error[typecheck];
};
PopProc: PROC [stack: Stack] RETURNS [Proc] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
array => IF x.executable THEN RETURN [x];
ENDCASE;
ERROR Error[typecheck];
};
PopBool: PROC [stack: Stack] RETURNS [BOOL] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
boolean => RETURN [x.bool];
ENDCASE => RETURN [BoolFromAny[x]];
};
PopArray: PROC [stack: Stack] RETURNS [Array] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
array => RETURN [x];
ENDCASE => ERROR Error[typecheck];
};
PopString: PROC [stack: Stack] RETURNS [String] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
string => RETURN [x];
ENDCASE => ERROR Error[typecheck];
};
PopFile: PROC [stack: Stack] RETURNS [File] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
file => RETURN [x];
ENDCASE => ERROR Error[typecheck];
};
PopDict: PROC [stack: Stack] RETURNS [Dict] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
dictionary => RETURN [x];
ENDCASE => ERROR Error[typecheck];
};
PopMark: PROC [stack: Stack] ~ {
x: Any ~ InlinePop[stack];
WITH x: x SELECT FROM
mark => NULL;
ENDCASE => ERROR Error[typecheck];
};
Execution
Execute: PROC [self: Root, singleStep: BOOL ← FALSE] ~ {
WHILE self.estack.count#0 DO
x: Any ~ Pop[self.estack];
IF x.executable THEN WITH x: x SELECT FROM
operator => {
restoreCount: ArrayIndex ~ self.ostack.count;
x.op[self ! Error => {
errorName: Any ~ Load[ErrorDict[self], error];
self.ostack.count ← restoreCount;
Push[self.ostack, x];
Push[self.estack, Load[ErrorDict[self], error]];
CONTINUE;
}];
};
array => {
pointer: ArrayPointer ~ ArrayAccess[a, executeOnly];
SELECT x.length FROM
0 => NULL; -- 0 elements
1 => Push[self.estack, pointer[x.start]]; -- 1 element
2 => { -- 2 elements: optimize for tail recursion
Push[self.estack, pointer[x.start+1]];
Push[self.estack, pointer[x.start]];
};
ENDCASE => {
post: Array ← x;
post.start ← x.start+1;
post.length ← x.length-1;
Push[self.estack, post]; -- remainder of array
Push[self.estack, pointer[a.start]]; -- first element
};
};
string => {
found: BOOL; token: Any; post: String;
[found, token, post] ← StringToken[self, x, executeOnly];
IF found THEN {
IF post.length#0 THEN Push[self.estack, post];
IF token.executable AND token.type#array THEN Push[self.estack, token]
ELSE Push[self.ostack, token]; -- push literal or defer procedure
};
};
name => {
found: BOOL; value: Any;
[found, value] ← TryToLoad[self, x];
Push[self.estack, IF found THEN value ELSE undefined];
};
file => {
found: BOOL; token: Any;
[found, token] ← FileToken[self, x, executeOnly];
IF found THEN {
Push[self.estack, x];
IF token.executable AND token.type#array THEN Push[self.estack, token]
ELSE Push[self.ostack, token]; -- push literal or defer procedure
};
};
stop => PushBool[self.ostack, FALSE]; -- not stopped
ENDCASE => Push[self.ostack, x] -- anything else is always literal
ELSE Push[self.ostack, x]; -- not executable
IF singleStep THEN EXIT;
ENDLOOP;
};
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 ← NameFromString["dictfull"L];
dictstackoverflow ← NameFromString["dictstackoverflow"L];
dictstackunderflow ← NameFromString["dictstackunderflow"L];
execstackoverflow ← NameFromString["execstackoverflow"L];
handleerror ← NameFromString["handleerror"L];
interrupt ← NameFromString["interrupt"L];
invalidaccess ← NameFromString["invalidaccess"L];
invalidexit ← NameFromString["invalidexit"L];
invalidfileaccess ← NameFromString["invalidfileaccess"L];
invalidfont ← NameFromString["invalidfont"L];
invalidrestore ← NameFromString["invalidrestore"L];
ioerror ← NameFromString["ioerror"L];
limitcheck ← NameFromString["limitcheck"L];
nocurrentpoint ← NameFromString["nocurrentpoint"L];
rangecheck ← NameFromString["rangecheck"L];
stackoverflow ← NameFromString["stackoverflow"L];
stackunderflow ← NameFromString["stackunderflow"L];
syntaxerror ← NameFromString["syntaxerror"L];
timeout ← NameFromString["timeout"L];
typecheck ← NameFromString["typecheck"L];
undefined ← NameFromString["undefined"L];
undefinedfilename ← NameFromString["undefinedfilename"L];
undefinedresult ← NameFromString["undefinedresult"L];
unmatchedmark ← NameFromString["unmatchedmark"L];
unregistered ← NameFromString["unregistered"L];
VMerror ← NameFromString["VMerror"L];
};
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:
RegisterOb["$error"L, Ob]; -- *
RegisterOb[".error"L, Ob]; -- *
RegisterOb["="L, Ob];
RegisterOb["=="L, Ob];
RegisterOb["=print"L, Ob]; -- * {dup type /stringtype ne {<=string> cvs} if print}
RegisterOb["=string"L, Ob]; -- * <128 string>
Register["["L, P];
Register["]"L, P];
Register["abs"L, P];
Register["add"L, P];
Register["aload"L, P];
Register["anchorsearch"L, P];
Register["and"L, P];
Register["arc"L, P];
Register["arcn"L, P];
Register["arcto"L, P];
Register["array"L, P];
Register["ashow"L, P];
Register["astore"L, P];
Register["atan"L, P];
Register["awidthshow"L, P];
Register["begin"L, P];
Register["bind"L, P];
Register["bitshift"L, P];
Register["bytesavailable"L, P];
Register["cachestatus"L, P];
Register["ceiling"L, P];
Register["cexec"L, P]; -- *
Register["charpath"L, P];
Register["clear"L, P];
Register["clearinterrupt"L, P]; -- *
Register["cleartomark"L, P];
Register["clip"L, P];
Register["clippath"L, P];
Register["closefile"L, P];
Register["closepath"L, P];
Register["concat"L, P];
Register["concatmatrix"L, P];
Register["copy"L, P];
Register["copypage"L, P];
Register["cos"L, P];
Register["count"L, P];
Register["countdictstack"L, P];
Register["countexecstack"L, P];
Register["counttomark"L, P];
Register["currentcacheparams"L, P]; -- *
Register["currentdash"L, P];
Register["currentdict"L, P];
Register["currentfile"L, P];
Register["currentflat"L, P];
Register["currentfont"L, P];
Register["currentgray"L, P];
Register["currenthsbcolor"L, P];
Register["currentlinecap"L, P];
Register["currentlinejoin"L, P];
Register["currentlinewidth"L, P];
Register["currentmatrix"L, P];
Register["currentmiterlimit"L, P];
Register["currentpacking"L, P]; -- *
Register["currentpoint"L, P];
Register["currentrgbcolor"L, P];
Register["currentscreen"L, P];
Register["currenttransfer"L, P];
Register["curveto"L, P];
Register["cvi"L, P];
Register["cvlit"L, P];
Register["cvn"L, P];
Register["cvr"L, P];
Register["cvrs"L, P];
Register["cvs"L, P];
Register["cvx"L, P];
Register["daytime"L, P]; -- *
Register["def"L, P];
Register["defaultmatrix"L, P];
Register["definefont"L, P];
Register["dict"L, P];
Register["dictstack"L, P];
Register["disableinterrupt"L, P]; -- *
Register["div"L, P];
Register["dtransform"L, P];
Register["dup"L, P];
Register["echo"L, P];
Register["eexec"L, P]; -- *
Register["enableinterrupt"L, P]; -- *
Register["end"L, P];
Register["eoclip"L, P];
Register["eofill"L, P];
Register["eq"L, P];
Register["erasepage"L, P];
RegisterOb["errordict"L, Ob];
Register["exch"L, P];
Register["exec"L, P];
Register["execstack"L, P];
Register["executeonly"L, P];
Register["exit"L, P];
Register["exp"L, P];
RegisterOb["false"L, AnyFromBool[FALSE]];
Register["file"L, P];
Register["fill"L, P];
RegisterOb["findfont"L, Ob];
Register["flattenpath"L, P];
Register["floor"L, P];
Register["flush"L, P];
Register["flushfile"L, P];
RegisterOb["FontDirectory"L, Ob];
Register["for"L, P];
Register["forall"L, P];
Register["framedevice"L, P];
Register["ge"L, P];
Register["get"L, P];
Register["getinterval"L, P];
Register["grestore"L, P];
Register["grestoreall"L, P];
Register["gsave"L, P];
Register["gt"L, P];
RegisterOb["handleerror"L, Ob];
Register["identmatrix"L, P];
Register["idiv"L, P];
Register["idtransform"L, P];
Register["if"L, P];
Register["ifelse"L, P];
Register["image"L, P];
Register["imagemask"L, P];
Register["index"L, P];
Register["initclip"L, P];
Register["initgraphics"L, P];
RegisterOb["initialized"L, Ob]; -- *
Register["initmatrix"L, P];
Register["internaldict"L, P]; -- *
Register["invermatrix"L, P];
Register["itransform"L, P];
Register["known"L, P];
Register["kshow"L, P];
Register["le"L, P];
Register["length"L, P];
Register["lineto"L, P];
Register["ln"L, P];
Register["load"L, P];
Register["log"L, P];
Register["loop"L, P];
Register["lt"L, P];
Register["makefont"L, P];
Register["makevm"L, P]; -- *
Register["mark"L, P];
Register["matrix"L, P];
Register["maxlength"L, P];
Register["mod"L, P];
Register["moveto"L, P];
Register["mul"L, P];
Register["ne"L, P];
Register["neg"L, P];
Register["newpath"L, P];
Register["noaccess"L, P];
Register["not"L, P];
RegisterOb["null"L, Ob];
Register["nulldevice"L, P];
Register["or"L, P];
Register["packedarray"L, P]; -- *
Register["pathbbox"L, P];
Register["pathforall"L, P];
Register["pop"L, P];
Register["print"L, P];
Register["psdevice"L, P]; -- *
Register["put"L, P];
Register["putinterval"L, P];
Register["quit"L, P];
Register["rand"L, P];
Register["rcheck"L, P];
Register["rcurveto"L, P];
Register["read"L, P];
Register["readhexstring"L, P];
Register["readline"L, P];
Register["readonly"L, P];
Register["readstring"L, P];
Register["repeat"L, P];
Register["resetfile"L, P];
Register["restore"L, P];
Register["reversepath"L, P];
Register["rlineto"L, P];
Register["rmoveto"L, P];
Register["roll"L, P];
Register["rotate"L, P];
Register["round"L, P];
Register["rrand"L, P];
RegisterOb["Run"L, Ob]; -- *
Register["run"L, P];
Register["save"L, P];
Register["scale"L, P];
Register["scalefont"L, P];
Register["search"L, P];
Register["setcachedevice"L, P];
Register["setcachelimit"L, P];
Register["setcacheparams"L, P]; -- *
Register["setcharwidth"L, P];
Register["setdash"L, P];
Register["setflat"L, P];
Register["setfont"L, P];
Register["setgray"L, P];
Register["sethsbcolor"L, P];
Register["setlinecap"L, P];
Register["setlinejoin"L, P];
Register["setlinewidth"L, P];
Register["setmatrix"L, P];
Register["setmiterlimit"L, P];
Register["setpacking"L, P]; -- *
Register["setram"L, P]; -- *
Register["setrgbcolor"L, P];
Register["setrom"L, P]; -- *
Register["setscreen"L, P];
Register["settransfer"L, P];
Register["show"L, P];
Register["showpage"L, P];
Register["sin"L, P];
Register["sqrt"L, P];
Register["srand"L, P];
RegisterOb["stack"L, Ob];
RegisterOb["StandardEncoding"L, Ob];
Register["status"L, P];
RegisterOb["statusdict"L, Ob]; -- *
Register["stop"L, P];
Register["stopped"L, P];
Register["store"L, P];
Register["string"L, P];
Register["stringwidth"L, P];
Register["stroke"L, P];
Register["strokepath"L, P];
Register["sub"L, P];
RegisterOb["systemdict"L, Ob];
Register["token"L, P];
Register["transform"L, P];
Register["translate"L, P];
RegisterOb["true"L, AnyFromBool[TRUE]];
Register["truncate"L, P];
Register["type"L, P];
RegisterOb["userdict"L, Ob];
Register["usertime"L, P];
RegisterOb["version"L, Ob];
Register["vmstatus"L, P];
Register["wcheck"L, P];
Register["where"L, P];
Register["widthshow"L, P];
Register["write"L, P];
Register["writehexstring"L, P];
Register["writestring"L, P];
Register["xcheck"L, P];
Register["xor"L, P];
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
Operand stack manipulation operators
Copy: PROC [stack: Stack, n: INT] ~ {
IF n IN ArrayIndex THEN {
count: ArrayIndex ~ stack.count;
depth: ArrayIndex ~ n;
IF depth>count THEN ERROR Error[stack.underflow];
IF depth>(stack.size-count) THEN ERROR Error[stack.overflow];
ArrayCopy[to: stack.elements, toStart: count,
from: stack.elements, fromStart: count-depth, length: depth];
stack.count ← stack.count+depth;
}
ELSE ERROR Error[rangecheck];
};
Roll: PROC [stack: Stack, n, j: INT] ~ {
count: ArrayIndex ~ stack.count;
IF n<0 THEN ERROR Error[rangecheck];
IF n>count THEN ERROR Error[stack.underflow];
WHILE j<0 DO j ← j+n ENDLOOP;
UNTIL j<n DO j ← j-n ENDLOOP;
IF j#0 THEN {
Reverse: PROC [start, stop: ArrayIndex] ~ INLINE {
FOR i: ArrayIndex IN[0..(stop-start)/2) DO
i1: ArrayIndex ~ start+i; i2: ArrayIndex ~ stop-1-i;
x: Any ~ stack[i1]; stack[i1] ← stack[i2]; stack[i2] ← x;
ENDLOOP;
};
Reverse[count-n, count-j];
Reverse[count-j, count];
Reverse[count-n, count];
};
};
Index: PROC [stack: Stack, n: INT] RETURNS [Any] ~ {
IF n<0 THEN ERROR Error[rangecheck]
ELSE {
count: ArrayIndex ~ stack.count;
IF n<count THEN RETURN[stack[count-1-n]]
ELSE ERROR Error[stack.underflow];
};
};
Clear: PROC [stack: Stack] ~ INLINE { stack.count ← 0 };
Count: PROC [stack: Stack] RETURNS [INT] ~ INLINE { RETURN [stack.count] };
ClearToMark: PROC [stack: Stack] ~ {
count: ArrayIndex ~ stack.count;
FOR i: ArrayIndex DECREASING IN [0..count) DO
IF stack[i].type=mark THEN stack.count ← i;
ENDLOOP;
ERROR Error[unmatchedmark];
};
CountToMark: PROC [stack: Stack] RETURNS [INT] ~ {
count: ArrayIndex ~ stack.count;
FOR i: ArrayIndex DECREASING IN [0..count) DO
IF stack[i].type=mark THEN RETURN [count-(i+1)];
ENDLOOP;
ERROR Error[unmatchedmark];
};
Ppop: PROC [self: Root] ~ {
[] ← Pop[self.ostack];
};
Pexch: PROC [self: Root] ~ {
Roll[self.ostack, 2, 1];
};
Pdup: PROC [self: Root] ~ {
Copy[self.ostack, 2];
};
Pindex: PROC [self: Root] ~ {
n: INT ~ PopInt[self.ostack];
Push[self.ostack, Index[self.ostack, n]];
};
Proll: PROC [self: Root] ~ {
j: INT ~ PopInt[self.ostack];
n: INT ~ PopInt[self.ostack];
Roll[self.ostack, n, j];
};
Pclear: PROC [self: Root] ~ {
Clear[self.ostack];
};
Pcount: PROC [self: Root] ~ {
PushInt[self.ostack, Count[self.ostack]];
};
Pmark: PROC [self: Root] ~ {
PushMark[self.ostack];
};
Pcleartomark: PROC [self: Root] ~ {
ClearToMark[self.ostack];
};
Pcounttomark: PROC [self: Root] ~ {
PushInt[self.ostack, CountToMark[self.ostack]];
};
Arithmetic and math operators
Padd: PROC [self: Root] ~ {
num2: Any ~ Pop[self.ostack];
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => WITH num2: num2 SELECT FROM
integer => {
i1: INT ~ num1.int;
i2: INT ~ num2.int;
i3: INT ~ i1+i2;
IF (i1<0)#(i2<0) OR (i2<0)=(i3<0) THEN PushInt[self.ostack, i3]
ELSE PushReal[self.ostack, REAL[i1]+REAL[i2]];
};
real => PushReal[self.ostack, num1.int+num2.real];
ENDCASE => ERROR Error[typecheck];
real => WITH num2: num2 SELECT FROM
integer => PushReal[self.ostack, num1.real+num2.int];
real => PushReal[self.ostack, num1.real+num2.real];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Psub: PROC [self: Root] ~ {
num2: Any ~ Pop[self.ostack];
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => WITH num2: num2 SELECT FROM
integer => {
i1: INT ~ num1.int;
i2: INT ~ num2.int;
i3: INT ~ i1-i2;
IF (i1<0)=(i2<0) OR (i2<0)#(i3<0) THEN PushInt[self.ostack, i3]
ELSE PushReal[self.ostack, REAL[i1]-REAL[i2]];
};
real => PushReal[self.ostack, num1.int-num2.real];
ENDCASE => ERROR Error[typecheck];
real => WITH num2: num2 SELECT FROM
integer => PushReal[self.ostack, num1.real-num2.int];
real => PushReal[self.ostack, num1.real-num2.real];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Pmul: PROC [self: Root] ~ {
num2: Any ~ Pop[self.ostack];
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => WITH num2: num2 SELECT FROM
integer => {
i1: INT ~ num1.int;
i2: INT ~ num2.int;
i3: INT ~ i1*i2;
r3: REAL ~ REAL[i1]*REAL[i2];
********** fix this **********
IF i3=r3 THEN PushInt[self.ostack, i3] ELSE PushReal[self.ostack, r3];
};
real => PushReal[self.ostack, num1.int*num2.real];
ENDCASE => ERROR Error[typecheck];
real => WITH num2: num2 SELECT FROM
integer => PushReal[self.ostack, num1.real*num2.int];
real => PushReal[self.ostack, num1.real*num2.real];
ENDCASE => ERROR Error[typecheck];
ENDCASE => ERROR Error[typecheck];
};
Pdiv: PROC [self: Root] ~ {
num2: REAL ~ PopReal[self.ostack];
num1: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, num1/num2];
};
Pidiv: PROC [self: Root] ~ {
int2: INT ~ PopInt[self.ostack];
int1: INT ~ PopInt[self.ostack];
PushInt[self.ostack, int1/int2];
};
Pmod: PROC [self: Root] ~ {
int2: INT ~ PopInt[self.ostack];
int1: INT ~ PopInt[self.ostack];
PushInt[self.ostack, int1 MOD int2];
};
Pabs: PROC [self: Root] ~ {
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => {
int: INT ~ num1.int;
IF int=INT.FIRST THEN PushReal[self.ostack, ABS[REAL[int]]]
ELSE PushInt[self.ostack, ABS[int]];
};
real => PushReal[self.ostack, ABS[num1.real]];
ENDCASE => ERROR Error[typecheck];
};
Pneg: PROC [self: Root] ~ {
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => {
int: INT ~ num1.int;
IF int=INT.FIRST THEN PushReal[self.ostack, -REAL[int]]
ELSE PushInt[self.ostack, -int];
};
real => PushReal[self.ostack, -num1.real];
ENDCASE => ERROR Error[typecheck];
};
Pceiling: PROC [self: Root] ~ {
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => PushInt[self.ostack, num1.int];
real => PushReal[self.ostack, Ceiling[num1.real]];
ENDCASE => ERROR Error[typecheck];
};
Pfloor: PROC [self: Root] ~ {
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => PushInt[self.ostack, num1.int];
real => PushReal[self.ostack, Floor[num1.real]];
ENDCASE => ERROR Error[typecheck];
};
Pround: PROC [self: Root] ~ {
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => PushInt[self.ostack, num1.int];
real => PushReal[self.ostack, Round[num1.real]];
ENDCASE => ERROR Error[typecheck];
};
Ptruncate: PROC [self: Root] ~ {
num1: Any ~ Pop[self.ostack];
WITH num1: num1 SELECT FROM
integer => PushInt[self.ostack, num1.int];
real => PushReal[self.ostack, Truncate[num1.real]];
ENDCASE => ERROR Error[typecheck];
};
Psqrt: PROC [self: Root] ~ {
num: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, RealFns.SqRt[num]];
};
Patan: PROC [self: Root] ~ {
den: REAL ~ PopReal[self.ostack];
num: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, RealFns.ArcTanDeg[num, den]];
};
Pcos: PROC [self: Root] ~ {
angle: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, RealFns.CosDeg[angle]];
};
Psin: PROC [self: Root] ~ {
angle: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, RealFns.SinDeg[angle]];
};
Pexp: PROC [self: Root] ~ {
exponent: REAL ~ PopReal[self.ostack];
base: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, RealFns.Power[base, exponent]];
};
Pln: PROC [self: Root] ~ {
num: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, RealFns.Ln[num]];
};
Plog: PROC [self: Root] ~ {
num: REAL ~ PopReal[self.ostack];
PushReal[self.ostack, RealFns.Log[10, num]];
};
Prand: PROC [self: Root] ~ {
int: INT ~ Random.NextInt[self.randomStream];
PushInt[self.ostack, int];
};
Psrand: PROC [self: Root] ~ {
int: INT ~ PopInt[self.ostack];
self.randomStream ← Random.Create[seed: int];
};
Prrand: PROC [self: Root] ~ {
ERROR Error[unimplemented];
};
Array operators
AStore: PROC [stack: Stack, array: Array] ~ {
to: ArrayPointer ~ ArrayAccess[array, unlimited];
IF stack.count<array.length THEN ERROR Error[stack.underflow];
stack.count ← stack.count-array.length;
ArrayCopy[to: to, toStart: array.start,
from: stack.elements, fromStart: stack.count, length: array.length];
};
ALoad: PROC [stack: Stack, array: Array] ~ {
from: ArrayPointer ~ ArrayAccess[array, readOnly];
IF (stack.size-stack.count)<array.length THEN ERROR Error[stack.overflow];
ArrayCopy[to: stack.elements, toStart: stack.count,
from: from, fromStart: array.start, length: array.length];
stack.count ← stack.count+array.length;
};
Parray: PROC [self: Root] ~ {
int: INT ~ PopInt[self.ostack];
IF int<0 THEN ERROR Error[rangecheck];
IF int IN ArrayIndex THEN Push[self.ostack, NewArray[self, int]]
ELSE ERROR Error[limitcheck];
};
Pstartarray: PROC [self: Root] ~ { -- [
PushMark[self.ostack];
};
Pendarray: PROC [self: Root] ~ { -- ]
array: Array ~ NewArray[self, CountToMark[self.ostack]];
AStore[self.ostack, array];
PopMark[self.ostack];
Push[self.ostack, array];
};
Paload: PROC [self: Root] ~ {
array: Array ~ PopArray[self.ostack];
ALoad[self.ostack, array];
Push[self.ostack, array];
};
Pastore: PROC [self: Root] ~ {
array: Array ~ PopArray[self.ostack];
AStore[self.ostack, array];
Push[self.ostack, array];
};
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: StringPointer ~ 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
Pstring: PROC [self: Root] ~ {
int: INT ~ PopInt[self.ostack];
IF int<0 THEN ERROR Error[rangecheck];
IF int IN StringIndex THEN Push[self.ostack, NewString[self, int]]
ELSE ERROR Error[limitcheck];
};
Panchorsearch: PROC [self: Root] ~ {
seek: String ~ PopString[self.ostack];
string: String ~ PopString[self.ostack];
pstring: StringPointer ~ StringAccess[string, readOnly];
pseek: StringPointer ~ StringAccess[seek, readOnly];
found: BOOL ← FALSE;
IF seek.length<=string.length THEN {
FOR i: StringIndex IN[0..seek.length) DO
IF pstring[string.start+i]#pseek[seek.start+i] THEN EXIT;
REPEAT FINISHED => found ← TRUE;
ENDLOOP;
};
IF found THEN {
match, post: String ← string;
match.length ← seek.length;
post.start ← match.start+match.length;
post.length ← string.length-match.length;
Push[self, post];
Push[self, match];
PushBool[self, TRUE];
}
ELSE {
Push[self, string];
PushBool[self, FALSE];
};
};
Psearch: PROC [self: Root] ~ {
seek: String ~ PopString[self.ostack];
string: String ~ PopString[self.ostack];
pstring: StringPointer ~ StringAccess[string, readOnly];
pseek: StringPointer ~ StringAccess[seek, readOnly];
found: BOOL ← FALSE;
skip: StringIndex ← 0;
FOR skip ← 0, skip+1 UNTIL found OR (string.length-skip)<seek.length DO
FOR i: StringIndex IN[0..seek.length) DO
IF pstring[string.start+skip+i]#pseek[seek.start+i] THEN EXIT;
REPEAT FINISHED => found ← TRUE;
ENDLOOP;
ENDLOOP;
IF found THEN {
pre, match, post: String ← string;
pre.length ← skip;
match.start ← pre.start+pre.length;
match.length ← seek.length;
post.start ← match.start+match.length;
post.length ← string.length-pre.length-match.length;
Push[self, post];
Push[self, match];
Push[self, pre];
PushBool[self, TRUE];
}
ELSE {
Push[self, string];
PushBool[self, FALSE];
};
};
Ptoken: PROC [self: Root] ~ {
};
Polymorphic operators
Plength: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
length: INT ← 1;
WITH x: x SELECT FROM
array => { [] ← ArrayAccess[x, readOnly]; length ← x.length };
string => { [] ← StringAccess[x, readOnly]; length ← x.length };
dictionary => length ← DictAccess[x, readOnly].length;
ENDCASE;
PushInt[self.ostack, length];
};
Pget: PROC [self: Root] ~ {
index: Any ~ Pop[self.ostack];
x: Any ~ Pop[self.ostack];
WITH x: x SELECT FROM
array => {
i: INT ~ IntFromAny[index];
pointer: ArrayPointer ~ ArrayAccess[x, readOnly];
IF i IN[0..x.length) THEN Push[self.ostack, pointer[x.start+i]]
ELSE ERROR Error[rangecheck];
};
string => {
i: INT ~ IntFromAny[index];
pointer: StringPointer ~ StringAccess[x, readOnly];
IF i IN[0..x.length) THEN PushInt[self.ostack, ORD[pointer[x.start+i]]]
ELSE ERROR Error[rangecheck];
};
dictionary => Push[self.ostack, Get[x, index]];
ENDCASE => ERROR Error[typecheck];
};
Pput: PROC [self: Root] ~ {
value: Any ~ Pop[self.ostack];
index: Any ~ Pop[self.ostack];
x: Any ~ Pop[self.ostack];
WITH x: x SELECT FROM
array => {
i: INT ~ IntFromAny[index];
pointer: ArrayPointer ~ ArrayAccess[x, unlimited];
IF i IN[0..x.length) THEN pointer[x.start+i] ← value
ELSE ERROR Error[rangecheck];
};
string => {
i: INT ~ IntFromAny[index];
char: CHAR ~ CharFromAny[value];
pointer: StringPointer ~ StringAccess[x, unlimited];
IF i IN[0..x.length) THEN pointer[x.start+i] ← char
ELSE ERROR Error[rangecheck];
};
dictionary => Put[x, index, value];
ENDCASE => ERROR Error[typecheck];
};
Pgetinterval: PROC [self: Root] ~ {
count: INT ~ PopInt[self.ostack];
index: INT ~ PopInt[self.ostack];
x: Any ~ Pop[self.ostack];
WITH from: x SELECT FROM
array => {
pointer: ArrayPointer ~ ArrayAccess[from, readOnly];
IF index IN[0..from.length] AND count IN [0..from.length-index] THEN {
Push[self.ostack, [executable: from.executable, variant: array[access: from.access,
start: from.start+index, length: count, finger: from.finger]]];
}
ELSE ERROR Error[rangecheck];
};
string => {
pointer: StringPointer ~ StringAccess[from, readOnly];
IF index IN[0..from.length] AND count IN [0..from.length-index] THEN {
Push[self.ostack, [executable: from.executable, variant: string[access: from.access,
start: from.start+index, length: count, finger: from.finger]]];
}
ELSE ERROR Error[rangecheck];
};
ENDCASE => ERROR Error[typecheck];
};
Pputinterval: PROC [self: Root] ~ {
x2: Any ~ Pop[self.ostack];
index: INT ~ PopInt[self.ostack];
x1: Any ~ Pop[self.ostack];
WITH to: x1 SELECT FROM
array => WITH from: x2 SELECT FROM
array => {
toPointer: ArrayPointer ~ ArrayAccess[to, unlimited];
fromPointer: ArrayPointer ~ ArrayAccess[from, readOnly];
IF index IN[0..to.length] AND from.length IN [0..to.length-index] THEN {
ArrayCopy[to: toPointer, toStart: to.start+index,
from: fromPointer, fromStart: from.start, length: from.length];
}
ELSE ERROR Error[rangecheck];
};
ENDCASE => ERROR Error[typecheck];
};
string => WITH from: x2 SELECT FROM
string => {
toPointer: StringPointer ~ StringAccess[to, unlimited];
fromPointer: StringPointer ~ StringAccess[from, readOnly];
IF index IN[0..to.length] AND from.length IN [0..to.length-index] THEN {
StringCopy[to: toPointer, toStart: to.start+index,
from: fromPointer, fromStart: from.start, length: from.length];
}
ELSE ERROR Error[rangecheck];
};
ENDCASE => ERROR Error[typecheck];
};
ENDCASE => ERROR Error[typecheck];
};
Pcopy: PROC [self: Root] ~ {
to: Any ~ Pop[self.ostack];
WITH to: to SELECT FROM
integer => Copy[self.ostack, to.int];
array => {
from: Array ~ PopArray[self.ostack];
toPointer: ArrayPointer ~ ArrayAccess[to, unlimited];
fromPointer: ArrayPointer ~ ArrayAccess[from, readOnly];
IF to.length>=from.length THEN {
ArrayCopy[to: toPointer, toStart: to.start,
from: fromPointer, fromStart: from.start, length: from.length];
Push[self.ostack, [executable: to.executable, variant: array[access: to.access,
start: to.start, length: from.length, finger: to.finger]]];
}
ELSE ERROR Error[rangecheck];
};
string => {
from: String ~ PopString[self.ostack];
toPointer: StringPointer ~ StringAccess[to, unlimited];
fromPointer: StringPointer ~ StringAccess[from, readOnly];
IF to.length>=from.length THEN {
StringCopy[to: toPointer, toStart: to.start,
from: fromPointer, fromStart: from.start, length: from.length];
Push[self.ostack, [executable: to.executable, variant: string[access: to.access,
start: to.start, length: from.length, finger: to.finger]]];
}
ELSE ERROR Error[rangecheck];
};
dictionary => {
from: Dict ~ PopDict[self.ostack];
DictCopy[to, from];
};
ENDCASE => ERROR Error[typecheck];
};
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: ArrayPointer ~ 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: StringPointer ~ 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: ArrayPointer ~ ArrayAccess[a1, readOnly];
pointer2: ArrayPointer ~ 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: StringPointer ~ StringAccess[s1, readOnly];
pointer2: StringPointer ~ 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: StringPointer ~ StringAccess[s1, readOnly];
pointer2: StringPointer ~ 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];
};
Control operators
Pexec: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
Push[self.estack, x];
};
Pif: PROC [self: Root] ~ {
proc: Any ~ PopProc[self.ostack];
bool: BOOL ~ PopBool[self.ostack];
IF bool THEN Push[self.estack, proc];
};
Pifelse: PROC [self: Root] ~ {
proc2: Any ~ PopProc[self.ostack];
proc1: Any ~ PopProc[self.ostack];
bool: BOOL ~ PopBool[self.ostack];
Push[self.estack, IF bool THEN proc1 ELSE proc2];
};
Pfor: PROC [self: Root] ~ {
proc: Any ~ PopProc[self.ostack];
limit: Any ~ PopNum[self.ostack];
increment: Any ~ PopNum[self.ostack];
initial: Any ~ PopNum[self.ostack];
i: BOOL ~ (limit.type=integer AND increment.type=integer AND initial.type=integer);
PushMark[self.estack];
Push[self.estack, proc];
Push[self.estack, limit];
Push[self.estack, increment];
Push[self.estack, initial];
Push[self.estack, IF i THEN self.xifor ELSE self.xrfor];
};
Xifor: PROC [self: Root] ~ {
control: INT ~ PopInt[self.estack];
increment: INT ~ PopInt[self.estack];
limit: INT ~ PopInt[self.estack];
proc: Any ~ Top[self.estack];
IF (IF increment<0 THEN control<limit ELSE control>limit) THEN {
[--proc--] ← Pop[self.estack];
PopMark[self.estack];
}
ELSE {
PushInt[self.estack, limit];
PushInt[self.estack, increment];
PushInt[self.estack, control+increment];
Push[self.estack, self.xifor];
Push[self.estack, proc];
PushInt[self.ostack, control];
};
};
Xrfor: PROC [self: Root] ~ {
control: REAL ~ PopReal[self.estack];
increment: REAL ~ PopReal[self.estack];
limit: REAL ~ PopReal[self.estack];
proc: Any ~ Top[self.estack];
IF (IF increment<0 THEN control<limit ELSE control>limit) THEN {
[--proc--] ← Pop[self.estack];
PopMark[self.estack];
}
ELSE {
PushReal[self.estack, limit];
PushReal[self.estack, increment];
PushReal[self.estack, control+increment];
Push[self.estack, self.xifor];
Push[self.estack, proc];
PushReal[self.ostack, control];
};
};
Prepeat: PROC [self: Root] ~ {
proc: Any ~ PopProc[self.estack];
int: INT ~ PopInt[self.estack];
IF int<0 THEN ERROR Error[rangecheck];
PushMark[self.estack];
Push[self.estack, proc];
PushInt[self.estack, int];
Push[self.estack, self.xrepeat];
};
Xrepeat: PROC [self: Root] ~ {
n: INT ~ PopInt[self.estack];
proc: Any ~ Top[self.estack];
IF n=0 THEN {
[--proc--] ← Pop[self.estack];
PopMark[self.estack];
}
ELSE {
PushInt[self.estack, n-1];
Push[self.estack, self.xrepeat];
Push[self.estack, proc];
};
};
Ploop: PROC [self: Root] ~ {
proc: Any ~ PopProc[self.ostack];
PushMark[self.estack];
Push[self.estack, proc];
Push[self.estack, self.xloop];
};
Xloop: PROC [self: Root] ~ {
proc: Any ~ Top[self.estack];
Push[self.estack, self.xloop];
Push[self.estack, proc];
};
Pexit: PROC [self: Root] ~ {
pointer: ArrayPointer ~ self.estack.elements;
FOR i: ArrayIndex DECREASING IN [0..self.estack.count) DO
x: Any ~ pointer[i];
WITH x: x SELECT FROM
mark => {
IF x.stop THEN ERROR Error[invalidexit]
ELSE self.estack.count ← i;
RETURN;
};
ENDCASE;
ENDLOOP;
};
Pstop: PROC [self: Root] ~ {
WHILE self.estack.count>0 DO
x: Any ~ Pop[self.estack];
WITH x: x SELECT FROM
mark => IF x.stop THEN { PushBool[self.ostack, TRUE]; RETURN };
ENDCASE;
ENDLOOP;
Punt[self];
};
Pstopped: PROC [self: Root] ~ {
proc: Any ~ PopProc[self.ostack];
Push[self.estack, [executable: TRUE, variant: mark[TRUE]]];
PushBool[self.estack, FALSE];
Push[self.estack, proc];
};
Pcountexecstack: PROC [self: Root] ~ {
PushInt[self.ostack, self.estack.count];
};
Pexecstack: PROC [self: Root] ~ {
array: Array ← PopArray[self.ostack];
count: ArrayIndex ~ self.estack.count;
IF array.length<count THEN ERROR Error[rangecheck];
array.length ← count;
AStore[self.estack, array];
self.estack.count ← count;
Push[self.ostack, array];
};
Pquit: PROC [self: Root] ~ {
};
Pstart: PROC [self: Root] ~ {
};
Type, attribute, and conversion operators
Ptype: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
PushName[self.ostack, NameFromType[x.type]];
};
Pcvlit: PROC [self: Root] ~ {
x: Any ← Pop[self.ostack];
x.executable ← FALSE;
Push[self.ostack, x];
};
Pcvx: PROC [self: Root] ~ {
x: Any ← Pop[self.ostack];
x.executable ← TRUE;
Push[self.ostack, x];
};
Pxcheck: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
PushBool[self.ostack, x.executable];
};
Pexecuteonly: PROC [self: Root] ~ {
x: Any ← Pop[self.ostack];
WITH x: x SELECT FROM
array => { [] ← ArrayAccess[x, unlimited]; x.access ← executeOnly };
string => { [] ← StringAccess[x, unlimited]; x.access ← executeOnly };
file => { [] ← FileAccess[x, unlimited]; x.access ← executeOnly };
ENDCASE => ERROR Error[typecheck];
Push[self.ostack, x];
};
Pnoaccess: PROC [self: Root] ~ {
x: Any ← Pop[self.ostack];
WITH x: x SELECT FROM
array => { [] ← ArrayAccess[x, unlimited]; x.access ← none };
string => { [] ← StringAccess[x, unlimited]; x.access ← none };
dictionary => { DictAccess[x, unlimited].access ← none };
file => { [] ← FileAccess[x, unlimited]; x.access ← none };
ENDCASE => ERROR Error[typecheck];
Push[self.ostack, x];
};
Preadonly: PROC [self: Root] ~ {
x: Any ← Pop[self.ostack];
WITH x: x SELECT FROM
array => { [] ← ArrayAccess[x, unlimited]; x.access ← readOnly };
string => { [] ← StringAccess[x, unlimited]; x.access ← readOnly };
dictionary => { DictAccess[x, unlimited].access ← readOnly };
file => { [] ← FileAccess[x, unlimited]; x.access ← readOnly };
ENDCASE => ERROR Error[typecheck];
Push[self.ostack, x];
};
Prcheck: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
bool: BOOL ← FALSE;
WITH x: x SELECT FROM
array => bool ← RCheck[x.access];
string => bool ← RCheck[x.access];
dictionary => bool ← RCheck[x.finger^.access];
file => bool ← RCheck[x.access];
ENDCASE => ERROR Error[typecheck];
PushBool[self.ostack, bool];
};
Pwcheck: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
bool: BOOL ← FALSE;
WITH x: x SELECT FROM
array => bool ← WCheck[x.access];
string => bool ← WCheck[x.access];
dictionary => bool ← WCheck[x.finger^.access];
file => bool ← WCheck[x.access];
ENDCASE => ERROR Error[typecheck];
PushBool[self.ostack, bool];
};
CvI: PROC [x: Any] RETURNS [INT] ~ {
WITH x: x SELECT FROM
integer => RETURN [x.int];
real => RETURN [Fix[x.real ! Real.RealException => GOTO RangeCheck]];
string => RETURN [CvI[NumFromString[x]]];
ENDCASE => ERROR Error[typecheck];
EXITS RangeCheck => ERROR Error[rangecheck];
};
CvR: PROC [x: Any] RETURNS [REAL] ~ {
WITH x: x SELECT FROM
int => RETURN [REAL[x.int]];
real => RETURN [x.real];
string => RETURN [CvR[NumFromString[x]]];
ENDCASE => ERROR Error[typecheck];
};
Pcvi: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
PushInt[self.ostack, CvI[x]];
};
Pcvn: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
WITH x: x SELECT FROM
string => Push[self.ostack, CvN[x]];
ENDCASE => ERROR Error[typecheck];
};
Pcvr: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
PushReal[self.ostack, CvR[x]];
};
Pcvrs: PROC [self: Root] ~ {
string: String ~ PopString[self.ostack];
radix: INT ~ PopInt[self.ostack];
num: Any ~ PopNum[self.ostack];
int: INT ~ CvI[num];
ERROR Error[unimplemented];
};
Pcvs: PROC [self: Root] ~ {
string: String ~ PopString[self.ostack];
x: Any ~ Pop[self.ostack];
s: StringPointer ~ StringAccess[string, unlimited];
i: StringIndex ← string.start;
result: String;
WITH x: x SELECT FROM
integer => result ← CvsInt[x.int, string];
real => result ← CvsReal[x.real, string];
boolean => xx
string => xx
name => xx
operator => xx
ENDCASE => result ← StringCopy[nostringval, string];
Push[self.ostack, result];
};
File operators
Pfile: PROC [self: Root] ~ {
string2: String ~ PopString[self.ostack];
string1: String ~ PopString[self.ostack];
};
Pclosefile: PROC [self: Root] ~ {
file: File ~ PopFile[self.ostack];
stream: STREAM ~ StreamFromFile[self, file];
IO.Close[stream];
};
Pread: PROC [self: Root] ~ {
file: File ~ PopFile[self.ostack];
stream: STREAM ~ StreamFromFile[self, file];
};
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] ~ {
};
Graphics state operators
Pgsave: PROC [self: Root] ~ {
};
Pgrestore: PROC [self: Root] ~ {
};
Pgrestoreall: PROC [self: Root] ~ {
};
Pinitgraphics: PROC [self: Root] ~ {
};
Psetlinewidth: PROC [self: Root] ~ {
};
Pcurrentlinewidth: PROC [self: Root] ~ {
};
Psetlinecap: PROC [self: Root] ~ {
};
Pcurrentlinecap: PROC [self: Root] ~ {
};
Psetlinejoin: PROC [self: Root] ~ {
};
Pcurrentlinejoin: PROC [self: Root] ~ {
};
Psetmiterlimit: PROC [self: Root] ~ {
};
Pcurrentmiterlimit: PROC [self: Root] ~ {
};
Psetdash: PROC [self: Root] ~ {
};
Pcurrentdash: PROC [self: Root] ~ {
};
Psetflat: PROC [self: Root] ~ {
};
Pcurrentflat: PROC [self: Root] ~ {
};
Psetgray: PROC [self: Root] ~ {
};
Pcurrentgray: PROC [self: Root] ~ {
};
Psethsbcolor: PROC [self: Root] ~ {
};
Pcurrenthsbcolor: PROC [self: Root] ~ {
};
Psetrgbcolor: PROC [self: Root] ~ {
};
Pcurrentrgbcolor: PROC [self: Root] ~ {
};
Psetscreen: PROC [self: Root] ~ {
};
Pcurrentscreen: PROC [self: Root] ~ {
};
Psettransfer: PROC [self: Root] ~ {
};
Pcurrenttransfer: PROC [self: Root] ~ {
};
Coordinate system and matrix operators
Pmatrix: PROC [self: Root] ~ {
};
Pinitmatrix: PROC [self: Root] ~ {
};
Pidentmatrix: PROC [self: Root] ~ {
};
Pdefaultmatrix: PROC [self: Root] ~ {
};
Pcurrentmatrix: PROC [self: Root] ~ {
};
Psetmatrix: PROC [self: Root] ~ {
};
Ptranslate: PROC [self: Root] ~ {
};
Pscale: PROC [self: Root] ~ {
};
Protate: PROC [self: Root] ~ {
};
Pconcat: PROC [self: Root] ~ {
};
Pconcatmatrix: PROC [self: Root] ~ {
};
Ptransform: PROC [self: Root] ~ {
};
Pdtransform: PROC [self: Root] ~ {
};
Pitransform: PROC [self: Root] ~ {
};
Pidtransform: PROC [self: Root] ~ {
};
Pinvertmatrix: PROC [self: Root] ~ {
};
Path construction operators
Pnewpath: PROC [self: Root] ~ {
};
Pcurrentpoint: PROC [self: Root] ~ {
};
Pmoveto: PROC [self: Root] ~ {
};
Prmoveto: PROC [self: Root] ~ {
};
Plineto: PROC [self: Root] ~ {
};
Prlineto: PROC [self: Root] ~ {
};
Parc: PROC [self: Root] ~ {
};
Parcn: PROC [self: Root] ~ {
};
Parcto: PROC [self: Root] ~ {
};
Pcurveto: PROC [self: Root] ~ {
};
Prcurveto: PROC [self: Root] ~ {
};
Pclosepath: PROC [self: Root] ~ {
};
Pflattenpath: PROC [self: Root] ~ {
};
Preversepath: PROC [self: Root] ~ {
};
Pstrokepath: PROC [self: Root] ~ {
};
Pcharpath: PROC [self: Root] ~ {
};
Pclippath: PROC [self: Root] ~ {
};
Ppathbbox: PROC [self: Root] ~ {
};
Ppathforall: PROC [self: Root] ~ {
};
Pinitclip: PROC [self: Root] ~ {
};
Pclip: PROC [self: Root] ~ {
};
Peoclip: 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.