<> <> <> <> DIRECTORY Atom USING [MakeAtomFromRefText], FS, Imager USING [Context, ShowText], ImagerFont USING [MapText, XStringProc], Interpress USING [AddMaster, LogProc, OpenMaster, OpenMasterRep], IO, IPInterpreter USING [Apply, Call, Context, Count, DoSaveAll, Env, Frame, Identifier, IdentifierRep, Integer, Mark, Marker, MasterError, MasterWarning, NoPool, Operator, OperatorClass, OperatorClassRep, OperatorRep, Pool, PopToActiveMark, PopVector, PushIdentifier, PushNum, PushVector, Ref, Rep, StackArrayRep, topFrameSize, Unmark, Vector, VectorFromBits, VectorFromBytes, VectorFromString, ZeroVec], IPMaster USING [Block, Body, BodyRep, BYTE, GetHeader, GetSkeleton, GetToken, IntFromSequenceData, Node, NodeRep, RealFromSequenceData, SequenceType, Skeleton, SkipBytes, SkipToEndOfBody, Token], RefText USING [ReserveChars], RopeFile, Rope; IPExecImpl: CEDAR PROGRAM IMPORTS Atom, FS, IO, Imager, ImagerFont, Interpress, IPInterpreter, IPMaster, RefText, Rope, RopeFile EXPORTS Interpress, IPInterpreter ~ BEGIN OPEN IPInterpreter, IPMaster; 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; Run: TYPE ~ RECORD[start, len: INT]; RunList: TYPE ~ LIST OF Run; DoString: PROC [self: Ref, text: REF TEXT] ~ { string: ImagerFont.XStringProc ~ { ImagerFont.MapText[text: text, charAction: charAction] }; PushVector[self, VectorFromString[string]]; }; DoIdentifier: PROC [self: Ref, text: REF TEXT] ~ { len: NAT ~ text.length; id: Identifier ~ NEW[IdentifierRep _ [atom: NIL, rope: NIL]]; warn: BOOL _ FALSE; id.rope _ Rope.FromRefText[text]; -- before conversion to lower case FOR i: NAT IN[0..len) DO char: CHAR ~ text[i]; SELECT char FROM IN['a..'z] => NULL; IN['A..'Z] => text[i] _ char+('a-'A); -- force lower case IN['0..'9], '- => IF i=0 THEN warn _ TRUE; ENDCASE => warn _ TRUE; ENDLOOP; IF len=0 THEN warn _ TRUE; id.atom _ Atom.MakeAtomFromRefText[text]; PushIdentifier[self, id]; IF warn THEN MasterWarning[$invalidEncoding, "Invalid Identifier"]; }; DoInteger: PROC [self: Ref, text: REF TEXT] ~ { len: NAT ~ text.length; IF len<=4 THEN { val: INT ~ IPMaster.IntFromSequenceData[text]; PushNum[self, [int[val]]]; } ELSE { val: REAL ~ IPMaster.RealFromSequenceData[text]; PushNum[self, [real[val]]]; }; }; DoRational: PROC [self: 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 PushNum[self, [rational[n: n, d: d]]] ELSE 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]; PushNum[self, [real[n/d]]]; }; IF (half+half)#len THEN MasterWarning[$invalidEncoding, IO.PutFR1["Invalid sequenceRational (length=%g)", IO.int[len]]]; }; DoInsertFile: PROC [self: Ref, text: REF TEXT] ~ { MasterWarning[$unimplemented, "Not implemented: sequenceInsertFile"]; }; 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]; }; OpenFileFromStream: PROC [stream: IO.STREAM] RETURNS [FS.OpenFile] ~ { openFile: FS.OpenFile _ FS.nullOpenFile; name: ROPE _ NIL; ok: BOOL _ TRUE; openFile _ FS.OpenFileFromStream[stream ! FS.Error, IO.Error => {ok _ FALSE; CONTINUE}]; <> name _ FS.GetName[openFile ! FS.Error => {ok _ FALSE; CONTINUE}].fullFName; IF ok THEN openFile _ FS.Open[ name: name, wantedCreatedTime: FS.GetInfo[openFile].created, remoteCheck: FALSE ! FS.Error => {ok _ FALSE; CONTINUE} ]; RETURN [IF ok THEN openFile ELSE FS.nullOpenFile] }; smallish: INT _ 30000; maxChunkSize: INT ~ LAST[NAT]-SIZE[TEXT[0]]*2-4; maxRopeStreams: NAT ~ 4; nRopeStreams: NAT _ 3; ropeBuffers: NAT _ 1; pagesPerFileBuffer: NAT _ 10; numberOfFilebuffers: NAT _ 2; ropeFileStreamOptions: FS.StreamOptions ~ [ tiogaRead: FALSE, commitAndReopenTransOnFlush: FALSE, truncatePagesOnClose: FALSE, finishTransOnClose: FALSE, closeFSOpenFileOnClose: FALSE ]; RopeFromRuns: PROC [stream: IO.STREAM, runs: LIST OF Run, sequenceLength: INT] RETURNS [rope: ROPE _ NIL] ~ { size: INT _ 0; openFile: FS.OpenFile ~ IF sequenceLength > smallish THEN OpenFileFromStream[stream] ELSE FS.nullOpenFile; IF openFile # FS.nullOpenFile THEN { <> ropes: ARRAY [0..maxRopeStreams) OF ROPE _ ALL[NIL]; FOR i: NAT IN [0..nRopeStreams) DO ropeFile: ROPE ~ RopeFile.FromStream[stream: FS.StreamFromOpenFile[openFile: openFile, streamOptions: ropeFileStreamOptions, streamBufferParms: [vmPagesPerBuffer: pagesPerFileBuffer, nBuffers: numberOfFilebuffers]], buffers: ropeBuffers]; t: ROPE _ NIL; size _ 0; FOR r: LIST OF Run _ runs, r.rest UNTIL r = NIL DO run: Run ~ r.first; t _ Rope.Concat[t, Rope.Substr[ropeFile, run.start, run.len]]; size _ size + run.len; ENDLOOP; ropes[i] _ t; ENDLOOP; FOR i: NAT IN [0..nRopeStreams) DO start: INT ~ size*i/nRopeStreams; end: INT ~ size*(i+1)/nRopeStreams; rope _ Rope.Concat[rope, Rope.Substr[ropes[i], start, end-start]]; ENDLOOP; } ELSE { saveIndex: INT ~ IO.GetIndex[stream]; FOR r: LIST OF Run _ runs, r.rest UNTIL r = NIL DO run: Run _ r.first; UNTIL run.len = 0 DO chunkSize: NAT ~ MIN[run.len, maxChunkSize]; text: Rope.Text ~ Rope.NewText[chunkSize]; zero: [0..0]; IO.SetIndex[stream, run.start]; TRUSTED {zero _ IO.GetBlock[stream, LOOPHOLE[text], 0, chunkSize]-chunkSize}; rope _ Rope.Concat[rope, text]; size _ size + chunkSize; run.start _ run.start + chunkSize; run.len _ run.len - chunkSize; ENDLOOP; ENDLOOP; IO.SetIndex[stream, saveIndex]; }; IF Rope.Size[rope] # sequenceLength THEN ERROR; IF size # sequenceLength THEN ERROR; }; ExecuteToEndOfBody: PROC [self: Ref] ~ { stream: STREAM ~ self.stream; sequenceData: {nil, text, runs, skip} _ nil; sequenceType: SequenceType _ nil; sequenceLength: INT _ 0; sequenceRuns: INT _ 0; text: REF TEXT _ NIL; buffer: REF TEXT ~ self.buffer; runsHead, runsTail: LIST OF Run _ NIL; BeginSequence: PROC [seq: SequenceType] ~ { SELECT sequenceType _ seq FROM sequenceString, sequenceIdentifier, sequenceInsertFile, sequenceComment, sequenceInteger, sequenceRational, sequenceReal => 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"]; SkipBytes[stream, length]; }; text => { len: NAT ~ length; nBytesRead: NAT _ 0; IF (text.maxLength-text.length) { prevTail: LIST OF Run ~ runsTail; runsTail _ LIST[[start: IO.GetIndex[stream], len: length]]; IF prevTail=NIL THEN runsHead _ runsTail ELSE prevTail.rest _ runsTail; SkipBytes[stream, length]; }; skip => SkipBytes[stream, length]; ENDCASE => ERROR; sequenceRuns _ sequenceRuns+1; sequenceLength _ sequenceLength+length; }; FinishSequence: PROC ~ { SELECT sequenceType FROM sequenceString => DoString[self, text]; sequenceIdentifier => DoIdentifier[self, text]; sequenceInteger => DoInteger[self, text]; sequenceRational => DoRational[self, text]; sequenceInsertFile => DoInsertFile[self, text]; sequenceComment => NULL; sequenceLargeVector => { rope: ROPE ~ RopeFromRuns[self.stream, runsHead, sequenceLength]; b: NAT ~ Rope.Fetch[rope, 0]-'\000; vector: Vector ~ VectorFromBytes[bytes: Rope.Substr[rope, 1], bytesPerElement: b, signed: TRUE]; PushVector[self, vector]; }; sequencePackedPixelVector => { rope: ROPE ~ RopeFromRuns[self.stream, 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: Vector ~ VectorFromBits[bytes: Rope.Substr[rope, 4], dataBitsPerLine: dataBitsPerLine, padBitsPerLine: padBitsPerLine]; 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: Token ~ GetToken[stream: self.stream, flushComments: FALSE]; IF token.seq=sequenceContinued THEN { ExtendSequence[token.len]; LOOP }; self.context.token _ token; IF sequenceType=sequenceString AND self.showVec.font#NIL 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; LOOP }; }; IF sequenceData#nil THEN FinishSequence[]; IF token.op=endBody THEN EXIT; SELECT token.type FROM op => Apply[self, token.op]; num => PushNum[self, [int[token.num]]]; seq => { BeginSequence[token.seq]; ExtendSequence[token.len] }; ENDCASE => ERROR; ENDLOOP; }; BeginBody: PROC [self: Ref] RETURNS [INT] ~ { token: Token ~ IPMaster.GetToken[self.stream]; self.context.token _ token; IF NOT token.op=beginBody THEN MasterError[$missingBody, "Missing body"]; RETURN[token.index]; }; SkipInlineBody: PUBLIC PROC [self: Ref] ~ { index: INT ~ BeginBody[self]; IPMaster.SkipToEndOfBody[self.stream]; }; GetInlineBody: PUBLIC PROC [self: Ref] RETURNS [Body] ~ { start, stop: INT _ 0; start _ BeginBody[self]; IPMaster.SkipToEndOfBody[self.stream]; stop _ IO.GetIndex[self.stream]; RETURN[NEW[IPMaster.BodyRep _ [index: start, length: stop-start]]]; }; ExecuteInlineBody: PROC [self: Ref] ~ { index: INT ~ BeginBody[self]; DO error: BOOL _ FALSE; ExecuteToEndOfBody[self ! MarkRecovery => { error _ TRUE; CONTINUE }]; IF error THEN { -- do mark recovery marker: Marker ~ PopToActiveMark[self]; IF marker=self.context.marker THEN { IO.SetIndex[self.stream, self.context.token.index]; DO token: Token ~ IPMaster.GetToken[self.stream]; SELECT token.op FROM endBody => ERROR MarkRecovery; -- end of body beginBody => IPMaster.SkipToEndOfBody[self.stream]; -- skip body literal unmark0 => { IO.SetIndex[self.stream, token.index]; EXIT }; -- found UNMARK0 ENDCASE; IF token.type=seq THEN IPMaster.SkipBytes[self.stream, token.len]; ENDLOOP; } ELSE ERROR MarkRecovery; -- not this context's marker } ELSE EXIT; -- normal completion ENDLOOP; }; CallInlineBody: PUBLIC PROC [self: Ref, frame: Vector, pool: Pool, env: Vector] ~ { action: PROC ~ { ExecuteInlineBody[self] }; Call[self: self, action: action, frame: frame, pool: pool, env: env]; }; CallBody: PROC [self: Ref, body: Body, frame: Vector, pool: Pool, env: Vector] ~ { stream: STREAM ~ self.stream; next: INT ~ IO.GetIndex[stream]; IO.SetIndex[stream, body.index]; CallInlineBody[self: self, frame: frame, pool: pool, env: env ! UNWIND => IO.SetIndex[stream, next]]; IO.SetIndex[stream, next]; }; DoWithMarkProtection: PUBLIC PROC [self: Ref, action: PROC] ~ { error: BOOL _ FALSE; inner: PROC ~ { Mark[self, 0]; action[]; Unmark[self, 0] }; inner[! MarkRecovery => { error _ TRUE; CONTINUE}]; IF error THEN { -- do mark recovery marker: Marker ~ PopToActiveMark[self]; IF marker=self.context.marker THEN Unmark[self, 0] ELSE ERROR MarkRecovery; }; }; Do: PUBLIC PROC [self: Ref, op: Operator] ~ { op.class.do[op, self] }; composedClass: OperatorClass ~ NEW[OperatorClassRep _ [ type: $Composed, do: ComposedDo]]; ComposedData: TYPE ~ REF ComposedDataRep; ComposedDataRep: TYPE ~ RECORD[ frame: Vector, -- initial frame pool: Pool, -- shared pool env: Vector, -- environment body: Body -- body of the operator ]; ComposedDo: PROC [op: Operator, state: Ref] ~ { data: ComposedData ~ NARROW[op.data]; CallBody[self: state, body: data.body, frame: data.frame, pool: data.pool, env: data.env]; }; MakeCO: PUBLIC PROC [frame: Vector, pool: Pool, env: Vector, body: Body] RETURNS [Operator] ~ { data: ComposedData ~ NEW[ComposedDataRep _ [ frame: frame, pool: pool, env: env, body: body]]; RETURN[NEW[OperatorRep _ [class: composedClass, data: data]]]; }; compiledImageClass: OperatorClass ~ NEW[OperatorClassRep _ [ type: $CompiledImage, do: CompiledImageDo]]; CompiledImageData: TYPE ~ REF CompiledImageDataRep; CompiledImageDataRep: TYPE ~ RECORD[frame: Vector, env: Vector, body: Body]; CompiledImageDo: PROC [op: Operator, state: Ref] ~ { data: CompiledImageData ~ NARROW[op.data]; CallBody[self: state, body: data.body, frame: data.frame, pool: NoPool[], env: data.env]; }; MakeCompiledImage: PUBLIC PROC [frame: Vector, env: Vector, body: Body] RETURNS [Operator] ~ { data: CompiledImageData ~ NEW[CompiledImageDataRep _ [ frame: frame, env: env, body: body]]; RETURN[NEW[OperatorRep _ [class: compiledImageClass, data: data]]]; }; CallPreamble: PROC [self: Ref, node: Node, frame: Vector, env: Vector] ~ { WITH node SELECT FROM node: REF NodeRep.body => { preamble: PROC ~ { Mark[self, 0]; ExecuteInlineBody[self]; IF Count[self]<1 THEN PushVector[self, Env[self]]; IF Count[self]<2 THEN PushVector[self, Frame[self]]; Unmark[self, 2]; }; IO.SetIndex[self.stream, node.body.index]; Call[self: self, action: preamble, frame: frame, pool: NoPool[], env: env]; }; < {>> <> <> <<};>> ENDCASE => ERROR; }; CallNode: PROC [self: Ref, node: Node, frame: Vector, env: Vector] ~ { WITH node SELECT FROM node: REF NodeRep.body => { body: Body ~ node.body; IO.SetIndex[self.stream, body.index]; CallInlineBody[self: self, frame: frame, pool: NoPool[], env: env]; }; < {>> <> <> <> <> <> <> <> <> <<};>> ENDCASE => ERROR; }; emptyVec: Vector ~ ZeroVec[0]; topFrame: Vector ~ ZeroVec[topFrameSize]; topEnv: Vector ~ emptyVec; -- empty vector, for now OpenMaster: TYPE ~ Interpress.OpenMaster; OpenMasterRep: TYPE ~ Interpress.OpenMasterRep; OpenMasterImplRep: PUBLIC TYPE ~ IPInterpreter.Rep; -- exported to Interpress LogProc: TYPE ~ Interpress.LogProc; DoTopAction: PROC [master: OpenMaster, action: PROC] ~ { self: Ref ~ master.impl; protect: PROC ~ { DoWithMarkProtection[self, action] }; call: PROC ~ { Call[self, protect, emptyVec, NoPool[], emptyVec] }; save: PROC ~ { IF self.imager=NIL THEN call ELSE DoSaveAll[self, call] }; Interpress.AddMaster[master, save]; }; DoPreamble: PROC [master: OpenMaster] ~ { self: Ref ~ master.impl; block: Block ~ master.skeleton.topBlock; action: PROC ~ { CallPreamble[self: self, node: block.preamble, frame: topFrame, env: topEnv]; self.topFrame _ PopVector[self]; self.topEnv _ PopVector[self]; }; DoTopAction[master, action]; }; defaultMaxStackLength: Integer ~ 1000; Open: PUBLIC PROC [fileName: ROPE, logProc: LogProc, logData: REF _ NIL] RETURNS [OpenMaster] ~ { stream: STREAM ~ FS.StreamOpen[fileName]; RETURN [FromStream[stream, logProc, logData]]; }; FromStream: PUBLIC PROC [stream: STREAM, logProc: LogProc, logData: REF _ NIL] RETURNS [OpenMaster] ~ { restOfHeader: ROPE ~ IPMaster.GetHeader[stream, "Interpress/Xerox/"]; skeleton: IPMaster.Skeleton ~ IPMaster.GetSkeleton[stream]; self: Ref ~ NEW[Rep _ [stream: stream]]; master: OpenMaster ~ NEW[OpenMasterRep _ [ pages: skeleton.topBlock.size, skeleton: skeleton, logProc: logProc, logData: logData, impl: self]]; self.buffer _ NEW[TEXT[200]]; self.stackArray _ NEW[StackArrayRep _ ALL[[zero[]]]]; self.stackCountMax _ defaultMaxStackLength; <> DoPreamble[master]; RETURN[master]; }; DoPage: PUBLIC PROC [master: OpenMaster, page: INT, context: Imager.Context] ~ { IF page IN[1..master.pages] THEN { block: Block ~ master.skeleton.topBlock; node: Node ~ block[page-1]; self: Ref ~ master.impl; action: PROC ~ { CallNode[self: self, node: node, frame: self.topFrame, env: self.topEnv] }; self.imager _ context; DoTopAction[master, action]; self.imager _ NIL; }; }; END. <<>> <> <> <<};>> <<>> <> <> <> <<};>> <<>> <> <> <> <> <> <> <> <> <1 DO Apply[self, $mergeprop] ENDLOOP;>> <> <<};>> <<};>> <<>> <> <> <> <<>> <> < CONTINUE];>> <> <<>> <> <<>> <> <> <> <> <> <> <> <<};>> <<>>