<> <> <> DIRECTORY Atom USING [PropList], IO USING [STREAM], PS, RefTab USING [Ref], Rope USING [ROPE]; PSImpl: PROGRAM ~ BEGIN OPEN PS; <> <> 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] ]; }; <> 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]]]; }; <> InvalidAccess: PROC ~ { ERROR Error[invalidaccess] }; StringAccess: PROC [s: String, access: Access] RETURNS [StringPointer] ~ INLINE { IF s.access=readOnly] }; WCheck: PROC [access: Access] RETURNS [BOOL] ~ INLINE { RETURN [access=unlimited] }; <> 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] ~ { }; <> Push: PROC [stack: Stack, x: Any] ~ { count: StackIndex ~ stack.count; IF count0 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]; }; <> 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; }; <> 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]; <> 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]; <> 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]; <<>> }; <> <> 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> 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]; }; <> AStore: PROC [stack: Stack, array: Array] ~ { to: ArrayPointer ~ ArrayAccess[array, unlimited]; IF stack.count> 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 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> 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 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]; }; <> 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) 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] ~ { }; <> 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]]; }; }; <> 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 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]; }; <> 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 controllimit) 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 controllimit) 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> 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]; }; <> 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] ~ { }; <> Psave: PROC [self: Root] ~ { }; Prestore: PROC [self: Root] ~ { }; Pvmstatus: PROC [self: Root] ~ { }; <> Pbind: PROC [self: Root] ~ { }; Pusertime: PROC [self: Root] ~ { }; <> 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] ~ { }; <> 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] ~ { }; <> 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] ~ { }; <> Perasepage: PROC [self: Root] ~ { }; Pfill: PROC [self: Root] ~ { }; Peofill: PROC [self: Root] ~ { }; Pstroke: PROC [self: Root] ~ { }; Pimage: PROC [self: Root] ~ { }; Pimagemask: PROC [self: Root] ~ { }; <> Pshowpage: PROC [self: Root] ~ { }; Pcopypage: PROC [self: Root] ~ { }; Pbanddevice: PROC [self: Root] ~ { }; Pframedevice: PROC [self: Root] ~ { }; Pnulldevice: PROC [self: Root] ~ { }; Prenderbands: PROC [self: Root] ~ { }; <> 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] ~ { }; <> Pcachestatus: PROC [self: Root] ~ { }; Psetcachedevice: PROC [self: Root] ~ { }; Psetcharwidth: PROC [self: Root] ~ { }; Psetcachelimit: PROC [self: Root] ~ { }; END.