// RSilPress.bcpl . Creates the PRESS file RSIL.PRESS
//C. Thacker modified on August 24, 1977 add option to send to the press printer
//R. Bates modified on February 15, 1978 to print color
//R. Bates modified on March 16, 1978 to put file name in Sil.Press+new time standard
//R. Bates modified on June 16, 1978 added font faces
//R. Bates modified on June 16, 1978 renamed program to SilToPress
//P. Lam modified on January 11, 1981
//added user defined xmargin , bottommargin , two fontsets & font rotations
get "sysdefs.d"
get "Sil.defs"
external [ PUTB ] //from this file
external MulDiv //from FontWidths.bcpl
manifest
[
//press commands:
SetX = #356
SetY = #357
ShowRectangle = #376
ShowCharacters = #360
Nop = #377
SetFont = #160
]
external
[
WSSB
UserName
DayTime; UNPACKDT; CONVUDT
dsp
]
external
[
CurrentPassNumber
@FontUsed
FontUsedTwo
FontSet
@FontNames
]
static
[
ncopies
PressS
@BackGndEn
@DoFnt15 = false
@ScanCvrt = false
@fheight
@fontsel
@EntityBytesSent
@FirstDLByte
@DLBytesSent
@ByteCarry =0
@PartDir
@PDptr
@BytesOut = 0
@CurrentRecord = 0
@Nparts = 0
@FontNames
@FontUsed = 0
BottomMargin = 0// normal = 0; UMI (define in User.cm) = 2
//@Xmargin = 28// normal = 28; UMI (define in User.cm) = 0
@Ymargin = 0
C1778 = C1778dflt
C50 = C50dflt
@prXmin; @prXmax; @prYmin;@prYmax
rotation
FontAlign
FontSet = 1// = 1 if le 4 fonts defined in user.cm
PressPass = 1// = Number of passes needed to generate the font dir
FontUsedTwo
CurrentPassNumber
Font16Flag
Font16Sub
]
structure FDentry:
[
el word
set byte
font byte
m byte
n byte
fam↑1,20 byte
face byte
source byte
siz word
rotation word
]
let MakePress(PrintSw,InitSwitch,comcm) be
[
Ws("*n*n*n*n*n"); Ws(Herrald)
//Xmargin = LeftMargin
FontNames = GetSomeMem(200)
InitColorTable(0)
FNameObject = GetSomeMem(280)
let fn = lv FNameObject>>item.string
SilInitCode(InitSwitch,0,FontNames)
let v = vec 50; InitCursor(v,50,0,0)
WriteCursor(Wss,"pg")
//initialize a zone for the file system
let v = vec 2000
SilZone = InitializeZone(v,2000)
//set up the part directory
let v = vec 256
PartDir = v
PDptr = PartDir
Zero(PartDir,256)
//initialize the Macro Definition Table
//Zero(Mact,Mtsize)
//use remaining space for the objects
SpaceBase = @#335 //EndCode
@#335 = lv PrintSw -2000 //set EndCode - leave 2000 words for the stack
SpaceTop = @#335-128 //leave margin for error
if (SpaceTop-SpaceBase-10000) ls 0 then CallSwat("Insufficient Object Storage")
let PressName = vec 100
let PressFile = vec 50; PressFile!0 = 0; AppendS("RSil.Press",PressFile)
let Host = vec 50; Host!0 = 0
OneLevel = false //ask for full macro expansion
PressS = 0
//THE MAIN FILE INPUT LOOP
let Page = 0
[
WriteCursor(Wns,Page+1,2)
WriteCursor($i)
InitStorage()
if not ReadCmEntry(comcm,fn) then break //no more files
CheckColorCmmd(comcm,fn,Host,PressFile)
if not fn>>str.length then break //command line error
FileIn(0)
let InOK = " "
if Message!0 ne InOK!0 then
[ Ws("*n");Ws(Message);Ws(fn);@#420 = Dcb; loop ]
if not PressS then
[
PressS=OpenFile(PressFile,ksTypeWriteOnly,1,verLatestCreate,0,0,SilZone)
if PressS eq 0 then CallSwat("Can’t Open RSil.Press")
MoveBlock(PressName, fn, 100)//save the name of the first file
]
WriteCursor($o)
@#420 = 0 //turn off display again
PressOut(PressS)
Page = Page+1
] repeat
if ncopies ls 1 then ncopies = 1
if ncopies ne 1 then PrintSw = true
if Page gr 1 then AppendS(" etc.",PressName)
WriteCursor(Wss,"dn")
Closes(comcm)
if PressS ne 0 then //send out the parts directories
[
//make Font Descriptors for the fonts used and send to out file
SendFDEntries(PressS,0)
if FontSet eq 2 then SendFDEntries(PressS,1)
//Output the font directory
//for i = 0 to 255 do PUTW(PressS,FontDir!i)
//add an entry to the part directory for the font directory
PDptr!0 = 1 //type font directory part
PDptr!1 = CurrentRecord
//PDptr!2 =1// FDptr ge 255? 2,1 //font directory is one page long
PDptr!2 =FontSet //font directory is one/two pages long
PDptr = PDptr+3
Nparts = Nparts+1
//CurrentRecord = CurrentRecord+1
CurrentRecord = CurrentRecord+FontSet
//Output the part directory
for i = 0 to 255 do PUTW(PressS,PartDir!i)
CurrentRecord = CurrentRecord+1
//Output the Document Directory
let dd=PartDir
for i = 0 to 127 do dd!i = -1
Zero(dd+128,128)
dd!0=27183 //password
dd!1=CurrentRecord+1 //total number of records
dd!2=Nparts //total number of parts
dd!3=CurrentRecord-1 // part directory begins here
dd!4=1 //part directory is 1 record long
//dd!5=-1
DayTime(dd+6) //put 1 sec timer into dd!6 and dd!7
dd!8=1 //first page to print
dd!9=1 //last page
//dd!10=-1
//dd!11=-1
dd!12 = ScanCvrt ne 0? ScanCvrt,-1 //Flag to get full software scan conversion
MoveBlock(dd+200b, PressName, 26)//put in the name of the first file
MoveBlock(dd+232b, UserName, UserName!-1)
let v = vec 6 //now get the Date and Time
UNPACKDT(0,v)
CONVUDT(dd+252b,v)
for i = 0 to 255 do PUTW(PressS,dd!i)
Closes(PressS)
]
test (PrintSw eq true) % Host!0 ifso
[ // Now write command on Rem.Cm and preserve old contents.
WriteRemcm(Host,PressFile)
]
//CounterJunta(SpeakVersion)
ifnot [ Ws("*n"); Ws(PressFile); Ws(" may be sent directly with use of ’RSil/h’") ]
finish
]
and PUTW(stream,wurd) be
[
PUTB(stream,wurd rshift 8)
PUTB(stream,wurd & #377)
]
and PUTB(stream,bite) be
[
Puts(stream,bite)
EntityBytesSent = EntityBytesSent+1
BytesOut = BytesOut+1
if BytesOut eq 0 then ByteCarry = ByteCarry+1
]
and WSSB(stream,string) be
[
for i=1 to string>>str.length do PUTB(stream, string>>str.char↑i)
]
and InitStorage() be
[
NewItem= SpaceBase
FirstItem = 0
Zero(Mact,Mtsize)
]
and PressOut(st) be //takes a stream open for bytes
[
let v = vec 7
FontAlign = v
Zero(FontAlign,7)
FontSet = FontUtil(FontAlign)// returns the number of font sets needed
let link = FirstItem
// This code test for two passes to generate the press file
if FontSet eq 2 then
[
until link eq 0 do //build PressPass
[
if link>>item.macro then
//macro --expand it and output any strings it contains
[
let sfi = FirstItem
FirstItem = 0
let sni = NewItem
Expand(link,0,0)
let tl = FirstItem
until tl eq 0 do
[
MarkFontUsed(tl)
tl=tl>>item.link
]
FirstItem = sfi
NewItem = sni
]
MarkFontUsed(link)
link = link>>item.link
]
let count = 0
Font16Sub = -1
for i = 0 to 15 do
[
let Filled = (FontUsed & 1 lshift i)
if Filled then count = count + 1
if not Filled & Font16Sub eq -1 then Font16Sub = i
let n = (FontUsedTwo & 1 lshift i)
if n then count = count + 1
]
if count ge 16 then PressPass = 2
]
if (FontSet eq 1 & FontUsed eq -1) % ( FontUsed eq -1 & FontUsedTwo eq -1 ) then CallSwat("To many font & faces in file")
if FontSet eq 2 & FontUsedTwo eq 0 & FontUsed ne -1 then FontSet = 1
Font16Flag = (FontUsed & #100000) eq #100000
if FontSet eq 2 then Font16Flag = false
// Now actually do it
DoPressOut(st)
]
and DoPressOut(st) be //takes a stream open for bytes
[
let DLone =0
let DLtwo = 0
test FontSet eq 1
ifso CurrentPassNumber = 0
ifnot CurrentPassNumber = 1
BytesOut = 0; ByteCarry = 0
//initial color conditions for start of press page
InitColorTable(true)
DoFnt15=false
let link = FirstItem
// may loop twice for FontSet = 2
[
link = FirstItem
until link eq 0 do //build DL
[
//if ((link>>item.font ge 8)&(link>>item.font ls 14)) then
if link>>item.macro then
//macro --expand it and output any strings it contains
[
let sfi = FirstItem
FirstItem = 0
let sni = NewItem
Expand(link,0,0)
let tl = FirstItem
until tl eq 0 do
[
//if tl>>item.font ls 8 then WSSB(st,lv(tl>>item.string))
//if tl>>item.font eq 15 then DoFnt15 = true
PutString(tl ,st)
if tl>>item.area then DoFnt15 = true
tl=tl>>item.link
]
FirstItem = sfi
NewItem = sni
]
//if link>>item.font ls 8 then WSSB(st, lv(link>>item.string))
//if link>>item.font eq 15 then DoFnt15 = true
PutString(link ,st)
if link>>item.area then DoFnt15 = true
link = link>>item.link
]
if FontSet eq 1 then break
if CurrentPassNumber eq 1 then DLone = BytesOut
if CurrentPassNumber eq 2 then DLtwo = BytesOut
//BytesOut = 0
if CurrentPassNumber eq 2 then break
CurrentPassNumber = CurrentPassNumber + 1
] repeat
if (BytesOut & 1) ne 0 then PUTB(st,0) //pad to word boundary
let BytesInDL = BytesOut
if (BytesInDL ls 0)%(ByteCarry ne 0) then
CallSwat("DL too large- type ↑K to exit")
BytesOut = 0; ByteCarry = 0
//now we are sending EL
PUTW(st,0) //send a 0 word
StartEntity()
FirstDLByte = 0
if BackGndEn ne true then DoFnt15 = false//skip backgrounds to print on Dover
//the following loop may be executed once or twice
//if the previous pass through the item lists found no items of font 15
//then only one pass is needed
//if areas are painted some color, then for objects OVER background,
//backgrounds must be output first - hence two passes
test FontSet eq 1
ifso CurrentPassNumber = 0
ifnot CurrentPassNumber = 1
// may loop twice for FontSet = 2
[
[
if CurrentPassNumber eq 2 then DoFnt15 = false
link = FirstItem //go through again and output entity list
until link eq 0 do
[
let tl = link; link = link>>item.link
let fnt = tl>>item.font
//if ((fnt ge 8)&(fnt ls 14)) then //macro
if tl>>item.macro then
[
let sfi = FirstItem
FirstItem = 0
let sni = NewItem
Expand(tl,0,0)
let xtl = FirstItem
until xtl eq 0 do
[
if (xtl>>item.area eq 1) eq DoFnt15 then MakeEntity(st,tl,xtl)
xtl = xtl>>item.link
]
FirstItem = sfi
NewItem = sni
loop
]
//not a macro
if (tl>>item.area eq 1) eq DoFnt15 then MakeEntity(st,tl,tl)
]
if DoFnt15 eq 0 then break
if not ScanCvrt then ScanCvrt = $s //dont set $s if nPPR/f said "fast print"
DoFnt15 = 0
] repeat
if FontSet eq 1 then break
if CurrentPassNumber eq 1 then PumpOutEntity(st)
if CurrentPassNumber eq 2 then break
CurrentPassNumber = CurrentPassNumber + 1
] repeat
//send the last entity
PumpOutEntity(st)
//pad
let elp = 0 //entity list padding
until ((BytesOut+BytesInDL) & #777) eq 0 do
[
PUTW(st,0)
elp = elp+1
]
//make an entry in the part directory for this page
PDptr!0 = 0 //type printed page
PDptr!1 = CurrentRecord
let rlen = (BytesOut rshift 9)+(BytesInDL rshift 9)+(((BytesOut & #777)+(BytesInDL & #777))rshift 9)+(ByteCarry lshift 7) //from bytes to pages
PDptr!2 = rlen
CurrentRecord = CurrentRecord+rlen
PDptr!3 = elp
PDptr = PDptr+4
Nparts = Nparts+1
]
and StartEntity() be
[
fontsel=0; fheight=AlFaceVec!(fontsel/4)
EntityBytesSent = 0 //don’t count the zero word
DLBytesSent = 0
prXmin=ScreenXmax; prXmax=-1
prYmin=ScreenYmax; prYmax=-1
]
and MakeEntity(st,tl,xtl) be
[
// CurrentPassNumber = 0 ---> write everything
// CurrentPassNumber = 1 ---> write fonts le 15
// CurrentPassNumber = 2 ---> write fonts ge 16 & le 28
let xfnt = xtl>>item.font
let LineOrArea = xtl>>item.line % xtl>>item.area
let xfnt = xtl>>item.font
test LineOrArea
ifso [ if CurrentPassNumber eq 2 then return ]
ifnot [
if (CurrentPassNumber eq 1) & (xfnt gr 7) then return
if (CurrentPassNumber eq 2) & (xfnt ls 8) then return
]
SetEntityColor(st,tl,xtl)
//test xfnt ge 14 ifso //rectangle
test LineOrArea ifso //rectangle
[
//crop lines at ScreenMax boundaries
if xtl>>item.xmax gr ScreenXmax then xtl>>item.xmax = ScreenXmax
if xtl>>item.ymax gr ScreenYmax then xtl>>item.ymax = ScreenYmax
let w=xtl>>item.xmax - xtl>>item.xmin
let h=xtl>>item.ymax - xtl>>item.ymin
if w ge 0 & h ge 0 then//Guard against unsanitized Sil files
[
PUTB(st,SetX)
PUTW(st,MulDiv(xtl>>item.xmin, C1778, C50) )
PUTB(st,SetY)
PUTW(st,MulDiv(ScreenYmax-xtl>>item.ymax, C1778, C50) )
PUTB(st,ShowRectangle)
PUTW(st,MulDiv(w ,C1778,C50))
PUTW(st,MulDiv(h ,C1778,C50))
]
]
ifnot
[
//the object is a string
xfnt = xtl>>item.fullfont
//FontUsed = FontUsed % (1 lshift xfnt)
let delx = FontAlign!(xfnt/4)
PUTB(st,SetX)
PUTW(st,MulDiv(xtl>>item.xmin + delx , C1778, C50) )
if xfnt ne fontsel then
[
fontsel = xfnt //external font with bold/italics bits
fheight = AlFaceVec!(fontsel/4)
let fontnumber = fontsel
if CurrentPassNumber eq 2 then fontnumber = fontnumber - #20
if CurrentPassNumber ls 2 & Font16Flag & fontsel eq 15 then fontnumber = Font16Sub
PUTB(st,SetFont+fontnumber)
//PUTB(st,SetFont+fontsel)
]
let FontItem = FontOrientation!( xfnt/4 )
let rot = FontItem & #377
//The following kludge is in to line up Gates and Template font definitions with sil lines on the printers.
let fudge = fheight ge 32? 16,0 //should be Gates32 or Template64
let pressPosn = ScreenYmax-xtl>>item.ymin-fheight
if rot eq 1 then pressPosn = ScreenYmax-xtl>>item.ymax
if pressPosn ls 0 then pressPosn = 0
PUTB(st,SetY)
PUTW(st,MulDiv(pressPosn, C1778, C50) + fudge)
PUTB(st,ShowCharacters)
let bcout =xtl>>item.string.length
PUTB(st,bcout)
DLBytesSent = DLBytesSent+bcout
]
if prXmin gr xtl>>item.xmin then prXmin=xtl>>item.xmin
if prXmax ls xtl>>item.xmax then prXmax=xtl>>item.xmax
if prYmin gr xtl>>item.ymin then prYmin=xtl>>item.ymin
if prYmax ls xtl>>item.ymax then prYmax=xtl>>item.ymax
if EntityBytesSent gr 20000 then PumpOutEntity(st)
]
and PumpOutEntity (st) be
[
if (BytesOut & 1) ne 0 then PUTB(st,Nop) //pad to word boundary
//send entity trailer
PUTB(st,0) //type
if CurrentPassNumber eq 2 then PUTB(st,1) //font set
if CurrentPassNumber ls 2 then PUTB(st,0) //font set
PUTW(st,0); PUTW(st,FirstDLByte) //begin-byte
PUTW(st,0); PUTW(st,DLBytesSent) //byte-length
//PUTW(st,MulDiv(Xmargin,C1778,C50)) //Xe
PUTW(st,MulDiv(LeftMargin,C1778,C50)) //Xe
PUTW(st,MulDiv(-Ymargin,C1778,C50)) //Ye
PUTW(st,MulDiv(prXmin,C1778,C50)) //left
PUTW(st,MulDiv(ScreenYmax+BottomMargin-prYmax,C1778,C50)) //bottom
PUTW(st,MulDiv(prXmax-prXmin ,C1778,C50)) //width
PUTW(st,MulDiv(prYmax-prYmin ,C1778,C50)) //height
PUTW(st,1+EntityBytesSent/2) //entity length
FirstDLByte = FirstDLByte+DLBytesSent
StartEntity()
]
and SendFDEntries(S,set) be// set is 0/1
[
let FontDir = vec 256
let FDptr = FontDir
Zero(FontDir,256)
if (FontSet eq 1 & FontUsed eq -1) % ( FontUsed eq -1 & FontUsedTwo eq -1 ) then CallSwat("To many font & faces in file")
let startfont, endfont = 0, 3
if set eq 1 then [ startfont = 4; endfont = 6 ]
for font = startfont to endfont do
[
let name = FontNames + 25*font
if name>>str.length eq 0 then loop
let ssi = 1 //remove leading "X" in name if there
if ((name>>str.char↑1 eq $X) % (name>>str.char↑1 eq $x)) then ssi=2
let FontItem = FontOrientation!font
let r = FontItem & #377
rotation = 90*r*60
//if font ge 2 then rotation = 90*60
let siz = GetNum(name,0)
if siz eq 0 then CallSwat("No point size in font:",name)
let face = 0; let gotsize = false; let sei = 1
for chrptr = 1 to name>>str.length do
[
let lastchar = name>>str.char↑chrptr
if gotsize then switchon lastchar into
[
case $I: case $i: face = face%1; endcase
case $R: case $r:
case $M: case $m: endcase
case $B: case $b: face = face%2; endcase
case $L: case $l: face = face%4; endcase
case $0: case $1: case $2: case $3: case $4:
case $5: case $6: case $7: case $8: case $9: endcase
default: CallSwat("Malformed Font Name:",name)
]
if (lastchar ge $0) & (lastchar le$9) then if gotsize eq false do
[ sei = chrptr-1; gotsize = true ]
]
//fill in the font directory entry for this font
for f = 0 to 3 do
[
let ff = font*4 + f
let FontFaceUsed = 0
test set eq 0
ifso [
FontFaceUsed = FontUsed & (1 lshift ff)
]
ifnot [
ff = ff - #20
FontFaceUsed = FontUsedTwo & (1 lshift ff)
]
let NoEntry = (set eq 1) & (ff eq 15)
if not NoEntry then
[
FDptr>>FDentry.el = 16
FDptr>>FDentry.set = set
FDptr>>FDentry.font = ff
FDptr>>FDentry.m = 0
FDptr>>FDentry.n = 127
FDptr>>FDentry.fam↑1 = sei-ssi+1 //string length
let i = 2
for j = ssi to sei do
[
FDptr>>FDentry.fam↑i = name>>str.char↑j
i = i+1
]
if FontFaceUsed then FDptr>>FDentry.face = f xor face
FDptr>>FDentry.source = 0
FDptr>>FDentry.siz = MulDiv(siz, C50dflt, C50 )
FDptr>>FDentry.rotation = rotation
FDptr= FDptr+16
]
]
]
if Font16Flag & set eq 0 then
[
FDptr = FontDir + 240
FDptr>>FDentry.font = Font16Sub
MoveBlock(FontDir + Font16Sub *16, FontDir + 240, 16)
]
if FontSet eq 1 then Zero(FontDir+240,16)
//
for i = 0 to 255 do PUTW(S,FontDir!i)
]