<> <> <> <> <<>> 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 ]]; <> <> < RETURN [x.int];>> < RETURN [Fix[x.real ! Real.RealException => GOTO RangeCheck]];>> < RETURN [CvI[NumFromString[x]]];>> < ERROR Error[typecheck];>> < ERROR Error[rangecheck];>> <<};>> <<>> <> <> < RETURN [REAL[x.int]];>> < RETURN [x.real];>> < RETURN [CvR[NumFromString[x]]];>> < ERROR Error[typecheck];>> <<};>> <<>> <> Push: PROC [stack: Stack, x: Any] ~ { count: ArrayIndex ~ stack.count; IF count0 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> 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 { IF val.access { IF val.access { base: DictBase ~ NARROW[x.ref]; IF access=executeOnly THEN ERROR Error[typecheck]; IF base.access 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]; }; <> <> <> <<};>> <<>> <> <> <> < Push[self.ostack, CvN[x]];>> < ERROR Error[typecheck];>> <<};>> <<>> <> <> <> <<};>> <<>> <> <> <> <> <> <> <<};>> <<>> <> <<};>> <<>> 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.