<> <> <> DIRECTORY FS, SymTab, PrePressFontFormat, Rope, RefText, List, PrincOpsUtils, Basics, IO, RopeFile, Atom; FontDictImpl: CEDAR PROGRAM IMPORTS FS, SymTab, PrePressFontFormat, Rope, RefText, List, PrincOpsUtils, IO, RopeFile, Atom ~ BEGIN BYTE: TYPE ~ Basics.BYTE; ROPE: TYPE ~ Rope.ROPE; LORA: TYPE ~ LIST OF REF; MalformedCDFont: ERROR ~ CODE; FabricateName: PROC [rope: ROPE] RETURNS [ROPE] ~ { cp: FS.ComponentPositions; fullFName: ROPE; [fullFName, cp] _ FS.ExpandName[rope]; RETURN [Rope.Concat[Rope.Substr[fullFName, cp.base.start, cp.base.length], ".cdtxt"]] }; Assert: PROC [truth: BOOL] ~ --INLINE-- { IF NOT truth THEN ERROR MalformedCDFont }; Bytes: PROC [wordSize: NAT] RETURNS [CARDINAL] ~ --INLINE-- {RETURN [wordSize*2]}; check: [2..2] ~ Basics.bytesPerWord; <> FileBytes: PROC [fileWords: INT] RETURNS [INT] ~ --INLINE-- {RETURN [fileWords*2]}; <> RawFetch: UNSAFE PROC [base: ROPE, byteOffset: INT, destination: LONG POINTER, nBytes: NAT] ~ UNCHECKED { buf: REF TEXT ~ RefText.ObtainScratch[nBytes]; Assert[(byteOffset + nBytes) <= Rope.Size[base]]; [] _ Rope.AppendChars[buffer: buf, rope: base, start: byteOffset, len: nBytes]; PrincOpsUtils.LongCopy[from: LOOPHOLE[buf, LONG POINTER]+SIZE[TEXT[0]], nwords: (nBytes+(Basics.bytesPerWord-1))/Basics.bytesPerWord, to: destination]; RefText.ReleaseScratch[buf]; }; rawOptions: FS.StreamOptions ~ [tiogaRead: FALSE, commitAndReopenTransOnFlush: TRUE, truncatePagesOnClose: TRUE, finishTransOnClose: TRUE, closeFSOpenFileOnClose: TRUE]; Int: PROC [i: CARDINAL] RETURNS [REF] ~ {RETURN [NEW[INT _ i]]}; DCard: PROC [i: PrePressFontFormat.BcplCard] RETURNS [REF] ~ {RETURN [NEW[INT _ PrePressFontFormat.CardFromBcpl[i]]]}; AnalyseFontDictionary: PROC [dictionaryFileName: ROPE] RETURNS [LORA] ~ { file: FS.OpenFile ~ FS.Open[name: dictionaryFileName, lock: read]; fullFName: ROPE ~ FS.GetName[file].fullFName; stream: IO.STREAM ~ FS.StreamFromOpenFile[openFile: file, streamOptions: rawOptions]; base: ROPE ~ RopeFile.FromStream[stream]; RETURN [AnalyseFontDictionaryRope[base, fullFName]]; }; AnalyseFontDictionaryRope: PROC [base: ROPE, fullFName: ROPE] RETURNS [LORA] ~ { names: ARRAY BYTE OF ATOM _ ALL[NIL]; head: LORA ~ LIST[NIL]; tail: LORA _ head; Append: PROC [ref: REF] ~ { tail.rest _ LIST[ref]; tail _ tail.rest; }; byteOffset: INT _ 0; DO -- read the index part to get all the name codes ix: PrePressFontFormat.IXHeader; headerBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.IXHeader]]; TRUSTED { RawFetch[base, byteOffset, @ix, headerBytes] }; SELECT ix.type FROM end => EXIT; name => { name: PrePressFontFormat.NameIndexEntry; nameBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.NameIndexEntry]]; Assert[FileBytes[ix.length] = headerBytes + nameBytes]; TRUSTED { RawFetch[base, byteOffset+headerBytes, @name, nameBytes] }; IF name.code IN BYTE THEN { Assert[names[name.code] = NIL]; names[name.code] _ Atom.MakeAtom[Rope.Substr[base, byteOffset+headerBytes+3, name.chars[0]]]; }; }; ENDCASE => NULL; byteOffset _ byteOffset + FileBytes[ix.length]; ENDLOOP; byteOffset _ 0; DO -- read the index part to get everything else of interest ix: PrePressFontFormat.IXHeader; headerBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.IXHeader]]; TRUSTED { RawFetch[base, byteOffset, @ix, headerBytes] }; SELECT ix.type FROM end => EXIT; name => NULL; spline, width => { index: PrePressFontFormat.StdIndexEntry; sdixBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.StdIndexEntry]]; Assert[FileBytes[ix.length] = headerBytes + sdixBytes]; TRUSTED { RawFetch[base, byteOffset+headerBytes, @index, sdixBytes] }; Assert[index.bc <= index.ec]; Append[LIST[ LIST[$Family, names[index.family]], LIST[$Face, Int[index.face]], LIST[$Size, Int[index.size]], LIST[$Type, IF ix.type = spline THEN $sd ELSE $wd], LIST[$Range, Int[index.bc], Int[index.ec]], LIST[$Rotation, Int[index.rotation]], LIST[$Segment, DCard[index.segmentSA], DCard[index.segmentLength]], LIST[$File, fullFName] ]]; }; character, orbit => { index: PrePressFontFormat.CharacterIndexEntry; acixBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.CharacterIndexEntry]]; Assert[FileBytes[ix.length] = headerBytes + acixBytes]; TRUSTED { RawFetch[base, byteOffset+headerBytes, @index, acixBytes] }; Assert[index.bc <= index.ec]; Append[LIST[ LIST[$Family, names[index.family]], LIST[$Face, Int[index.face]], LIST[$Size, Int[index.size]], LIST[$Type, IF ix.type = character THEN $ac ELSE $oc], LIST[$Range, Int[index.bc], Int[index.ec]], LIST[$Rotation, Int[index.rotation]], LIST[$ResolutionX, Int[index.resolutionX]], LIST[$ResolutionY, Int[index.resolutionY]], LIST[$Segment, DCard[index.segmentSA], DCard[index.segmentLength]], LIST[$File, fullFName] ]]; }; multipleCharacter => { index: PrePressFontFormat.MultipleCharacterIndexEntry; mcixBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.MultipleCharacterIndexEntry]]; segList: LORA _ NIL; Assert[FileBytes[ix.length] = headerBytes + mcixBytes]; TRUSTED { RawFetch[base, byteOffset+headerBytes, @index, mcixBytes] }; Assert[index.bc <= index.ec]; FOR i: CARDINAL IN [0..index.numSegs) DO dse: PrePressFontFormat.DatedSegmentEntry; dseBytes: INT ~ Bytes[SIZE[PrePressFontFormat.DatedSegmentEntry]]; TRUSTED { RawFetch[base, byteOffset+headerBytes+mcixBytes+i*dseBytes, @dse, dseBytes] }; segList _ CONS[LIST[DCard[dse.segmentSA], DCard[dse.segmentLength], DCard[dse.expirationDate]], segList] ENDLOOP; segList _ List.DReverse[segList]; Append[LIST[ LIST[$Family, names[index.family]], LIST[$Face, Int[index.face]], LIST[$Size, Int[index.size]], LIST[$Type, $mc], LIST[$Range, Int[index.bc], Int[index.ec]], LIST[$Rotation, Int[index.rotation]], LIST[$ResolutionX, Int[index.resolutionX]], LIST[$ResolutionY, Int[index.resolutionY]], CONS[$Segments, segList], LIST[$File, fullFName] ]]; }; ENDCASE => ERROR MalformedCDFont; byteOffset _ byteOffset + FileBytes[ix.length]; ENDLOOP; RETURN [head.rest]; }; Get: PROC [list: LORA, key: ATOM] RETURNS [LORA] ~ { FOR each: LORA _ list, each.rest UNTIL each = NIL DO WITH each.first SELECT FROM lora: LORA => IF lora.first = key THEN RETURN [lora.rest]; ENDCASE => NULL; ENDLOOP; RETURN [NIL] }; Ith: PROC [list: LORA, i: INT] RETURNS [INT] ~ { WHILE list # NIL AND i > 0 DO list _ list.rest; i _ i-1 ENDLOOP; IF i = 0 AND list # NIL THEN WITH list.first SELECT FROM int: REF INT => RETURN [int^] ENDCASE => NULL; RETURN [FIRST[INT]] }; ValidSegment: PROC [list: LORA, type: ATOM, bc, ec, segmentSA, segmentLength: INT] RETURNS [BOOL] ~ { FOR p: LORA _ list, p.rest UNTIL p = NIL DO WITH p.first SELECT FROM lora: LORA => { range: LORA ~ Get[lora, $Range]; segment: LORA ~ Get[lora, $Segment]; typeList: LORA ~ Get[lora, $Type]; IF typeList # NIL AND typeList.first = type AND bc = Ith[range, 0] AND ec = Ith[range, 1] AND segmentSA = Ith[segment, 0] AND segmentLength = Ith[segment, 1] THEN RETURN [TRUE]; }; ENDCASE => NULL; ENDLOOP; RETURN [FALSE] }; SymTabEntryRep: TYPE ~ RECORD [rope: ROPE, directoryInfo: LORA]; RopeForFile: PROC [ropeForFile: SymTab.Ref, fullFName: ROPE, type: ATOM, bc, ec: BYTE, segmentSA, segmentLength: INT] RETURNS [rope: ROPE] ~ { entry: REF SymTabEntryRep _ NIL; WITH SymTab.Fetch[x: ropeForFile, key: fullFName].val SELECT FROM e: REF SymTabEntryRep => entry _ e; ENDCASE => { rope _ RopeFile.Create[fullFName]; entry _ NEW[SymTabEntryRep _ [rope: rope, directoryInfo: AnalyseFontDictionaryRope[rope, fullFName]]]; [] _ SymTab.Store[x: ropeForFile, key: fullFName, val: entry]; }; IF NOT ValidSegment[list: entry.directoryInfo, type: type, bc: bc, ec: ec, segmentSA: segmentSA, segmentLength: segmentLength] THEN ERROR; rope _ Rope.Substr[base: entry.rope, start: 2*segmentSA, len: 2*segmentLength]; }; EncodeEntry: PROC [textBuf: REF TEXT, entry: LORA, segmentBase: INT, families: REF ARRAY BYTE OF ATOM, ropeForFile: SymTab.Ref] RETURNS [newBuf: REF TEXT, segment: ROPE _ NIL] ~ { type: ATOM _ NIL; family: ATOM _ NIL; familyCode: BYTE _ 0; face: BYTE _ 0; bc: BYTE _ LAST[BYTE]; ec: BYTE _ 0; size: INT _ 0; rotation: INT _ 0; resolutionX: INT _ 0; resolutionY: INT _ 0; segmentSA: INT _ 0; segmentLength: INT _ 0; check: INT _ 0; file: ROPE _ NIL; newBuf _ textBuf; newBuf.length _ 0; FOR each: LORA _ entry, each.rest UNTIL each = NIL DO item: LIST OF REF ~ NARROW[each.first]; SELECT item.first FROM $Type => type _ NARROW[item.rest.first]; $Family => family _ NARROW[item.rest.first]; $Face => face _ Ith[item.rest, 0]; $Range => { bc _ Ith[item.rest, 0]; ec _ Ith[item.rest, 1] }; $Size => size _ Ith[item.rest, 0]; $Rotation => rotation _ Ith[item.rest, 0]; $ResolutionX => resolutionX _ Ith[item.rest, 0]; $ResolutionY => resolutionY _ Ith[item.rest, 0]; $Segment => { segmentSA _ Ith[item.rest, 0]; segmentLength _ Ith[item.rest, 1] }; $Segments => NULL; $File => file _ NARROW[item.rest.first]; ENDCASE => ERROR; ENDLOOP; IF bc > ec OR size < 0 OR family = NIL OR file = NIL THEN ERROR; FOR f: BYTE IN BYTE DO IF families[f] = family THEN {familyCode _ f; EXIT}; ENDLOOP; SELECT type FROM $sd, $wd => { headerBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.IXHeader]]; indexBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.StdIndexEntry]]; ixHeader: PrePressFontFormat.IXHeader _ [type: IF type = $sd THEN spline ELSE width, length: (headerBytes+indexBytes)/2]; index: PrePressFontFormat.StdIndexEntry _ [ family: familyCode, face: face, bc: bc, ec: ec, size: size, rotation: rotation, segmentSA: PrePressFontFormat.BcplFromCard[segmentBase], segmentLength: PrePressFontFormat.BcplFromCard[segmentLength] ]; TRUSTED {newBuf _ RawAppend[newBuf, @ixHeader, headerBytes]}; TRUSTED {newBuf _ RawAppend[newBuf, @index, indexBytes]}; }; $ac, $oc => { headerBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.IXHeader]]; indexBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.CharacterIndexEntry]]; ixHeader: PrePressFontFormat.IXHeader _ [type: IF type = $ac THEN character ELSE orbit, length: (headerBytes+indexBytes)/2]; index: PrePressFontFormat.CharacterIndexEntry _ [ family: familyCode, face: face, bc: bc, ec: ec, size: size, rotation: rotation, segmentSA: PrePressFontFormat.BcplFromCard[segmentBase], segmentLength: PrePressFontFormat.BcplFromCard[segmentLength], resolutionX: resolutionX, resolutionY: resolutionY ]; TRUSTED {newBuf _ RawAppend[newBuf, @ixHeader, headerBytes]}; TRUSTED {newBuf _ RawAppend[newBuf, @index, indexBytes]}; }; $mc => NULL; -- unimplemented ENDCASE => ERROR; segment _ RopeForFile[ropeForFile: ropeForFile, fullFName: file, type: type, bc: bc, ec: ec, segmentSA: segmentSA, segmentLength: segmentLength]; }; RawAppend: UNSAFE PROC [textBuf: REF TEXT, pointer: LONG POINTER, byteCount: NAT] RETURNS [REF TEXT] ~ UNCHECKED { p: LONG POINTER TO Basics.RawBytes ~ pointer; start: NAT ~ textBuf.length; textBuf _ RefText.ReserveChars[textBuf, byteCount]; FOR i: NAT IN [0..byteCount) DO textBuf[start+i] _ VAL[p[i]]; ENDLOOP; textBuf.length _ start+byteCount; RETURN [textBuf]; }; EncodeNameEntry: PROC [textBuf: REF TEXT, code: BYTE, family: ATOM] RETURNS [newBuf: REF TEXT] ~ { headerBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.IXHeader]]; indexBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.NameIndexEntry]]; ixHeader: PrePressFontFormat.IXHeader _ [type: name, length: (headerBytes+indexBytes)/2]; index: PrePressFontFormat.NameIndexEntry _ [code: code, chars: ALL[0]]; action: Rope.ActionType ~ { <<[c: CHAR] RETURNS [quit: BOOL _ FALSE]>> index.chars[index.chars[0] _ index.chars[0] + 1] _ ORD[c]; RETURN [quit: FALSE] }; newBuf _ textBuf; newBuf.length _ 0; [] _ Rope.Map[base: Atom.GetPName[family], action: action]; TRUSTED {newBuf _ RawAppend[newBuf, @ixHeader, headerBytes]}; TRUSTED {newBuf _ RawAppend[newBuf, @index, indexBytes]}; }; AssembleFontDictionary: PROC [list: LORA] RETURNS [rope: ROPE _ NIL] ~ { ropeForFile: SymTab.Ref ~ SymTab.Create[case: FALSE]; families: REF ARRAY BYTE OF ATOM _ NEW[ARRAY BYTE OF ATOM _ ALL[NIL]]; lc: INT _ 0; textBuf: REF TEXT _ NEW[TEXT[100]]; segments: ROPE _ NIL; FOR each: LORA _ list, each.rest UNTIL each = NIL DO <> entry: LORA ~ NARROW[each.first]; name: ATOM ~ NARROW[Get[entry, $Family].first]; FOR f: BYTE IN BYTE DO IF families[f] = NIL THEN {families[f] _ name; EXIT}; IF families[f] = name THEN {EXIT}; IF f = LAST[BYTE] THEN ERROR; ENDLOOP; ENDLOOP; FOR f: BYTE IN BYTE DO <> IF families[f] = NIL THEN EXIT; textBuf _ EncodeNameEntry[textBuf, f, families[f]]; rope _ Rope.Concat[rope, Rope.FromRefText[textBuf]]; lc _ lc + textBuf.length/2; ENDLOOP; FOR each: LORA _ list, each.rest UNTIL each = NIL DO <> entry: LORA ~ NARROW[each.first]; segment: ROPE; [textBuf, segment] _ EncodeEntry[textBuf, entry, 0, families, ropeForFile]; lc _ lc + textBuf.length/2; ENDLOOP; lc _ lc + Bytes[SIZE[PrePressFontFormat.IXHeader]]/2; FOR each: LORA _ list, each.rest UNTIL each = NIL DO <> entry: LORA ~ NARROW[each.first]; segment: ROPE; [textBuf, segment] _ EncodeEntry[textBuf, entry, lc, families, ropeForFile]; rope _ Rope.Concat[rope, Rope.FromRefText[textBuf]]; segments _ Rope.Concat[segments, segment]; lc _ lc + Rope.Size[segment]/2; ENDLOOP; TRUSTED { <> headerBytes: NAT ~ Bytes[SIZE[PrePressFontFormat.IXHeader]]; ixHeader: PrePressFontFormat.IXHeader _ [type: end, length: (headerBytes)/2]; textBuf.length _ 0; textBuf _ RawAppend[textBuf, @ixHeader, headerBytes]; rope _ Rope.Concat[rope, Rope.FromRefText[textBuf]]; }; rope _ Rope.Concat[rope, segments]; IF Rope.Size[rope] # lc*2 THEN ERROR; }; WriteFontDictionary: PROC [list: LORA, fileName: ROPE] RETURNS [written: ROPE] ~ { rope: ROPE ~ AssembleFontDictionary[list]; stream: IO.STREAM ~ FS.StreamOpen[fileName: fileName, accessOptions: $create]; IO.PutRope[stream, rope]; written _ FS.GetName[FS.OpenFileFromStream[stream]].fullFName; IO.Close[stream]; }; WriteLORA: PROC [fileName: ROPE, list: LORA] RETURNS [written: ROPE] ~ { stream: IO.STREAM ~ FS.StreamOpen[fileName: fileName, accessOptions: $create]; WriteLORAToStream[stream, list]; written _ FS.GetName[FS.OpenFileFromStream[stream]].fullFName; IO.Close[stream]; }; ReadLORA: PROC [fileName: ROPE] RETURNS [LORA] ~ { stream: IO.STREAM ~ FS.StreamOpen[fileName: fileName, accessOptions: $read]; lora: LORA ~ ReadLORAFromStream[stream]; IO.Close[stream]; RETURN [lora] }; BoundedCount: PROC [list: LORA, limit: INT] RETURNS [INT] ~ { count: INT _ 0; UNTIL limit = 0 OR list = NIL DO sub: INT ~ WITH list.first SELECT FROM lora: LORA => BoundedCount[lora, limit], ENDCASE => 1; count _ count + sub; limit _ limit - sub; list _ list.rest; ENDLOOP; RETURN [count] }; maxPerLine: INT _ 6; WriteLORAToStream: PROC [stream: IO.STREAM, list: LORA, nest: INT _ 0] ~ { IF BoundedCount[list, maxPerLine] < maxPerLine THEN { IO.PutChar[stream, '(]; FOR each: LORA _ list, each.rest UNTIL each = NIL DO IF each # list THEN IO.PutChar[stream, ' ]; WITH each.first SELECT FROM lora: LORA => WriteLORAToStream[stream, lora, nest]; ENDCASE => IO.PutF[stream, "%g", IO.refAny[each.first]]; ENDLOOP; IO.PutChar[stream, ')]; } ELSE { IO.PutChar[stream, '(]; IO.PutChar[stream, '\n]; nest _ nest + 1; FOR i: INT IN [0..nest) DO IO.PutChar[stream, '\t] ENDLOOP; FOR each: LORA _ list, each.rest UNTIL each = NIL DO WITH each.first SELECT FROM lora: LORA => WriteLORAToStream[stream, lora, nest]; ENDCASE => IO.PutF[stream, "%g", IO.refAny[each.first]]; IO.PutChar[stream, '\n]; FOR i: INT IN [0..nest) DO IO.PutChar[stream, '\t] ENDLOOP; ENDLOOP; IO.PutChar[stream, ')]; nest _ nest - 1; }; }; ReadLORAFromStream: PROC [stream: IO.STREAM] RETURNS [LORA] ~ { ref: REF ~ IO.GetRefAny[stream]; WITH ref SELECT FROM lora: LORA => RETURN [lora]; ENDCASE => RETURN [NIL]; }; END.