// bcpl/f PressEditFonts.bcpl -- merge, page edit press files // Copyright Xerox Corporation 1979, 1980, 1981, 1982 // Last modified by Lyle Ramshaw on January 13, 1982 4:02 PM // Last modified by Lyle Ramshaw on January 14, 1981 10:53 AM // Last modified by RML on August 5, 1980 4:45 PM // renamed 1.83 get "presseditdefs.bcpl" get "streams.d" // outgoing procedures external [ AddExtraFonts AddExtraFont FindFamily InitializeFonts LookupFamily MakeFontEntry MatchFontSets PrintFontSets ReadFontNames ReadPressFontDir ScanFontSets ] // incoming procedures external [ BlankSet CheckFontEntry CompareSets DecodeFontName EqStr Error Gets GetFixed max MoveBlock OpenFile Puts ReadBlock SetInFile WFACE Wns Ws Wl Zero ] // incoming statics external [ Debug DocDirList docMergePtrs DLByteCount dsp efCount efScratch // dump of external files EntVec EntByteCount ExtraFonts FamilyDir FileNames FontSets FontVec FontVecPtr illusMergePtrs InputStream InputByteStream MaxSet Merge mergeList mergePtr NFamilies NFontEntries NPages NFiles nIllus NRects OutPartDir OutDocDir OutputFileName PageList PageDir PageDirFile pageNoStart pageNoX pageNoY pageNoOmit PrivateStamp RectangleVec SetMaps SetMapPtr SetMapTable TempSets TLvec XFonts ] let ReadFontNames(fd) be [ Zero(fd, MaxFamilies*FamilyLen) // zero it out NFamilies=0 //so far ] and FindFamily(s) = valof [ for i=0 to NFamilies-1 do if FamilyDir!(i*FamilyLen) ne 0 then if EqStr(s,FamilyDir+i*FamilyLen) then resultis i if NFamilies ge MaxFamilies then Error("Too many font family names") let curFams=NFamilies MoveBlock(FamilyDir+curFams*FamilyLen,s,FamilyLen) NFamilies=curFams+1 resultis curFams ] // check validity of all files, Press or Ears // read Press font directory // SetMapTable contains one ptr per file, pointing into SetMaps // ptr is zero if no mapping needed // in SetMaps is set of new font set nos (ddv>>DD.nsets entries) // FontSets contains up to 64 lists of 16 pointers to FONT entries // FONT entries are stored in FontVec // while assembling sets for one file, use TempSets and InitializeFonts() be [ FontVecPtr=FontVec Zero(FontSets, 1024) MaxSet=-1 SetMapPtr=SetMaps ] and ReadPressFontDir(s,fn) be [ let ddv=DocDirList+fn*DDlen SetInFile(s,ddv,ddv>>DD.fdstart,0) let evec=vec FElen-1 // vector for entry Zero(TempSets, 1024) let maxfontset=0 [ ReadBlock(s, evec, FElen) // read it if evec>>FE.length eq 0 then break CheckFontEntry(evec) let fp=MakeFontEntry(evec,FontVecPtr) if fp eq FontVecPtr then FontVecPtr=FontVecPtr+FONTlen if FontVecPtr-FontVec ge FONTlen*MaxFonts then Error("too many different fonts") TempSets!(16*evec>>FE.set+evec>>FE.fno)=fp maxfontset=max(maxfontset,evec>>FE.set) ] repeat MatchFontSets(fn,maxfontset) ] and MatchFontSets(fn,maxfontset) be [ SetMapTable!fn=SetMapPtr let mapsame=true for i=0 to maxfontset do [ SetMapPtr!i=-1 // in case blank set let tp=TempSets+16*i unless BlankSet(tp) then [ let s=ScanFontSets(tp) SetMapPtr!i=s if s ne i then mapsame=false // need map ] ] test mapsame ifso SetMapTable!fn=0 ifnot SetMapPtr=SetMapPtr+maxfontset+1 (DocDirList+fn*DDlen)>>DD.nsets=maxfontset+1 ] // returns font set no, makes new entry if necessary and ScanFontSets(tp) = valof [ for j=0 to MaxSet do [ let fp=FontSets+16*j unless BlankSet(fp) then [ switchon CompareSets(fp,tp) into [ case 0: case 1: resultis j case 2: // old is subset of new MoveBlock(fp, tp, 16) resultis j case 3: // combine them for i=0 to 15 do if fp!i eq 0 then fp!i=tp!i resultis j default: endcase // not same ] ] ] MaxSet=MaxSet+1 MoveBlock(FontSets+16*MaxSet, tp, 16) resultis MaxSet ] // find entry matching this font, or make new entry // returns pointer to entry and MakeFontEntry(ev,fp) = valof [ let fam=FindFamily(lv ev>>FE.fam) fp>>FONT.family=fam fp>>FONT.face=ev>>FE.face fp>>FONT.ptsize=ev>>FE.siz fp>>FONT.rotn=ev>>FE.rotn fp>>FONT.earsfont=false // in all new entries let p=FontVec until (p!0 & #77777) eq (fp!0 & #77777) & (p>>FONT.face eq fp>>FONT.face) & (p>>FONT.ptsize eq fp>>FONT.ptsize) & (p>>FONT.rotn eq fp>>FONT.rotn) do p=p+FONTlen resultis p // points to new entry ] and PrintFontSets() be [ Wl("Font sets:") for s=0 to MaxSet do [ let blankfont=true let p=FontSets+16*s Wns(dsp, s); Ws(": ") for j=0 to 15 do if p!j ne 0 then [ let fp=p!j Ws(FamilyDir+(fp>>FONT.family)*FamilyLen) Wns(dsp, fp>>FONT.ptsize) WFACE(fp>>FONT.face) unless fp>>FONT.rotn eq 0 do [ Puts(dsp, $() Wns(dsp, fp>>FONT.rotn) Puts(dsp, $)) ] Puts(dsp, $(); Wns(dsp, j); Ws(") ") blankfont=false ] if blankfont then Ws(" not used") Puts(dsp, $*n) ] ] and AddExtraFonts() be [ for i=0 to XFonts-1 do [ let s=ExtraFonts!i DecodeFontName(s,FontVecPtr) let p=FontVec until p!0 eq FontVecPtr!0 & (p>>FONT.face eq FontVecPtr>>FONT.face) & (p>>FONT.ptsize eq FontVecPtr>>FONT.ptsize) do p=p+FONTlen if p eq FontVecPtr then [ FontVecPtr=FontVecPtr+FONTlen if FontVecPtr-FontVec ge FONTlen*MaxFonts then Error("too many different fonts") AddExtraFont(p) ] ] NFontEntries=(FontVecPtr-FontVec)/FONTlen ] and AddExtraFont(fp) be [ for fn=0 to MaxSet do [ let p=FontSets+16*fn unless BlankSet(p) then for i=0 to 15 do if p!i eq 0 then [ p!i=fp return ] ] MaxSet=MaxSet+1 if MaxSet gr 63 then Error("too many font sets") FontSets!(16*MaxSet)=fp // start new set with this one ]