~
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;
Dragon conversion note; the construct Bytes[SIZE[type]] should be changed to work properly for 32-bit machines. We can get by with this here because the press font formats are all based on 16-bit words.
FileBytes:
PROC [fileWords:
INT]
RETURNS [
INT] ~
--INLINE-- {
RETURN [fileWords*2]};
FileBytes is used to convert a count of 16-bit words into bytes. This does not change even if the machine's word size is other than 16;
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
Collect up all the family names and assign codes
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
Emit all the family codes
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
Count up the total entry sizes
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
Emit all the entries, concatenate the segments
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 {
Emit the index end entry.
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];
};