PSPrimitives1Impl.mesa
Copyright Ó 1987 by Xerox Corporation. All rights reserved.
Doug Wyatt, May 15, 1987 1:16:30 pm PDT
PostScript primitives: basic language operations.
DIRECTORY
PS,
Basics,
RealFns;
PSPrimitives1Impl: CEDAR PROGRAM
IMPORTS PS, Basics, RealFns
~ BEGIN OPEN PS;
Operand stack manipulation operators
pop: PROC [self: Root] ~ {
[] ← PopAny[self];
};
exch: PROC [self: Root] ~ {
Roll[self, 2, 1];
};
dup: PROC [self: Root] ~ {
Copy[self, 2];
};
copy is polymorphic
index: PROC [self: Root] ~ {
n: INT ~ PopInt[self];
PushAny[self, Index[self, n]];
};
roll: PROC [self: Root] ~ {
j: INT ~ PopInt[self];
n: INT ~ PopInt[self];
Roll[self, n, j];
};
clear: PROC [self: Root] ~ {
Clear[self];
};
count: PROC [self: Root] ~ {
PushInt[self, Count[self]];
};
mark: PROC [self: Root] ~ {
PushMark[self];
};
cleartomark: PROC [self: Root] ~ {
ClearToMark[self];
};
counttomark: PROC [self: Root] ~ {
PushInt[self, CountToMark[self]];
};
Arithmetic and math operators
add: PROC [self: Root] ~ {
num2: Num ~ PopNum[self];
num1: Num ~ PopNum[self];
WITH num1: num1 SELECT FROM
int => WITH num2: num2 SELECT FROM
int => PushNum[self, IntAdd[num1.int, num2.int]];
real => PushReal[self, REAL[num1.int]+num2.real];
ENDCASE => ERROR Bug;
real => WITH num2: num2 SELECT FROM
int => PushReal[self, num1.real+REAL[num2.int]];
real => PushReal[self, num1.real+num2.real];
ENDCASE => ERROR Bug;
ENDCASE => ERROR Bug;
};
div: PROC [self: Root] ~ {
real2: REAL ~ PopReal[self];
real1: REAL ~ PopReal[self];
PushReal[self, real1/real2];
};
idiv: PROC [self: Root] ~ {
int2: INT ~ PopInt[self];
int1: INT ~ PopInt[self];
PushInt[self, int1/int2];
};
mod: PROC [self: Root] ~ {
int2: INT ~ PopInt[self];
int1: INT ~ PopInt[self];
PushInt[self, int1 MOD int2];
};
mul: PROC [self: Root] ~ {
num2: Num ~ PopNum[self];
num1: Num ~ PopNum[self];
WITH num1: num1 SELECT FROM
int => WITH num2: num2 SELECT FROM
int => PushNum[self, IntMul[num1.int, num2.int]];
real => PushReal[self, REAL[num1.int]*num2.real];
ENDCASE => ERROR Bug;
real => WITH num2: num2 SELECT FROM
int => PushReal[self, num1.real*REAL[num2.int]];
real => PushReal[self, num1.real*num2.real];
ENDCASE => ERROR Bug;
ENDCASE => ERROR Bug;
};
sub: PROC [self: Root] ~ {
num2: Num ~ PopNum[self];
num1: Num ~ PopNum[self];
WITH num1: num1 SELECT FROM
int => WITH num2: num2 SELECT FROM
int => PushNum[self, IntSub[num1.int, num2.int]];
real => PushReal[self, REAL[num1.int]-num2.real];
ENDCASE => ERROR Bug;
real => WITH num2: num2 SELECT FROM
int => PushReal[self, num1.real-REAL[num2.int]];
real => PushReal[self, num1.real-num2.real];
ENDCASE => ERROR Bug;
ENDCASE => ERROR Bug;
};
abs: PROC [self: Root] ~ {
num: Num ~ PopNum[self];
WITH num: num SELECT FROM
int => IF num.int#INT.FIRST
THEN PushInt[self, ABS[num.int]]
ELSE PushReal[self, ABS[REAL[num.int]]];
real => PushReal[self, ABS[num.real]];
ENDCASE => ERROR Bug;
};
neg: PROC [self: Root] ~ {
num: Num ~ PopNum[self];
WITH num: num SELECT FROM
int => IF num.int#INT.FIRST
THEN PushInt[self, -num.int]
ELSE PushReal[self, -REAL[num.int]];
real => PushReal[self, -num.real];
ENDCASE => ERROR Bug;
};
ceiling: PROC [self: Root] ~ {
num: Num ~ PopNum[self];
WITH num: num SELECT FROM
int => PushInt[self, num.int];
real => PushReal[self, Ceiling[num.real]];
ENDCASE => ERROR Bug;
};
floor: PROC [self: Root] ~ {
num: Num ~ PopNum[self];
WITH num: num SELECT FROM
int => PushInt[self, num.int];
real => PushReal[self, Floor[num.real]];
ENDCASE => ERROR Bug;
};
round: PROC [self: Root] ~ {
num: Num ~ PopNum[self];
WITH num: num SELECT FROM
int => PushInt[self, num.int];
real => PushReal[self, Round[num.real]];
ENDCASE => ERROR Bug;
};
truncate: PROC [self: Root] ~ {
num: Num ~ PopNum[self];
WITH num: num SELECT FROM
int => PushInt[self, num.int];
real => PushReal[self, Truncate[num.real]];
ENDCASE => ERROR Bug;
};
sqrt: PROC [self: Root] ~ {
num: REAL ~ PopReal[self];
PushReal[self, RealFns.SqRt[num]];
};
atan: PROC [self: Root] ~ {
den: REAL ~ PopReal[self];
num: REAL ~ PopReal[self];
PushReal[self, RealFns.ArcTanDeg[num, den]];
};
cos: PROC [self: Root] ~ {
angle: REAL ~ PopReal[self];
PushReal[self, RealFns.CosDeg[angle]];
};
sin: PROC [self: Root] ~ {
angle: REAL ~ PopReal[self];
PushReal[self, RealFns.SinDeg[angle]];
};
exp: PROC [self: Root] ~ {
exponent: REAL ~ PopReal[self];
base: REAL ~ PopReal[self];
PushReal[self, RealFns.Power[base, exponent]];
};
ln: PROC [self: Root] ~ {
num: REAL ~ PopReal[self];
PushReal[self, RealFns.Ln[num]];
};
log: PROC [self: Root] ~ {
num: REAL ~ PopReal[self];
PushReal[self, RealFns.Log[10, num]];
};
rand: PROC [self: Root] ~ {
int: INT ~ Rand[self];
PushInt[self, int];
};
srand: PROC [self: Root] ~ {
int: INT ~ PopInt[self];
SRand[self, int];
};
rrand: PROC [self: Root] ~ {
int: INT ~ RRand[self];
PushInt[self, int];
};
Array operators
array: PROC [self: Root] ~ {
size: INT ~ PopInt[self];
PushArray[self, ArrayCreate[size]];
};
startarray: PROC [self: Root] ~ { -- [
PushMark[self];
};
endarray: PROC [self: Root] ~ { -- ]
size: INT ~ CountToMark[self];
array: Array ~ ArrayCreate[size];
FOR index: INT DECREASING IN [0..ArrayLength[array]) DO
ArrayPut[array, index, PopAny[self]];
ENDLOOP;
PopMark[self];
PushArray[self, array];
};
length is polymorphic
get is polymorphic
put is polymorphic
getinterval is polymorphic
putinterval is polymorphic
aload: PROC [self: Root] ~ {
array: Array ~ PopArray[self];
IF ArrayAccess[array]<readOnly THEN ERROR Error[invalidaccess];
FOR index: INT IN [0..ArrayLength[array]) DO
PushAny[self, ArrayGet[array, index]];
ENDLOOP;
PushArray[self, array];
};
astore: PROC [self: Root] ~ {
array: Array ~ PopArray[self];
IF ArrayAccess[array]<unlimited THEN ERROR Error[invalidaccess];
IF Count[self]<ArrayLength[array] THEN ERROR Error[stackunderflow];
FOR index: INT DECREASING IN [0..ArrayLength[array]) DO
ArrayPut[array, index, PopAny[self]];
ENDLOOP;
PushArray[self, array];
};
copy is polymorphic
forall is polymorphic
Dictionary operators
dict: PROC [self: Root] ~ {
size: INT ~ PopInt[self];
PushDict[self, DictCreate[size]];
};
length is polymorphic
maxlength: PROC [self: Root] ~ {
dict: Dict ~ PopDict[self];
PushInt[self, DictMaxLength[dict]];
};
begin: PROC [self: Root] ~ {
dict: Dict ~ PopDict[self];
Begin[self, dict];
};
end: PROC [self: Root] ~ {
End[self];
};
def: PROC [self: Root] ~ {
value: Any ~ PopAny[self];
key: Any ~ PopAny[self];
Def[self, key, value];
};
load: PROC [self: Root] ~ {
key: Any ~ PopAny[self];
PushAny[self, Load[self, key]];
};
store: PROC [self: Root] ~ {
value: Any ~ PopAny[self];
key: Any ~ PopAny[self];
Store[self, key, value];
};
get is polymorphic
put is polymorphic
known: PROC [self: Root] ~ {
key: Any ~ PopAny[self];
dict: Dict ~ PopDict[self];
PushBool[self, Known[dict, key]];
};
where: PROC [self: Root] ~ {
key: Any ~ PopAny[self];
found: BOOL; dict: Dict;
[found, dict] ← Where[self, key];
IF found THEN PushDict[self, dict];
PushBool[self, found];
};
copy is polymorphic
forall is polymorphic
currentdict: PROC [self: Root] ~ {
PushDict[self, CurrentDict[self]];
};
countdictstack: PROC [self: Root] ~ {
PushInt[self, CountDictStack[self]];
};
dictstack: PROC [self: Root] ~ {
array: Array ~ PopArray[self];
PushArray[self, DictStack[self, array]];
};
String operators
string: PROC [self: Root] ~ {
size: INT ~ PopInt[self];
PushString[self, StringCreate[size]];
};
length is polymorphic
get is polymorphic
put is polymorphic
getinterval is polymorphic
putinterval is polymorphic
copy is polymorphic
forall is polymorphic
anchorsearch: PROC [self: Root] ~ {
seek: String ~ PopString[self];
string: String ~ PopString[self];
found: BOOL; index: INT;
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
IF StringAccess[seek]<readOnly THEN ERROR Error[invalidaccess];
[found: found, index: index] ← Search[string: string, seek: seek, anchor: TRUE];
IF index#0 THEN ERROR Bug;
IF found THEN {
matchLength: INT ~ StringLength[seek];
match: String ~ StringGetInterval[string, 0, matchLength];
post: String ~ StringGetInterval[string, matchLength, StringLength[string]-matchLength];
PushString[self, post];
PushString[self, match];
PushBool[self, TRUE];
}
ELSE {
PushString[self, string];
PushBool[self, FALSE];
};
};
search: PROC [self: Root] ~ {
seek: String ~ PopString[self];
string: String ~ PopString[self];
found: BOOL; matchIndex: INT;
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
IF StringAccess[seek]<readOnly THEN ERROR Error[invalidaccess];
[found: found, index: matchIndex] ← Search[string: string, seek: seek, anchor: FALSE];
IF found THEN {
matchLength: INT ~ StringLength[seek];
postIndex: INT ~ matchIndex+matchLength;
pre: String ~ StringGetInterval[string, 0, matchIndex];
match: String ~ StringGetInterval[string, matchIndex, matchLength];
post: String ~ StringGetInterval[string, postIndex, StringLength[string]-postIndex];
PushString[self, post];
PushString[self, match];
PushString[self, pre];
PushBool[self, TRUE];
}
ELSE {
PushString[self, string];
PushBool[self, FALSE];
};
};
token is polymorphic
Relational, boolean, and bitwise operators
eq: PROC [self: Root] ~ {
x2: Any ~ PopAny[self];
x1: Any ~ PopAny[self];
PushBool[self, Eq[x1, x2]];
};
ne: PROC [self: Root] ~ {
x2: Any ~ PopAny[self];
x1: Any ~ PopAny[self];
PushBool[self, NOT Eq[x1, x2]];
};
ge: PROC [self: Root] ~ {
x2: Any ~ PopAny[self];
x1: Any ~ PopAny[self];
PushBool[self, Compare[x1, x2]>=equal];
};
gt: PROC [self: Root] ~ {
x2: Any ~ PopAny[self];
x1: Any ~ PopAny[self];
PushBool[self, Compare[x1, x2]>equal];
};
le: PROC [self: Root] ~ {
x2: Any ~ PopAny[self];
x1: Any ~ PopAny[self];
PushBool[self, Compare[x1, x2]<=equal];
};
lt: PROC [self: Root] ~ {
x2: Any ~ PopAny[self];
x1: Any ~ PopAny[self];
PushBool[self, Compare[x1, x2]<equal];
};
and: PROC [self: Root] ~ {
arg2: Any ~ PopAny[self];
SELECT Type[arg2] FROM
boolean => {
bool2: BOOL ~ BoolFromAny[arg2];
bool1: BOOL ~ PopBool[self];
PushBool[self, bool1 AND bool2];
};
integer => {
int2: INT ~ IntFromAny[arg2];
int1: INT ~ PopInt[self];
PushInt[self, Basics.DoubleAnd[[li[int1]], [li[int2]]].li];
};
ENDCASE => ERROR Error[typecheck];
};
not: PROC [self: Root] ~ {
arg1: Any ~ PopAny[self];
SELECT Type[arg1] FROM
boolean => {
bool1: BOOL ~ BoolFromAny[arg1];
PushBool[self, NOT bool1];
};
integer => {
int1: INT ~ IntFromAny[arg1];
PushInt[self, Basics.DoubleNot[[li[int1]]].li];
};
ENDCASE => ERROR Error[typecheck];
};
or: PROC [self: Root] ~ {
arg2: Any ~ PopAny[self];
SELECT Type[arg2] FROM
boolean => {
bool2: BOOL ~ BoolFromAny[arg2];
bool1: BOOL ~ PopBool[self];
PushBool[self, bool1 OR bool2];
};
integer => {
int2: INT ~ IntFromAny[arg2];
int1: INT ~ PopInt[self];
PushInt[self, Basics.DoubleOr[[li[int1]], [li[int2]]].li];
};
ENDCASE => ERROR Error[typecheck];
};
xor: PROC [self: Root] ~ {
arg2: Any ~ PopAny[self];
SELECT Type[arg2] FROM
boolean => {
bool2: BOOL ~ BoolFromAny[arg2];
bool1: BOOL ~ PopBool[self];
PushBool[self, bool1 # bool2];
};
integer => {
int2: INT ~ IntFromAny[arg2];
int1: INT ~ PopInt[self];
PushInt[self, Basics.DoubleXor[[li[int1]], [li[int2]]].li];
};
ENDCASE => ERROR Error[typecheck];
};
bitshift: PROC [self: Root] ~ {
shift: INT ~ PopInt[self];
int1: INT ~ PopInt[self];
IF shift NOT IN INTEGER THEN PushInt[self, 0]
ELSE PushInt[self, Basics.DoubleShift[[li[int1]], shift].li];
};
Control operators
exec: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
Execute[self, x];
};
if: PROC [self: Root] ~ {
proc: Any ~ PopProc[self];
bool: BOOL ~ PopBool[self];
IF bool THEN Execute[self, proc];
};
ifelse: PROC [self: Root] ~ {
proc2: Any ~ PopProc[self];
proc1: Any ~ PopProc[self];
bool: BOOL ~ PopBool[self];
Execute[self, IF bool THEN proc1 ELSE proc2];
};
for: PROC [self: Root] ~ {
proc: Any ~ PopProc[self];
num3: Num ~ PopNum[self];
num2: Num ~ PopNum[self];
num1: Num ~ PopNum[self];
IFor: PROC [self: Root, init, incr, limit: INT, proc: Any] ~ {
FOR control: INT ← init, control+incr
UNTIL (IF incr>0 THEN control>limit ELSE control<limit) DO
PushInt[self, control];
Execute[self, proc ! Exit => EXIT];
ENDLOOP;
};
RFor: PROC [self: Root, init, incr, limit: REAL, proc: Any] ~ {
FOR control: REAL ← init, control+incr
UNTIL (IF incr>0 THEN control>limit ELSE control<limit) DO
PushReal[self, control];
Execute[self, proc ! Exit => EXIT];
ENDLOOP;
};
WITH num1: num1 SELECT FROM
int => WITH num2: num2 SELECT FROM
int => WITH num3: num3 SELECT FROM
int => IFor[self, num1.int, num2.int, num3.int, proc];
real => RFor[self, num1.int, num2.int, num3.real, proc];
ENDCASE => ERROR Bug;
real => WITH num3: num3 SELECT FROM
int => RFor[self, num1.int, num2.real, num3.int, proc];
real => RFor[self, num1.int, num2.real, num3.real, proc];
ENDCASE => ERROR Bug;
ENDCASE => ERROR Bug;
real => WITH num2: num2 SELECT FROM
int => WITH num3: num3 SELECT FROM
int => RFor[self, num1.real, num2.int, num3.int, proc];
real => RFor[self, num1.real, num2.int, num3.real, proc];
ENDCASE => ERROR Bug;
real => WITH num3: num3 SELECT FROM
int => RFor[self, num1.real, num2.real, num3.int, proc];
real => RFor[self, num1.real, num2.real, num3.real, proc];
ENDCASE => ERROR Bug;
ENDCASE => ERROR Bug;
ENDCASE => ERROR Bug;
};
repeat: PROC [self: Root] ~ {
proc: Any ~ PopProc[self];
int: INT ~ PopInt[self];
IF int<0 THEN ERROR Error[rangecheck];
THROUGH [0..int) DO
Execute[self, proc ! Exit => EXIT];
ENDLOOP;
};
loop: PROC [self: Root] ~ {
proc: Any ~ PopProc[self];
DO
Execute[self, proc ! Exit => EXIT];
ENDLOOP;
};
exit: PROC [self: Root] ~ {
SIGNAL Exit;
ERROR Error[invalidexit];
};
stop: PROC [self: Root] ~ {
ERROR Stop;
};
stopped: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
stopped: BOOL ← FALSE;
Execute[self, x !
Stop => { stopped ← TRUE; CONTINUE };
Exit => { RESUME };
];
PushBool[self, stopped];
};
quit: PROC [self: Root] ~ {
ERROR Quit;
};
Type, attribute, and conversion operators
type: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushName[self, NameFromType[Type[x]]];
};
cvlit: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushAny[self, CvLit[x]];
};
cvx: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushAny[self, CvX[x]];
};
xcheck: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushBool[self, XCheck[x]];
};
executeonly: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushAny[self, SetAccess[x, executeOnly]];
};
noaccess: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushAny[self, SetAccess[x, none]];
};
readonly: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushAny[self, SetAccess[x, readOnly]];
};
rcheck: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushBool[self, GetAccess[x]>=readOnly];
};
wcheck: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
PushBool[self, GetAccess[x]=unlimited];
};
cvi: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
SELECT Type[x] FROM
integer => {
int: INT ~ IntFromAny[x];
PushInt[self, int];
};
real => {
real: REAL ~ RealFromAny[x];
PushInt[self, IntFromReal[real]];
};
string => {
string: String ~ StringFromAny[x];
PushInt[self, IntFromString[string]];
};
ENDCASE => ERROR Error[typecheck];
};
cvn: PROC [self: Root] ~ {
string: String ~ PopString[self];
PushName[self, NameFromString[string]];
};
cvr: PROC [self: Root] ~ {
x: Any ~ PopAny[self];
SELECT Type[x] FROM
integer => {
int: INT ~ IntFromAny[x];
PushReal[self, RealFromInt[int]];
};
real => {
real: REAL ~ RealFromAny[x];
PushReal[self, real];
};
string => {
string: String ~ StringFromAny[x];
PushReal[self, RealFromString[string]];
};
ENDCASE => ERROR Error[typecheck];
};
cvrs: PROC [self: Root] ~ {
string: String ~ PopString[self];
radix: INT ~ PopInt[self];
x: Any ~ PopAny[self];
SELECT Type[x] FROM
integer => {
int: INT ~ IntFromAny[x];
PushString[self, StringFromInt[int, string, radix]];
};
real => {
real: REAL ~ RealFromAny[x];
PushString[self, StringFromInt[IntFromReal[real], string, radix]];
};
ENDCASE => ERROR Error[typecheck];
};
cvs: PROC [self: Root] ~ {
string: String ~ PopString[self];
x: Any ~ PopAny[self];
SELECT Type[x] FROM
integer => {
int: INT ~ IntFromAny[x];
PushString[self, StringFromInt[int, string]];
};
real => {
real: REAL ~ RealFromAny[x];
PushString[self, StringFromReal[real, string]];
};
boolean => {
bool: BOOL ~ BoolFromAny[x];
PushString[self, StringFromRope[(IF bool THEN "true" ELSE "false"), string]];
};
string => {
string1: String ~ StringFromAny[x];
PushString[self, StringCopy[string1, string]];
};
name => {
name: Name ~ NameFromAny[x];
PushString[self, StringCopy[name.ref^, string]];
};
operator => {
operator: Operator ~ OperatorFromAny[x];
PushString[self, StringFromRope[operator.ref.name, string]];
};
ENDCASE => {
PushString[self, StringFromRope["--nostringval--", string]];
};
};
File operators
FileAccessModeFromString: PROC [string: String] RETURNS [FileAccessMode] ~ {
IF StringLength[string]=1 THEN SELECT StringGet[string, 0] FROM
'r => RETURN[$read];
'w => RETURN[$create];
ENDCASE;
ERROR Error[invalidfileaccess];
};
file: PROC [self: Root] ~ {
string2: String ~ PopString[self];
string1: String ~ PopString[self];
IF StringAccess[string1]<readOnly THEN ERROR Error[invalidaccess];
IF StringAccess[string2]<readOnly THEN ERROR Error[invalidaccess];
PushFile[self, FileCreate[string1, FileAccessModeFromString[string2]]];
};
closefile: PROC [self: Root] ~ {
file: File ~ PopFile[self];
CloseFile[file];
};
read: PROC [self: Root] ~ {
file: File ~ PopFile[self];
found: BOOL; char: CHAR;
IF FileAccess[file]<readOnly THEN ERROR Error[invalidaccess];
[found, char] ← Read[file];
IF found THEN PushInt[self, IntFromChar[char]];
PushBool[self, found];
};
write: PROC [self: Root] ~ {
int: INT ~ PopInt[self];
file: File ~ PopFile[self];
IF FileAccess[file]<unlimited THEN ERROR Error[invalidaccess];
Write[file, CharFromInt[int]];
};
ReadStringProc: TYPE ~ PROC [file: File, string: String] RETURNS [substring: String, bool: BOOL];
DoReadString: PROC [self: Root, readString: ReadStringProc] ~ {
string: String ~ PopString[self];
file: File ~ PopFile[self];
substring: String; bool: BOOL;
IF FileAccess[file]<readOnly THEN ERROR Error[invalidaccess];
IF StringAccess[string]<unlimited THEN ERROR Error[invalidaccess];
[substring, bool] ← readString[file, string];
PushString[self, substring];
PushBool[self, bool];
};
WriteStringProc: TYPE ~ PROC [file: File, string: String];
DoWriteString: PROC [self: Root, writeString: WriteStringProc] ~ {
string: String ~ PopString[self];
file: File ~ PopFile[self];
IF FileAccess[file]<unlimited THEN ERROR Error[invalidaccess];
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
writeString[file, string];
};
readhexstring: PROC [self: Root] ~ {
DoReadString[self, ReadHexString];
};
writehexstring: PROC [self: Root] ~ {
DoWriteString[self, WriteHexString];
};
readstring: PROC [self: Root] ~ {
DoReadString[self, ReadString];
};
writestring: PROC [self: Root] ~ {
DoWriteString[self, WriteString];
};
readline: PROC [self: Root] ~ {
DoReadString[self, ReadLine];
};
token is polymorphic
bytesavailable: PROC [self: Root] ~ {
file: File ~ PopFile[self];
IF FileAccess[file]<readOnly THEN ERROR Error[invalidaccess];
PushInt[self, BytesAvailable[file]];
};
flush: PROC [self: Root] ~ {
FlushFile[self.stdout];
};
flushfile: PROC [self: Root] ~ {
file: File ~ PopFile[self];
FlushFile[file];
};
resetfile: PROC [self: Root] ~ {
file: File ~ PopFile[self];
ResetFile[file];
};
status: PROC [self: Root] ~ {
file: File ~ PopFile[self];
PushBool[self, Status[file]];
};
run: PROC [self: Root] ~ {
string: String ~ PopString[self];
file: File ~ FileCreate[string, $read];
ExecuteFile[self, file !
UNWIND => CloseFile[file];
Exit => RESUME;
];
CloseFile[file];
};
currentfile: PROC [self: Root] ~ {
file: File ~ SIGNAL CurrentFile[];
PushFile[self, file];
};
print: PROC [self: Root] ~ {
string: String ~ PopString[self];
WriteString[self.stdout, string];
};
echo: PROC [self: Root] ~ {
bool: BOOL ~ PopBool[self];
Echo[self, bool];
};
Polymorphic operators
copy: PROC [self: Root] ~ {
arg: Any ~ PopAny[self];
SELECT Type[arg] FROM
integer => {
n: INT ~ IntFromAny[arg];
Copy[self, n];
};
array => {
array2: Array ~ ArrayFromAny[arg];
array1: Array ~ PopArray[self];
IF ArrayAccess[array1]<readOnly THEN ERROR Error[invalidaccess];
IF ArrayAccess[array2]<unlimited THEN ERROR Error[invalidaccess];
PushArray[self, ArrayCopy[array1, array2]];
};
string => {
string2: String ~ StringFromAny[arg];
string1: String ~ PopString[self];
IF StringAccess[string1]<readOnly THEN ERROR Error[invalidaccess];
IF StringAccess[string2]<unlimited THEN ERROR Error[invalidaccess];
PushString[self, StringCopy[string1, string2]];
};
dict => {
dict2: Dict ~ DictFromAny[arg];
dict1: Dict ~ PopDict[self];
IF DictAccess[dict1]<readOnly THEN ERROR Error[invalidaccess];
IF DictAccess[dict2]<unlimited THEN ERROR Error[invalidaccess];
PushDict[self, DictCopy[dict1, dict2]];
};
ENDCASE => ERROR Error[typecheck];
};
length: PROC [self: Root] ~ {
arg: Any ~ PopAny[self];
SELECT Type[arg] FROM
array => {
array: Array ~ ArrayFromAny[arg];
IF ArrayAccess[array]<readOnly THEN ERROR Error[invalidaccess];
PushInt[self, ArrayLength[array]];
};
string => {
string: String ~ StringFromAny[arg];
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
PushInt[self, StringLength[string]];
};
dict => {
dict: Dict ~ DictFromAny[arg];
IF DictAccess[dict]<readOnly THEN ERROR Error[invalidaccess];
PushInt[self, DictLength[dict]];
};
name => {
name: Name ~ NameFromAny[arg];
PushInt[self, NameLength[name]];
};
ENDCASE => ERROR Error[typecheck];
};
get: PROC [self: Root] ~ {
arg2: Any ~ PopAny[self];
arg1: Any ~ PopAny[self];
SELECT Type[arg1] FROM
array => {
array: Array ~ ArrayFromAny[arg1];
index: INT ~ IntFromAny[arg2];
IF ArrayAccess[array]<readOnly THEN ERROR Error[invalidaccess];
PushAny[self, ArrayGet[array, index]];
};
string => {
string: String ~ StringFromAny[arg1];
index: INT ~ IntFromAny[arg2];
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
PushInt[self, IntFromChar[StringGet[string, index]]];
};
dict => {
dict: Dict ~ DictFromAny[arg1];
IF DictAccess[dict]<readOnly THEN ERROR Error[invalidaccess];
PushAny[self, DictGet[dict, arg2]];
};
ENDCASE => ERROR Error[typecheck];
};
put: PROC [self: Root] ~ {
arg3: Any ~ PopAny[self];
arg2: Any ~ PopAny[self];
arg1: Any ~ PopAny[self];
SELECT Type[arg1] FROM
array => {
array: Array ~ ArrayFromAny[arg1];
index: INT ~ IntFromAny[arg2];
IF ArrayAccess[array]<unlimited THEN ERROR Error[invalidaccess];
ArrayPut[array, index, arg3];
};
string => {
string: String ~ StringFromAny[arg1];
index: INT ~ IntFromAny[arg2];
int: INT ~ IntFromAny[arg3];
IF StringAccess[string]<unlimited THEN ERROR Error[invalidaccess];
StringPut[string, index, CharFromInt[int]];
};
dict => {
dict: Dict ~ DictFromAny[arg1];
IF DictAccess[dict]<unlimited THEN ERROR Error[invalidaccess];
DictPut[dict, arg2, arg3];
};
ENDCASE => ERROR Error[typecheck];
};
getinterval: PROC [self: Root] ~ {
count: INT ~ PopInt[self];
index: INT ~ PopInt[self];
arg1: Any ~ PopAny[self];
SELECT Type[arg1] FROM
array => {
array: Array ~ ArrayFromAny[arg1];
IF ArrayAccess[array]<readOnly THEN ERROR Error[invalidaccess];
PushArray[self, ArrayGetInterval[array, index, count]];
};
string => {
string: String ~ StringFromAny[arg1];
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
PushString[self, StringGetInterval[string, index, count]];
};
ENDCASE => ERROR Error[typecheck];
};
putinterval: PROC [self: Root] ~ {
arg3: Any ~ PopAny[self];
index: INT ~ PopInt[self];
arg1: Any ~ PopAny[self];
SELECT Type[arg1] FROM
array => {
array1: Array ~ ArrayFromAny[arg1];
array2: Array ~ ArrayFromAny[arg3];
IF ArrayAccess[array1]<unlimited THEN ERROR Error[invalidaccess];
IF ArrayAccess[array2]<readOnly THEN ERROR Error[invalidaccess];
ArrayPutInterval[array1, index, array2];
};
string => {
string1: String ~ StringFromAny[arg1];
string2: String ~ StringFromAny[arg3];
IF StringAccess[string1]<unlimited THEN ERROR Error[invalidaccess];
IF StringAccess[string2]<readOnly THEN ERROR Error[invalidaccess];
StringPutInterval[string1, index, string2];
};
ENDCASE => ERROR Error[typecheck];
};
forall: PROC [self: Root] ~ {
proc: Any ~ PopAny[self];
arg: Any ~ PopAny[self];
SELECT Type[arg] FROM
array => {
array: Array ~ ArrayFromAny[arg];
action: PROC [x: Any] ~ {
PushAny[self, x];
Execute[self, proc];
};
IF ArrayAccess[array]<readOnly THEN ERROR Error[invalidaccess];
ArrayForAll[array, action ! Exit => CONTINUE];
};
string => {
string: String ~ StringFromAny[arg];
action: PROC [c: CHAR] ~ {
PushInt[self, IntFromChar[c]];
Execute[self, proc];
};
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
StringForAll[string, action ! Exit => CONTINUE];
};
dict => {
dict: Dict ~ DictFromAny[arg];
action: PROC [key, val: Any] ~ {
PushAny[self, key];
PushAny[self, val];
Execute[self, proc];
};
IF DictAccess[dict]<readOnly THEN ERROR Error[invalidaccess];
DictForAll[dict, action ! Exit => CONTINUE];
};
ENDCASE => ERROR Error[typecheck];
};
token: PROC [self: Root] ~ {
arg: Any ~ PopAny[self];
SELECT Type[arg] FROM
string => {
string: String ~ StringFromAny[arg];
found: BOOL; token: Any; post: String;
IF StringAccess[string]<readOnly THEN ERROR Error[invalidaccess];
[found, token, post] ← StringToken[string];
IF found THEN {
PushString[self, post];
PushAny[self, token];
PushBool[self, TRUE];
}
ELSE {
PushBool[self, FALSE];
};
};
file => {
file: File ~ FileFromAny[arg];
found: BOOL; token: Any;
IF FileAccess[file]<readOnly THEN ERROR Error[invalidaccess];
[found, token] ← FileToken[file];
IF found THEN {
PushAny[self, token];
PushBool[self, TRUE];
}
ELSE {
PushBool[self, FALSE];
};
};
ENDCASE => ERROR Error[typecheck];
};
Registration
Primitives1: PROC [self: Root] ~ {
Register[self, "pop", pop];
Register[self, "exch", exch];
Register[self, "dup", dup];
Register[self, "index", index];
Register[self, "roll", roll];
Register[self, "clear", clear];
Register[self, "count", count];
Register[self, "mark", mark];
Register[self, "cleartomark", cleartomark];
Register[self, "counttomark", counttomark];
Register[self, "add", add];
Register[self, "div", div];
Register[self, "idiv", idiv];
Register[self, "mod", mod];
Register[self, "mul", mul];
Register[self, "sub", sub];
Register[self, "abs", abs];
Register[self, "neg", neg];
Register[self, "ceiling", ceiling];
Register[self, "floor", floor];
Register[self, "round", round];
Register[self, "truncate", truncate];
Register[self, "sqrt", sqrt];
Register[self, "atan", atan];
Register[self, "cos", cos];
Register[self, "sin", sin];
Register[self, "exp", exp];
Register[self, "ln", ln];
Register[self, "log", log];
Register[self, "rand", rand];
Register[self, "srand", srand];
Register[self, "rrand", rrand];
Register[self, "array", array];
Register[self, "[", startarray];
Register[self, "]", endarray];
Register[self, "aload", aload];
Register[self, "astore", astore];
Register[self, "dict", dict];
Register[self, "maxlength", maxlength];
Register[self, "begin", begin];
Register[self, "end", end];
Register[self, "def", def];
Register[self, "load", load];
Register[self, "store", store];
Register[self, "known", known];
Register[self, "where", where];
RegisterAny[self, "errordict", xxx];
RegisterAny[self, "systemdict", xxx];
RegisterAny[self, "userdict", xxx];
Register[self, "currentdict", currentdict];
Register[self, "countdictstack", countdictstack];
Register[self, "dictstack", dictstack];
Register[self, "string", string];
Register[self, "anchorsearch", anchorsearch];
Register[self, "search", search];
Register[self, "eq", eq];
Register[self, "ne", ne];
Register[self, "ge", ge];
Register[self, "gt", gt];
Register[self, "le", le];
Register[self, "lt", lt];
Register[self, "and", and];
Register[self, "not", not];
Register[self, "or", or];
Register[self, "xor", xor];
RegisterAny[self, "true", xxx];
RegisterAny[self, "false", xxx];
Register[self, "bitshift", bitshift];
Register[self, "exec", exec];
Register[self, "if", if];
Register[self, "ifelse", ifelse];
Register[self, "for", for];
Register[self, "repeat", repeat];
Register[self, "loop", loop];
Register[self, "exit", exit];
Register[self, "stop", stop];
Register[self, "stopped", stopped];
Register[self, "countexecstack", countexecstack];
Register[self, "execstack", execstack];
Register[self, "quit", quit];
RegisterAny[self, "start", xxx];
Register[self, "type", type];
Register[self, "cvlit", cvlit];
Register[self, "cvx", cvx];
Register[self, "xcheck", xcheck];
Register[self, "executeonly", executeonly];
Register[self, "noaccess", noaccess];
Register[self, "readonly", readonly];
Register[self, "rcheck", rcheck];
Register[self, "wcheck", wcheck];
Register[self, "cvi", cvi];
Register[self, "cvn", cvn];
Register[self, "cvr", cvr];
Register[self, "cvrs", cvrs];
Register[self, "cvs", cvs];
Register[self, "file", file];
Register[self, "closefile", closefile];
Register[self, "read", read];
Register[self, "write", write];
Register[self, "readhexstring", readhexstring];
Register[self, "writehexstring", writehexstring];
Register[self, "readstring", readstring];
Register[self, "writestring", writestring];
Register[self, "readline", readline];
Register[self, "bytesavailable", bytesavailable];
Register[self, "flush", flush];
Register[self, "flushfile", flushfile];
Register[self, "resetfile", resetfile];
Register[self, "status", status];
Register[self, "run", run];
Register[self, "currentfile", currentfile];
Register[self, "print", print];
RegisterAny[self, "=", xxx];
RegisterAny[self, "stack", xxx];
RegisterAny[self, "==", xxx];
RegisterAny[self, "pstack", xxx];
Register[self, "echo", echo];
Register[self, "copy", copy];
Register[self, "length", length];
Register[self, "get", get];
Register[self, "put", put];
Register[self, "getinterval", getinterval];
Register[self, "putinterval", putinterval];
Register[self, "forall", forall];
Register[self, "token", token];
};
RegisterPrimitives[Primitives1];
END.