<> <> <> DIRECTORY FS USING [StreamOpen], Imager USING [Context, ContextRep, DoSave, DoSaveAll, ShowText], ImagerFont USING [MapText, XStringProc], Interpress USING [classMasterError, classMasterWarning, LogProc, Master, MasterImplRep, MasterRep, Credentials, Instructions], IO USING [int, PutFR1, STREAM], IPExecute USING [defaultMaxStackLength], IPInterpreter USING [Any, Apply, Array, ArrayFromVector, Cardinal, Context, ContextRep, Count, Get, Mark, Marker, Operator, OperatorClass, OperatorClassRep, OperatorRep, PopToActiveMark, PushIdentifier, PushNum, PushVector, Ref, Rep, StackArrayRep, Unmark, Vector, VectorFromArray, VectorFromBits, VectorFromBytes, VectorFromString, ZeroVec], IPMaster USING [Block, Body, BYTE, GetSkeleton, GetToken, IntFromSequenceData, OpFromEncodingValue, Node, NodeRep, Preamble, RealFromSequenceData, SequenceType, Skeleton, SkeletonRecord, SkipBytes, SkipToEndOfBody, Token, Vector], RefText USING [ReserveChars], Rope USING [AppendChars, Concat, Fetch, FromRefText, ROPE, Size, Substr], RopeFile USING [FromStream]; IPExecImpl: CEDAR PROGRAM IMPORTS FS, IO, Imager, ImagerFont, IPInterpreter, IPMaster, RefText, Rope, RopeFile EXPORTS Interpress, IPInterpreter, IPExecute ~ { ROPE: TYPE ~ Rope.ROPE; STREAM: TYPE ~ IO.STREAM; Token: TYPE ~ IPMaster.Token; Body: TYPE ~ IPMaster.Body; Block: TYPE ~ IPMaster.Block; Node: TYPE ~ IPMaster.Node; NodeRep: TYPE ~ IPMaster.NodeRep; BYTE: TYPE ~ IPMaster.BYTE; MarkRecovery: PUBLIC ERROR ~ CODE; Bug: PUBLIC ERROR ~ CODE; contextFreeCountMax: INT _ 8; AllocContext: PROC [self: IPInterpreter.Ref] RETURNS [context: IPInterpreter.Context] ~ { IF self.contextFreeCount>0 THEN { context _ self.contextFree; self.contextFree _ context.caller; self.contextFreeCount _ self.contextFreeCount-1} ELSE context _ NEW [IPInterpreter.ContextRep]; }; FreeContext: PROC [self: IPInterpreter.Ref, context: IPInterpreter.Context] ~ { IF self.contextFreeCount { self.context _ context.caller; FreeContext[self, context] }]; IF self.context=context THEN { self.context _ context.caller; FreeContext[self, context] } ELSE ERROR Bug; }; Frame: PUBLIC PROC[self: IPInterpreter.Ref] RETURNS[IPMaster.Vector] ~ { context: IPInterpreter.Context ~ self.context; IF context.frame=NIL THEN RETURN[context.initialFrame] ELSE RETURN[IPInterpreter.VectorFromArray[context.frame]]; }; FGet: PUBLIC PROC[self: IPInterpreter.Ref, i: IPInterpreter.Cardinal] RETURNS[IPInterpreter.Any] ~ { context: IPInterpreter.Context ~ self.context; IF context.frame=NIL THEN RETURN[IPInterpreter.Get[context.initialFrame, i]] ELSE { array: IPInterpreter.Array ~ context.frame; RETURN[array[i-array.lowerBound]] }; }; FSet: PUBLIC PROC[self: IPInterpreter.Ref, x: IPInterpreter.Any, i: IPInterpreter.Cardinal] ~ { context: IPInterpreter.Context ~ self.context; IF context.frame=NIL THEN context.frame _ IPInterpreter.ArrayFromVector[context.initialFrame]; { array: IPInterpreter.Array ~ context.frame; array[i-array.lowerBound] _ x }; }; Env: PUBLIC PROC[self: IPInterpreter.Ref] RETURNS[IPMaster.Vector] ~ {RETURN[self.context.env]}; DoSave: PUBLIC PROC[self: IPInterpreter.Ref, action: PROC] ~ { <> Imager.DoSave[self.imager, action]; }; DoSaveAll: PUBLIC PROC[self: IPInterpreter.Ref, action: PROC] ~ { <> Imager.DoSaveAll[self.imager, action]; }; Run: TYPE ~ RECORD[start, len: INT]; RunList: TYPE ~ LIST OF Run; DoString: PROC [self: IPInterpreter.Ref, text: REF TEXT] ~ { string: ImagerFont.XStringProc ~ { ImagerFont.MapText[text: text, charAction: charAction] }; IPInterpreter.PushVector[self, IPInterpreter.VectorFromString[string]]; }; DoIdentifier: PROC [self: IPInterpreter.Ref, text: REF TEXT] ~ { len: NAT ~ text.length; warn: BOOL _ FALSE; FOR i: NAT IN[0..len) DO char: CHAR ~ text[i]; SELECT char FROM IN['a..'z], IN['A..'Z] => NULL; IN['0..'9], '- => IF i=0 THEN warn _ TRUE; ENDCASE => warn _ TRUE; ENDLOOP; IF len=0 THEN warn _ TRUE; IPInterpreter.PushIdentifier[self, Rope.FromRefText[text]]; IF warn THEN MasterWarning[$invalidEncoding, "Invalid Identifier"]; }; DoCardinal: PROC [self: IPInterpreter.Ref, text: REF TEXT] ~ { len: NAT ~ text.length; IF len<=4 THEN { val: INT ~ IPMaster.IntFromSequenceData[text]; IPInterpreter.PushNum[self, [int[val]]]} ELSE { val: REAL ~ IPMaster.RealFromSequenceData[text]; IPInterpreter.PushNum[self, [real[val]]]}; }; DoRational: PROC [self: IPInterpreter.Ref, text: REF TEXT] ~ { len: NAT ~ text.length; half: NAT ~ len/2; IF half<=4 THEN { n: INT ~ IPMaster.IntFromSequenceData[text: text, start: 0, len: half]; d: INT ~ IPMaster.IntFromSequenceData[text: text, start: half, len: half]; IF n IN INTEGER AND d IN INTEGER THEN IPInterpreter.PushNum[self, [rational[n: n, d: d]]] ELSE IPInterpreter.PushNum[self, [real[REAL[n]/REAL[d]]]]} ELSE { n: REAL ~ IPMaster.RealFromSequenceData[text: text, start: 0, len: half]; d: REAL ~ IPMaster.RealFromSequenceData[text: text, start: half, len: half]; IPInterpreter.PushNum[self, [real[n/d]]]}; IF (half+half)#len THEN MasterWarning[$invalidEncoding, IO.PutFR1["Invalid sequenceRational (length=%g)", IO.int[len]]]; }; DoInsertFile: PROC [self: IPInterpreter.Ref, text: REF TEXT] ~ { MasterWarning[$unimplemented, "sequenceInsertFile found after PreScanning"]; }; Fetch16: PROC [rope: ROPE, startByte: INT] RETURNS [CARDINAL] ~ { b0: CARDINAL ~ Rope.Fetch[rope, startByte]-'\000; b1: CARDINAL ~ Rope.Fetch[rope, startByte+1]-'\000; RETURN [b0*256+b1]; }; RopeFromRuns: PROC [ropeChunk: ROPE, runs: LIST OF Run, sequenceLength: INT] RETURNS [rope: ROPE _ NIL] ~ { FOR r: LIST OF Run _ runs, r.rest UNTIL r = NIL DO run: Run _ r.first; rope _ Rope.Concat[rope, Rope.Substr[ropeChunk, run.start, run.len]]; ENDLOOP; IF Rope.Size[rope] # sequenceLength THEN ERROR; }; ExecuteToEndOfBody: PROC [self: IPInterpreter.Ref] ~ { sequenceData: {nil, text, runs, skip} _ nil; sequenceType: IPMaster.SequenceType _ nil; sequenceLength: INT _ 0; sequenceRuns: INT _ 0; text: REF TEXT _ NIL; buffer: REF TEXT ~ self.buffer; runsHead, runsTail: LIST OF Run _ NIL; token: IPMaster.Token; BeginSequence: PROC [seq: IPMaster.SequenceType] ~ { SELECT sequenceType _ seq FROM sequenceString, sequenceIdentifier, sequenceInsertFile, sequenceComment, sequenceInteger, sequenceRational => sequenceData _ text; sequenceLargeVector, sequencePackedPixelVector, sequenceCompressedPixelVector, sequenceAdaptivePixelVector => sequenceData _ runs; ENDCASE => sequenceData _ skip; SELECT sequenceData FROM text => { text _ buffer; text.length _ 0 }; runs => { runsHead _ runsTail _ NIL }; ENDCASE; sequenceLength _ 0; }; ExtendSequence: PROC [length: INT] ~ { SELECT sequenceData FROM nil => { MasterWarning[$invalidEncoding, "Misplaced sequenceContinued"]; self.index _ IPMaster.SkipBytes[self.rope, self.index, length]}; text => { len: NAT ~ length; IF (text.maxLength-text.length) < len THEN text _ RefText.ReserveChars[text, len]; [] _ Rope.AppendChars[buffer: text, rope: self.rope, start: self.index, len: len]; self.index _ IPMaster.SkipBytes[self.rope, self.index, length] -- This wasn't here before -- }; runs => { prevTail: LIST OF Run ~ runsTail; runsTail _ LIST[[start: self.index, len: length]]; IF prevTail=NIL THEN runsHead _ runsTail ELSE prevTail.rest _ runsTail; self.index _ IPMaster.SkipBytes[self.rope, self.index, length]}; skip => self.index _ IPMaster.SkipBytes[self.rope, self.index, length]; ENDCASE => ERROR; sequenceRuns _ sequenceRuns+1; sequenceLength _ sequenceLength+length; }; FinishSequence: PROC ~ { SELECT sequenceType FROM sequenceString => DoString[self, text]; sequenceIdentifier => DoIdentifier[self, text]; sequenceInteger => DoCardinal[self, text]; sequenceRational => DoRational[self, text]; sequenceInsertFile => DoInsertFile[self, text]; sequenceComment => NULL; sequenceLargeVector => { rope: ROPE ~ RopeFromRuns[self.rope, runsHead, sequenceLength]; b: NAT ~ Rope.Fetch[rope, 0]-'\000; vector: IPMaster.Vector ~ IPInterpreter.VectorFromBytes[bytes: Rope.Substr[rope, 1], bytesPerElement: b, signed: TRUE]; IPInterpreter.PushVector[self, vector]}; sequencePackedPixelVector => { rope: ROPE ~ RopeFromRuns[self.rope, runsHead, sequenceLength]; bitsPerSample: [1..1] ~ Fetch16[rope, 0]; -- only one bit per sample supported here scanLength: NAT ~ Fetch16[rope, 2]; dataBitsPerLine: NAT ~ bitsPerSample*scanLength; padBitsPerLine: NAT ~ NAT[32 - (dataBitsPerLine MOD 32)] MOD 32; vector: IPMaster.Vector ~ IPInterpreter.VectorFromBits[bytes: Rope.Substr[rope, 4], dataBitsPerLine: dataBitsPerLine, padBitsPerLine: padBitsPerLine]; IPInterpreter.PushVector[self, vector]}; sequenceCompressedPixelVector => MasterWarning[$unimplemented, "Not implemented: sequenceCompressedPixelVector"]; sequenceAdaptivePixelVector => MasterWarning[$unimplemented, "Not implemented: sequenceAdaptivePixelVector"]; sequenceContinued => MasterWarning[$invalidEncoding, "Misplaced sequenceContinued"]; ENDCASE => MasterWarning[$invalidEncoding, IO.PutFR1["Invalid sequence type (%g)", IO.int[ORD[sequenceType]]]]; sequenceData _ nil; sequenceType _ nil; }; DO -- for each Token [token, self.index] _ IPMaster.GetToken[encoding: self.rope, start: self.index]; IF token.seq=sequenceContinued THEN { ExtendSequence[token.len]; LOOP }; self.context.token _ token; IF sequenceType=sequenceString THEN { done: BOOL _ TRUE; SELECT token.op FROM show => Imager.ShowText[context: self.imager, text: text]; showandxrel => Imager.ShowText[context: self.imager, text: text, xrel: TRUE]; ENDCASE => done _ FALSE; IF done THEN { sequenceData _ nil; sequenceType _ nil; LOOP }}; IF sequenceData#nil THEN FinishSequence[]; IF token.op=endBody THEN EXIT; SELECT token.type FROM op => IPInterpreter.Apply[self, IPMaster.OpFromEncodingValue[token.op]]; num => IPInterpreter.PushNum[self, [int[token.num]]]; seq => { BeginSequence[token.seq]; ExtendSequence[token.len] }; ENDCASE => ERROR; ENDLOOP }; BeginBody: PROC [self: IPInterpreter.Ref] RETURNS [INT] ~ { [self.context.token, self.index] _ IPMaster.GetToken[self.rope, self.index]; IF self.context.token.op # beginBody THEN MasterError[$missingBody, "Missing body"]; RETURN[self.index]; }; SkipInlineBody: PUBLIC PROC [self: IPInterpreter.Ref] ~ { self.index _ BeginBody[self]; self.index _ IPMaster.SkipToEndOfBody[self.rope, self.index]; }; GetInlineBody: PUBLIC PROC [self: IPInterpreter.Ref] RETURNS [IPMaster.Body] ~ { start, stop: INT _ 0; start _ self.index; self.index _ BeginBody[self]; stop _ self.index _ IPMaster.SkipToEndOfBody[self.rope, self.index]; RETURN[Rope.Substr[self.rope, start, stop-start]]; }; ExecuteInlineBody: PROC [self: IPInterpreter.Ref] ~ { self.index _ BeginBody[self]; DO error: BOOL _ FALSE; ExecuteToEndOfBody[self ! MarkRecovery => { error _ TRUE; CONTINUE }]; IF error THEN { -- do mark recovery marker: IPInterpreter.Marker ~ IPInterpreter.PopToActiveMark[self]; IF marker=self.context.marker THEN { token: IPMaster.Token; DO [token, self.index] _ IPMaster.GetToken[self.rope, self.index]; SELECT token.op FROM endBody => ERROR MarkRecovery; -- end of body beginBody => self.index _ IPMaster.SkipToEndOfBody[self.rope, self.index]; -- skip body literal unmark0 => EXIT; -- found UNMARK0 ENDCASE => NULL; IF token.type=seq THEN self.index _ IPMaster.SkipBytes[self.rope, self.index, token.len]; ENDLOOP} ELSE ERROR MarkRecovery; -- not this context's marker } ELSE EXIT; -- normal completion ENDLOOP; }; CallInlineBody: PUBLIC PROC [self: IPInterpreter.Ref, frame, env: IPMaster.Vector] ~ { action: PROC ~ { ExecuteInlineBody[self] }; Call[self: self, action: action, frame: frame, env: env]; }; CallBody: PROC [self: IPInterpreter.Ref, body: IPMaster.Body, frame: IPMaster.Vector, env: IPMaster.Vector] ~ { saveBody: ROPE ~ self.rope; saveIndex: INT ~ self.index; self.rope _ body; self.index _ 0; CallInlineBody[self: self, frame: frame, env: env ! UNWIND => {self.rope _ saveBody; self.index _ saveIndex}]; self.rope _ saveBody; self.index _ saveIndex; }; DoWithMarkProtection: PUBLIC PROC [self: IPInterpreter.Ref, action: PROC] ~ { error: BOOL _ FALSE; inner: PROC ~ { IPInterpreter.Mark[self, 0]; action[]; IPInterpreter.Unmark[self, 0] }; inner[! MarkRecovery => { error _ TRUE; CONTINUE}]; IF error THEN { -- do mark recovery marker: IPInterpreter.Marker ~ IPInterpreter.PopToActiveMark[self]; IF marker=self.context.marker THEN IPInterpreter.Unmark[self, 0] ELSE ERROR MarkRecovery; }; }; Do: PUBLIC PROC [self: IPInterpreter.Ref, op: IPInterpreter.Operator] ~ { op.class.do[op, self] }; composedClass: IPInterpreter.OperatorClass ~ NEW[IPInterpreter.OperatorClassRep _ [ type: $Composed, do: ComposedDo]]; ComposedData: TYPE ~ REF ComposedDataRep; ComposedDataRep: TYPE ~ RECORD[ frame: IPMaster.Vector, -- initial frame env: IPMaster.Vector, -- environment body: IPMaster.Body -- body of the operator ]; ComposedDo: PROC [op: IPInterpreter.Operator, state: IPInterpreter.Ref] ~ { data: ComposedData ~ NARROW[op.data]; CallBody[self: state, body: data.body, frame: data.frame, env: data.env]; }; MakeCO: PUBLIC PROC [frame, env: IPMaster.Vector, body: IPMaster.Body] RETURNS [IPInterpreter.Operator] ~ { data: ComposedData ~ NEW[ComposedDataRep _ [frame: frame, env: env, body: body]]; RETURN[NEW[IPInterpreter.OperatorRep _ [class: composedClass, data: data]]]; }; CallPreamble: PUBLIC PROC [self: IPInterpreter.Ref, preamble: IPMaster.Preamble, frame, env: IPMaster.Vector] ~ { IF preamble # NIL THEN { preambleProc: PROC ~ { IPInterpreter.Mark[self, 0]; ExecuteInlineBody[self]; IF IPInterpreter.Count[self]<1 THEN IPInterpreter.PushVector[self, Env[self]]; IF IPInterpreter.Count[self]<2 THEN IPInterpreter.PushVector[self, Frame[self]]; IPInterpreter.Unmark[self, 2]}; IF preamble.initialFrame = NIL THEN { oldSource: ROPE = self.rope; oldIndex: INT = self.index; self.rope _ preamble.source; self.index _ 0; self.topFrame _ frame; self.topEnv _ env; Call[self: self, action: preambleProc, frame: frame, env: env]; self.rope _ oldSource; self.index _ oldIndex; preamble.initialFrame _ self.topFrame} ELSE self.topFrame _ preamble.initialFrame} ELSE ERROR; }; CallNode: PUBLIC PROC [self: IPInterpreter.Ref, node: Node, frame, env: IPMaster.Vector] ~ { WITH node SELECT FROM node: REF NodeRep.body => { self.rope _ node.body; self.index _ 0; CallInlineBody[self: self, frame: frame, env: env]}; -- May have to save old self values < {>> <> <> <> <> <> <> <> <> <<};>> ENDCASE => ERROR; }; Master: TYPE ~ Interpress.Master; MasterRep: TYPE ~ Interpress.MasterRep; MasterImpl: TYPE ~ REF MasterImplRep; MasterImplRep: PUBLIC TYPE ~ RECORD [ -- exported to Interpress skeleton: IPMaster.Skeleton, interpreter: IPInterpreter.Ref ]; LogProc: TYPE ~ Interpress.LogProc; Error: SIGNAL [class: INT, code: ATOM, explanation: ROPE] ~ CODE; ReportError: PUBLIC PROC [class: INT, code: ATOM, explanation: ROPE] ~ { SIGNAL Error[class: class, code: code, explanation: explanation]; IF class=Interpress.classMasterError THEN ERROR MarkRecovery; }; MasterError: PUBLIC PROC [code: ATOM, explanation: ROPE] ~ { ReportError[class: Interpress.classMasterError, code: code, explanation: explanation]; }; MasterWarning: PUBLIC PROC [code: ATOM, explanation: ROPE _] ~ { ReportError[class: Interpress.classMasterWarning, code: code, explanation: explanation]; }; DoTopAction: PUBLIC PROC [self: IPInterpreter.Ref, action: PROC, log: LogProc] ~ { protect: PROC ~ { DoWithMarkProtection[self, action] }; call: PROC ~ { Call[self, protect, IPInterpreter.ZeroVec[0], IPInterpreter.ZeroVec[0]] }; save: PROC ~ { IF self.imager=NIL THEN call[] ELSE DoSaveAll[self, call] }; save[! Error => { IF log#NIL THEN {log[class, code, explanation]; RESUME} ELSE REJECT }]; }; <> <> <> <> <> <> <> <> <<};>> <<>> <> <<>> <<};>> Open: PUBLIC PROC [fileName: ROPE, log: LogProc, credentials: Interpress.Credentials _ NIL, instructionsHandle: Interpress.Instructions _ NIL] RETURNS [Master] ~ { RETURN [FromStream[FS.StreamOpen[fileName], log]]; }; FromStream: PUBLIC PROC [stream: STREAM, log: LogProc, credentials: Interpress.Credentials _ NIL, instructionsHandle: Interpress.Instructions _ NIL] RETURNS [Master] ~ { skeleton: IPMaster.Skeleton _ NEW[IPMaster.SkeletonRecord _ IPMaster.GetSkeleton[master: RopeFile.FromStream[stream], start: 0]]; self: IPInterpreter.Ref ~ NEW[IPInterpreter.Rep -- _ [stream: stream] --]; impl: MasterImpl ~ NEW[MasterImplRep _ [skeleton: skeleton, interpreter: self]]; master: Master ~ NEW[MasterRep _ [pages: skeleton.topBlock.totalPlates, impl: impl]]; self.buffer _ NEW[TEXT[200]]; self.stackArray _ NEW[IPInterpreter.StackArrayRep _ ALL[[zero[]]]]; self.stackCountMax _ IPExecute.defaultMaxStackLength; <> <> RETURN[master]; }; BlockForPage: PROC [skeleton: IPMaster.Skeleton, page: INT] RETURNS [block: Block] ~ { FindBlock: PROC [block: Block, page: INT] RETURNS [blockFound: Block _ NIL] ~ { currentPage: INT _ block.startingPlateNumber+1; IF block.startingPlateNumber > page-1 THEN ERROR; IF block.startingPlateNumber+block.totalPlates < page THEN RETURN; <> FOR i: NAT IN [0..block.size) DO node: Node = block[i]; WITH node SELECT FROM node: REF NodeRep.body => IF currentPage = page THEN RETURN [block] ELSE currentPage _ currentPage+1; node: REF NodeRep.block => IF (blockFound _ FindBlock[node.block, page]) # NIL THEN RETURN ELSE currentPage _ currentPage+node.block.totalPlates; ENDCASE => ERROR; ENDLOOP; ERROR; -- Should never get here }; RETURN [FindBlock[block: skeleton.topBlock, page: page]] }; NodeForPage: PROC [block: Block, page: INT] RETURNS [node: Node] ~ { FindNode: PROC [block: Block, page: INT] RETURNS [nodeFound: Node _ NIL] ~ { currentPage: INT _ block.startingPlateNumber+1; IF block.startingPlateNumber > page-1 THEN ERROR; IF block.startingPlateNumber+block.totalPlates < page THEN RETURN; <> FOR i: NAT IN [0..block.size) DO node: Node = block[i]; WITH node SELECT FROM node: REF NodeRep.body => IF currentPage = page THEN RETURN [node] ELSE currentPage _ currentPage+1; node: REF NodeRep.block => IF (nodeFound _ FindNode[node.block, page]) # NIL THEN RETURN ELSE currentPage _ currentPage+node.block.totalPlates; ENDCASE => ERROR; ENDLOOP; ERROR; -- Should never get here }; RETURN [FindNode[block: block, page: page]] }; DoPage: PUBLIC PROC [master: Master, page: INT, context: Imager.Context, log: LogProc, copy: INT _ 1] ~ { IF page IN[1..master.pages] THEN { impl: MasterImpl ~ master.impl; block: Block ~ BlockForPage[impl.skeleton, page]; node: Node ~ NodeForPage[block, page]; self: IPInterpreter.Ref ~ impl.interpreter; action: PROC ~ { CallNode[self: self, node: node, frame: self.topFrame, env: self.topEnv] }; self.imager _ context; self.topFrame _ block.preamble.initialFrame; self.topEnv _ block.preamble.environment; DoTopAction[self, action, log]; self.imager _ NIL}; }; Close: PUBLIC PROC [master: Master] ~ { <> }; }. <<>> <> <> <<};>> <<>> <> <> <> <<};>> <<>> <> <> <> <> <> <> <> <> <1 DO Apply[self, $mergeprop] ENDLOOP;>> <> <<};>> <<};>> <<>> <> <> <> <<>> <> < CONTINUE];>> <> <<>> <> <<>> <> <> <> <> <> <> <> <<};>> <<>>