DIRECTORY
PS,
Real;

PS1Impl: CEDAR PROGRAM
IMPORTS PS, Real
~ BEGIN OPEN PS;
Fix: PROC [real: REAL] RETURNS [INT] ~ { RETURN [Real.Fix[real]] };

IntFromReal: PUBLIC PROC [real: REAL] RETURNS [int: INT _ 0] ~ {
int _ Fix[real ! Real.RealException => CONTINUE];
IF int#real THEN ERROR Error[rangecheck];
};

IntFromAny: PUBLIC PROC [x: Any] RETURNS [INT] ~ {
WITH val: x.val SELECT FROM
integer => RETURN [val.int];
real => RETURN [IntFromReal[val.real]];
ENDCASE => ERROR Error[typecheck];
};

RealFromAny: PUBLIC PROC [x: Any] RETURNS [REAL] ~ {
WITH val: x.val SELECT FROM
integer => RETURN [REAL[val.int]];
real => RETURN [val.real];
ENDCASE => ERROR Error[typecheck];
};

BoolFromAny: PUBLIC PROC [x: Any] RETURNS [BOOL] ~ {
WITH val: x.val SELECT FROM
boolean => RETURN [val.bool];
ENDCASE => ERROR Error[typecheck];
};

ArrayFromAny: PUBLIC PROC [x: Any] RETURNS [Array] ~ {
WITH val: x.val SELECT FROM
array => RETURN [[
executable: val.executable, access: val.access,
start: val.start, length: val.length, base: NARROW[x.ref]
]];
ENDCASE => ERROR Error[typecheck];
};

StringFromAny: PUBLIC PROC [x: Any] RETURNS [String] ~ {
WITH val: x.val SELECT FROM
string => RETURN [[
executable: val.executable, access: val.access,
start: val.start, length: val.length, base: NARROW[x.ref]
]];
ENDCASE => ERROR Error[typecheck];
};

DictFromAny: PUBLIC PROC [x: Any] RETURNS [Dict] ~ {
WITH val: x.val SELECT FROM
dict => RETURN [[executable: val.executable, base: NARROW[x.ref]]];
ENDCASE => ERROR Error[typecheck];
};

AnyFromInt: PUBLIC PROC [int: INT] RETURNS [Any] ~ {
RETURN[[val: [executable: FALSE, variant: integer[int: int]], ref: NIL]];
};

AnyFromReal: PUBLIC PROC [real: REAL] RETURNS [Any] ~ {
RETURN[[val: [executable: FALSE, variant: real[real: real]], ref: NIL]];
};

AnyFromBool: PUBLIC PROC [bool: BOOL] RETURNS [Any] ~ {
RETURN[[val: [executable: FALSE, variant: boolean[bool: bool]], ref: NIL]];
};

AnyFromArray: PUBLIC PROC [array: Array] RETURNS [Any] ~ {
RETURN[[val: [executable: array.executable, variant: array[access: array.access, 
start: array.start, length: array.length]], ref: array.base]];
};

AnyFromString: PUBLIC PROC [string: String] RETURNS [Any] ~ {
RETURN[[val: [executable: string.executable, variant: string[access: string.access, 
start: string.start, length: string.length]], ref: string.base]];
};

AnyFromFile: PUBLIC PROC [file: File] RETURNS [Any] ~ {
RETURN[[val: [executable: file.executable, variant: file[access: file.access]], ref: file.stream]];
};

AnyFromDict: PUBLIC PROC [dict: Dict] RETURNS [Any] ~ {
RETURN[[val: [executable: dict.executable, variant: dict[]], ref: dict.base]];
};

AnyFromName: PUBLIC PROC [name: Name] RETURNS [Any] ~ {
RETURN[[val: [executable: name.executable, variant: name[]], ref: name.atom]];
};

AtomFromTypeArray: TYPE ~ ARRAY AnyType OF ATOM;
atomFromType: REF AtomFromTypeArray ~ NEW [AtomFromTypeArray _ [
array: $arraytype,
boolean: $booleantype,
dict: $dicttype,
file: $filetype,
font: $fonttype, 
integer: $integertype,
mark: $marktype,
name: $nametype,
null: $nulltype,
operator: $operatortype,
real: $realtype,
save: $savetype,
string: $stringtype
]];

Push: PROC [stack: Stack, x: Any] ~ {
count: ArrayIndex ~ stack.count;
IF count<stack.size THEN { stack.base[count] _ x; stack.count _ count+1 }
ELSE ERROR Error[stack.overflow];
};

Pop: PROC [stack: Stack] RETURNS [x: Any] ~ {
count: ArrayIndex ~ stack.count;
IF count>0 THEN RETURN [stack.base[stack.count _ count-1]]
ELSE ERROR Error[stack.underflow];
};

Top: PROC [stack: Stack] RETURNS [x: Any] ~ {
count: ArrayIndex ~ stack.count;
IF count>0 THEN RETURN [stack.base[count-1]]
ELSE ERROR Error[stack.underflow];
};


PushInt: PROC [stack: Stack, int: INT] ~ {
Push[stack, AnyFromInt[int]];
};

PushReal: PROC [stack: Stack, real: REAL] ~ {
Push[stack, AnyFromReal[real]];
};

PushBool: PROC [stack: Stack, bool: BOOL] ~ {
Push[stack, AnyFromBool[bool]];
};

PushArray: PROC [stack: Stack, array: Array] ~ {
Push[stack, AnyFromArray[array]];
};

PushString: PROC [stack: Stack, string: String] ~ {
Push[stack, AnyFromString[string]];
};

PushFile: PROC [stack: Stack, file: File] ~ {
Push[stack, AnyFromFile[file]];
};

PushDict: PROC [stack: Stack, dict: Dict] ~ {
Push[stack, AnyFromDict[dict]];
};

PushName: PROC [stack: Stack, name: Name] ~ {
Push[stack, AnyFromName[name]];
};


PopInt: PROC [stack: Stack] RETURNS [INT] ~ {
x: Any ~ Pop[stack];
WITH val: x.val SELECT FROM
integer => RETURN [val.int];
ENDCASE => RETURN [IntFromAny[x]];
};

PopReal: PROC [stack: Stack] RETURNS [REAL] ~ {
x: Any ~ Pop[stack];
WITH val: x.val SELECT FROM
integer => RETURN [REAL[val.int]];
real => RETURN [val.real];
ENDCASE => RETURN [RealFromAny[x]];
};

PopBool: PROC [stack: Stack] RETURNS [BOOL] ~ {
x: Any ~ Pop[stack];
WITH val: x.val SELECT FROM
boolean => RETURN [val.bool];
ENDCASE => RETURN [BoolFromAny[x]];
};

PopNum: PROC [stack: Stack] RETURNS [Any] ~ {
x: Any ~ Pop[stack];
SELECT Type[x] FROM
integer, real => RETURN [x];
ENDCASE => ERROR Error[typecheck];
};

PopArray: PROC [stack: Stack] RETURNS [Array] ~ {
RETURN[ArrayFromAny[Pop[stack]]];
};

PopString: PROC [stack: Stack] RETURNS [String] ~ {
RETURN[StringFromAny[Pop[stack]]];
};

PopFile: PROC [stack: Stack] RETURNS [File] ~ {
RETURN[FileFromAny[Pop[stack]]];
};

PopDict: PROC [stack: Stack] RETURNS [Dict] ~ {
RETURN[DictFromAny[Pop[stack]]];
};


mark: Any ~ [val: [executable: FALSE, variant: mark[]], ref: NIL];

PushMark: PROC [stack: Stack] ~ {
Push[stack, mark];
};

PopMark: PROC [stack: Stack] ~ {
x: Any ~ Pop[stack];
IF Type[x]#mark THEN ERROR Error[typecheck];
};


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];
ArrayTransfer[to: stack.base, toStart: count, 
from: stack.base, 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;
temp: Any ~ stack.base[i1];
stack.base[i1] _ stack.base[i2];
stack.base[i2] _ temp;
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.base[count-1-n]]
ELSE ERROR Error[stack.underflow];
};
};

Clear: PROC [stack: Stack] ~ {
stack.count _ 0;
};

Count: PROC [stack: Stack] RETURNS [INT] ~ {
RETURN [stack.count];
};

ClearToMark: PROC [stack: Stack] ~ {
count: ArrayIndex ~ stack.count;
FOR i: ArrayIndex DECREASING IN [0..count) DO
IF Type[stack.base[i]]=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 Type[stack.base[i]]=mark THEN RETURN [count-(i+1)];
ENDLOOP;
ERROR Error[unmatchedmark];
};

Ptype: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
PushName[self.ostack, [executable: TRUE, atom: atomFromType[Type[x]]]];
};

Pcvlit: PROC [self: Root] ~ {
x: Any _ Pop[self.ostack];
x.val.executable _ FALSE;
Push[self.ostack, x];
};

Pcvx: PROC [self: Root] ~ {
x: Any _ Pop[self.ostack];
x.val.executable _ TRUE;
Push[self.ostack, x];
};

Pxcheck: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
PushBool[self.ostack, x.val.executable];
};

ChangeAccess: PROC [x: Any, access: Access] RETURNS [Any] ~ {
WITH val: x.val SELECT FROM
array => {
IF val.access<access THEN ERROR Error[invalidaccess];
val.access _ access;
};
string => {
IF val.access<access THEN ERROR Error[invalidaccess];
val.access _ access;
};
file => {
IF val.access<access THEN ERROR Error[invalidaccess];
val.access _ access;
};
dict => {
base: DictBase ~ NARROW[x.ref];
IF access=executeOnly THEN ERROR Error[typecheck];
IF base.access<access THEN ERROR Error[invalidaccess];
base.access _ access;
};
ENDCASE => ERROR Error[typecheck];
RETURN [x];
};

Preadonly: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
Push[self.ostack, ChangeAccess[x, readOnly]];
};

Pexecuteonly: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
Push[self.ostack, ChangeAccess[x, executeOnly]];
};

Pnoaccess: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
Push[self.ostack, ChangeAccess[x, none]];
};

Prcheck: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
bool: BOOL _ FALSE;
SELECT Type[x] FROM
array => bool _ ArrayFromAny[x].access>=readOnly;
string => bool _ StringFromAny[x].access>=readOnly;
dict => bool _ DictFromAny[x].base.access>=readOnly;
file => bool _ FileFromAny[x].access>=readOnly;
ENDCASE => ERROR Error[typecheck];
PushBool[self.ostack, bool];
};

Pwcheck: PROC [self: Root] ~ {
x: Any ~ Pop[self.ostack];
bool: BOOL _ FALSE;
SELECT Type[x] FROM
array => bool _ ArrayFromAny[x].access=unlimited;
string => bool _ StringFromAny[x].access=unlimited;
dict => bool _ DictFromAny[x].base.access=unlimited;
file => bool _ FileFromAny[x].access=unlimited;
ENDCASE => ERROR Error[typecheck];
PushBool[self.ostack, bool];
};


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]];
};


Register1: PROC [self: Root] ~ {
Register[self, "pop", Ppop];
Register[self, "exch", Pexch];
Register[self, "dup", Pdup];
Register[self, "index", Pindex];
Register[self, "roll", Proll];
Register[self, "clear", Pclear];
Register[self, "count", Pcount];
Register[self, "mark", Pmark];
Register[self, "cleartomark", Pcleartomark];
Register[self, "counttomark", Pcounttomark];
};

RegisterPrimitives[Register1];

END.
"PS1Impl.mesa
Copyright Σ 1986 by Xerox Corporation.  All rights reserved.
Doug Wyatt, October 29, 1986 5:19:51 pm PST
PostScript implementation: type checking and stack operations.

Type and Attribute operations
Type, attribute, and conversion operators
CvI: PROC [x: Any] RETURNS [INT] ~ {
WITH x: x SELECT FROM
int => 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];
};

Stack operations
Primitives
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] ~ {
};

Κs˜
codeš
œ™Kš
œ<™<K™+—K˜K™>K™š
Οk	˜	Kšœ
˜Kš
œ˜—K˜KšΟnœœ
˜Kšœ
œ˜Kšœœ
œ
œ
˜
head™šžœœœœœœ˜CK˜—šžœœ
œœœœ	˜@Jšœ'œ˜1Jšœ
œ
œ˜)K˜K˜—š
ž
œœ
œ
œœ˜2šœœ
˜Kšœœ˜Kšœœ˜'Kšœœ˜"—K˜K˜—š
žœœ
œ
œœ˜4šœœ
˜Kšœœœ˜"Kšœœ˜Kšœœ˜"—K˜K˜—š
žœœ
œ
œœ˜4šœœ
˜Kšœœ˜Kšœœ˜"—K˜K˜—šžœœ
œ
œ˜6šœœ
˜šœ	œ˜Kš
œ/˜/Kšœ,œ˜9Kš
œ˜—Kšœœ˜"—K˜K˜—šž
œœ
œ
œ
˜8šœœ
˜šœ
œ˜Kš
œ/˜/Kšœ,œ˜9Kš
œ˜—Kšœœ˜"—K˜K˜—šžœœ
œ
œ˜4šœœ
˜Kšœœ%œ
˜CKšœœ˜"—K˜K˜—š
ž
œœ
œœœ
˜4Kšœœ$œ˜IK˜K˜—š
žœœ
œœœ
˜7Kšœœ#œ˜HK˜K˜—š
žœœ
œœœ
˜7Kšœœ&œ˜KK˜K˜—šžœœ
œœ
˜:KšœŠ
˜
K˜K˜—šž
œœ
œœ
˜=Kšœ
˜–
K˜K˜—šžœœ
œœ
˜7Kšœ]˜cK˜K˜—šžœœ
œœ
˜7KšœH˜NK˜K˜—šžœœ
œœ
˜7KšœH˜NK˜K˜——™)Kš	œœœ	œ
œ
˜0šœœœ˜@Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜K˜—šžœœ
œœ™$šœœ
™Kšœœ	™Kšœœ%œ™EKšœ
œ™)Kšœœ™"—Kšœœ™,K™K™—šžœœ
œœ™%šœœ
™Kšœœœ	™Kšœœ
™Kšœ
œ™)Kšœœ™"—K™K™——™šžœœ˜%Kš
œ ˜ Kšœœ1˜IKšœ
œ˜!K˜K˜—šžœœœ
˜-Kš
œ ˜ Kšœ	œ
œ$˜:Kšœ
œ˜"K˜K˜—šžœœœ
˜-Kš
œ ˜ Kšœ	œ
œ˜,Kšœ
œ˜"K˜K˜—K˜šžœœœ˜*Kš
œ˜K˜K˜—šžœœœ˜-Kš
œ˜K˜K˜—šžœœœ˜-Kš
œ˜K˜K˜—šž	œœ!˜0Kš
œ!˜!K˜K˜—šž
œœ#˜3Kš
œ#˜#K˜K˜—šžœœ˜-Kš
œ˜K˜K˜—šžœœ˜-Kš
œ˜K˜K˜—šžœœ˜-Kš
œ˜K˜K˜—K˜šžœœœœ˜-K˜šœœ
˜Kšœœ˜Kšœœ˜"—K˜K˜—šžœœœœ˜/K˜šœœ
˜Kšœœœ˜"Kšœœ˜Kšœœ˜#—K˜K˜—šžœœœœ˜/K˜šœœ
˜Kšœœ˜Kšœœ˜#—K˜K˜—šžœœœ
˜-K˜šœ	˜Kšœœ˜Kšœœ˜"—K˜K˜—šžœœœ˜1Kšœ˜!K˜K˜—šž	œœœ
˜3Kšœ˜"K˜K˜—šžœœœ˜/Kšœ˜ K˜K˜—šžœœœ˜/Kšœ˜ K˜K˜—K˜šœœœ˜BK˜—šžœœ˜!Kš
œ˜K˜K˜—šžœœ˜ K˜Kšœœ
œ˜,K˜K˜—K˜šžœœœ˜%šœœœ˜Kš
œ ˜ K˜Kšœ
œ
œ˜1Kšœœ
œ˜=Kš
œh˜hK˜ K˜
—Kšœ
œ˜K˜K˜—šžœœœ˜(K˜ Kšœœ
œ˜$Kšœ	œ
œ˜-Kšœœ	œ
˜Kšœœ	œ
˜šœœ˜
šžœœœ˜2šœœ˜*Kš
œ˜Kš
œ˜K˜K˜ Kš
œ˜Kšœ
˜—K˜—Kš
œ˜Kš
œ˜Kš
œ˜K˜—K˜K˜—šžœœœœ
˜4Kšœœ
œ˜#šœ˜K˜ Kšœ	œ
œ˜-Kšœ
œ˜"K˜—K˜K˜—šžœœ˜Kš
œ˜Kš
œ˜K˜—šžœœœœ˜,Kšœ˜Kš
œ˜K˜—šžœœ˜$K˜ šœ
œ
œ˜-Kšœœ˜1Kšœ
˜—Kšœ˜K˜K˜—šžœœœœ˜2K˜ šœ
œ
œ˜-Kšœœ
œ˜6Kšœ
˜—Kšœ˜K˜K˜——™
šžœœ˜K˜Kšœ#œ ˜GK˜K˜—šžœœ˜K˜Kšœœ
˜K˜K˜K˜—šžœœ˜K˜Kšœœ
˜K˜K˜K˜—šžœœ˜K˜Kš
œ(˜(K˜K˜—šžœœœ
˜=šœœ
˜š
œ
˜
Kšœœ
œ˜5Kš
œ˜Kš
œ˜—š
œ˜Kšœœ
œ˜5Kš
œ˜Kš
œ˜—š
œ	˜	Kšœœ
œ˜5Kš
œ˜Kš
œ˜—š
œ	˜	Kšœœ˜Kšœœ
œ˜2Kšœœ
œ˜6Kš
œ˜Kš
œ˜—Kšœœ˜"—Kšœ˜K˜K˜—šž	œœ˜ K˜K˜-K˜K˜—šžœœ˜#K˜K˜0K˜K˜—šž	œœ˜ K˜K˜)K˜K˜—šžœœ˜K˜Kšœœœ
˜šœ	˜Kš
œ1˜1Kš
œ3˜3Kš
œ4˜4Kš
œ/˜/Kšœœ˜"—K˜K˜K˜—šžœœ˜K˜Kšœœœ
˜šœ	˜Kš
œ1˜1Kš
œ3˜3Kš
œ4˜4Kš
œ/˜/Kšœœ˜"—K˜K˜K˜—šžœœ™K™K™K™K™—šžœœ™K™šœœ
™Kš
œ$™$Kšœœ™"—K™K™—šžœœ™K™K™K™K™—šžœœ™K™(Kšœœ™!Kš
œ™Kšœœ™Kšœ™K™K™—šžœœ™K™K™—K˜šžœœ˜K˜K˜K˜—šžœœ˜K˜K˜K˜—šžœœ˜K˜K˜K˜—šžœœ˜Kšœœ˜K˜)K˜K˜—šžœœ˜Kšœœ˜Kšœœ˜K˜K˜K˜—šžœœ˜K˜K˜K˜—šžœœ˜K˜)K˜K˜—šžœœ˜K˜K˜K˜—šžœœ˜#K˜K˜K˜—šžœœ˜#K˜/K˜K˜—J˜šž	œœ˜ Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ ˜ Kš
œ˜Kš
œ ˜ Kš
œ ˜ Kš
œ˜Kš
œ,˜,Kš
œ,˜,J˜J˜—J˜—J˜Jšœ
˜—…—)^>σ