Trailing-Edge
-
PDP-10 Archives
-
BB-JR93N-BB_1990
-
10,7/galaxy/lptspl/lptl01.mac
There are 10 other files named lptl01.mac in the archive. Click here to see a list.
TITLE LPTL01 - LN01 device driver for LPTSPL-10
SUBTTL Nicolas Tamburri 16-OCT-89
;
;
; COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION
; 1984,1985,1986,1987,1990.
; ALL RIGHTS RESERVED.
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED
; AND COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE
; AND WITH THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS
; SOFTWARE OR ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR
; OTHERWISE MADE AVAILABLE TO ANY OTHER PERSON. NO TITLE TO
; AND OWNERSHIP OF THE SOFTWARE IS HEREBY TRANSFERRED.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE
; WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT
; BY DIGITAL EQUIPMENT CORPORATION.
;
; DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY
; OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY
; DIGITAL.
;
SEARCH GLXMAC ;SEARCH GALAXY PARAMETERS
SEARCH QSRMAC ;SEARCH QUASAR PARAMETERS
SEARCH ORNMAC ;SEARCH ORION/OPR PARAMETERS
SEARCH LPTMAC ;Search LPTSPL parameters
PROLOG(LPTL01)
IF2,<PRINTX Assembling GALAXY-10 LPTL01>
.DIRECT FLBLST
SALL ;SUPPRESS MACRO EXPANSIONS
ENTRY LPTL01 ;LOAD IF LIBRARY SEARCH
;LPTL01 VERSION INFORMATION
%%.LPT==:%%.LPT ;EDIT LEVEL
GLOB <LPERR,LPMSG>
SUBTTL Local symbols
ACSLTH==^D38 ;Maximum lenght of ACS string
CHTWDS==ACSLTH/5+1 ;Define lenght in words
NAMBYT==7 ;8 bit bytes in the name
RNMLTH==^D20 ;Number of characters in real name
RNMWDS==RNMLTH/5 ;Number of words (8 bit bytes)
NAMLTH==^D30 ;Max chars in a pseudoname
SUBTTL Macros
DEFINE $ESC<[EXP .CHESC]> ;For escape sequences
SUBTTL Tables -- Font list entry format
PHASE 0
FN.LNM:! BLOCK 1 ;List of names
FN.RNM:! BLOCK <RNMWDS> ;20 character real name
FN.FIL:! BLOCK 1 ;Name of font file
FN.LEN:! BLOCK 1 ;Lenght of the font
FN.LND:! BLOCK 1 ;Landscape flag
FN.SIZ==. ;Size of the entry
DEPHASE
PHASE 0
FC.CHC:! BLOCK 1 ;Font name cached from LPFONT.INI
FC.SIZ==. ;Size of cache entry
DEPHASE
PHASE 0
FM.NAM:! BLOCK FNMLTH ;Font name (30 char max)
FM.SIZ==.
DEPHASE
SUBTTL Local storage
INIUDT: BLOCK 1 ;Creation date of LPFONT.INI
FNTLST: BLOCK 1 ;List of cached names
SUBTTL Tables -- FONTFD - Font file descriptor template
; These two tables will be used to access the fonts needed.
FONTFD: $BUILD (FDXSIZ)
$SET(.FDLEN,FD.LEN,FDXSIZ) ;Lenght of filespec block
$SET(.FDLEN,FD.TYP,.FDNAT) ;Native file spec
$SET(.FDSTR,,'SSL ') ;System search list must have FNT
$SET(.FDEXT,,'SIX ') ;Extension
$SET(.FDPPN,,) ;So will the PPN
$SET(.FDPAT,,'LN01 ') ;SFD name for this device
$EOB
SUBTTL Tables -- FNTFOB - Font file FOB template
FNTFOB: $BUILD (FOB.SZ)
$SET(FOB.FD,,FONTFD) ;Address of file descriptor
$SET(FOB.CW,FB.BSZ,7) ;Byte size
$SET(FOB.US,,) ;In your behalf PPN will be filled in
$EOB
SUBTTL Tables -- FINIFD - LPFONT.INI file dispcriptor block
FINIFD: $BUILD (FDXSIZ)
$SET(.FDLEN,FD.LEN,FDXSIZ) ;Lenght of filespec block
$SET(.FDLEN,FD.TYP,.FDNAT) ;Native file spec
$SET(.FDSTR,,'SSL ') ;System search list for FNT
$SET(.FDNAM,,'LPFONT') ;Name to be filled in later
$SET(.FDEXT,,'INI ') ;Extension
$SET(.FDPPN,,) ;So will the PPN
$SET(.FDPAT,,'LN01 ') ;SFD name for this device
$EOB
SUBTTL Tables -- INIFOB - LPFONT.INI FOB
INIFOB: $BUILD (FOB.SZ)
$SET(FOB.FD,,FINIFD) ;Address of file descriptor
$SET(FOB.CW,FB.BSZ,7) ;Byte size
$EOB
SUBTTL Tables -- Function dispatch table
; This table contains the addresses of the LN01 specific functions
; which will be called by LPTSPL at the required times. The first word
; of the table will contain the lenght of itself, and will be used by
; LPTSPL to BLT the table into the stream data page at the page's
; creation. Wether the table should be loaded or not will be specified
; GALGEN time.
LPTL01::DEVDSP (L01,<LN01>)
L01STS==LPTSTS## ;Device status text
SUBTTL Global routines -- L01INX - Initialize the printer
; This routine will be called when the LN01 first comes on line
; and will reset the printer if need be. It will also return
; a pointer to a block of four words which will contain a break
; mask for which characters must be interpreted by the device specific routine.
;
; Call: J/ Stream number
; M/ Setup message address or zero
; PUSHJ P,L01INX
; $CALL LPTL01
;
; Returns: TRUE if OK, FALSE otherwise
; S1/ Response to setup code (%RSUxx)
L01INX: JUMPE M,.RETT ;Return if LPTSPL initialization
MOVE S1,STREAM## ;Get stream number
MOVE S1,JOBOBA##(S1) ;And the object block
MOVE S1,OBJ.ND(S1) ;Get station number
PUSHJ P,LPTANF## ;Must be ANF-10
SKIPN J$LLAT(J) ; or a LAT line
JUMPF INIT.1 ;No: not our kind of device
PUSHJ P,CHKDEV ;See if ANF/LP-11 or asynch line
JUMPF INIT.1 ;Try another driver
MOVE T1,['LN01 '] ;Unit type identifier
MOVEM T1,J$LTYP(J) ;Save for QUASAR
HRLZI T1,'FNT' ;Get name of where fonts are kept
DEVPPN T1,UU.PHY ;Get the ersatz PPN
MOVE T1,[5,,36] ;Assume default
MOVEM T1,FINIFD+.FDPPN ;Store for lookup
MOVEM T1,FONTFD+.FDPPN
SETOM J$LLCL(J) ;Flag a lower case printer
HRLZI T1,LPTL01 ;Build a BLT pointer
HRRI T1,J$$DEV(J) ; to the initialization vector
BLT T1,J$$DND(J) ;Copy our vector
SETOM J$ALNF(J) ;LN01 doesn't need alignment formfeeds
SETOM J$POSF(J) ;LN01 DOES POSITIONING
SETOM J$FFDF(J) ;LN01 DOES FORM FEEDS
SETOM J$DC3F(J) ;LN01 SUPPORTS DC3 IN BANNERS
SETOM J$MNTF(J) ;LN01 SUPPORTS MOUNTABLE FORMS
MOVEI S1,%RSUOK ;LOAD THE CODE
SETZ S2, ;NO EXTRA ATTRIBS
$RETT ;Return
INIT.1: MOVNI S1,1 ;-1 means device not for us
$RETF ;Return
INIT.2: SKIPA S1,[%RSUNA] ;unit not available
INIT.3: MOVEI S1,%RSUDE ;unit will never be available
$RETF ;Return
; Here to check for an ANF/LP-11 LN01 or an LN01 on
; a an asymch line.
CHKDEV: SKIPN S1,SUP.ST(M) ;Have specific device?
MOVSI S1,'LPT' ;Will be a LPT
PUSHJ P,LPTDVN## ;Make a device name
; LP11
CHKLPX: MOVE T1,J$LDEV(J) ;Get device name
DEVCHR T1,UU.PHY ;Get characteristics
TXNN T1,DV.LPT ;A LPT?
JRST CHKTTY ;Nope
MOVE T1,[2,,T2] ;Set up UUO AC
MOVEI T2,.DFHCW ;Function code
MOVE T3,J$LDEV(J) ;Device name
DEVOP. T1,UU.PHY ;Read hardware characteristics
SETZ T1, ;Failed??
LOAD T1,T1,DF.CLU ;Get the unit type
CAIE T1,.DFULN ;Device an LN01?
$RETF ;No, try another driver
$RETT ;Return goodness
CHKTTY: SKIPN S1,SUP.ST(M) ;GET DEVICE NAME
$RETF ;MUST BE AN ALTERNATE DEVICE
PUSHJ P,LPTLIN## ;GENERATE DEVICE NAME
$RETIF ;GIVE UP
MOVE T1,J$LDEV(J) ;GET DEVICE NAME
DEVCHR T1,UU.PHY ;GET DEVICE CHARACTERISTICS
TXNN T1,DV.TTY ;MUST BE A TTY
$RETF ;ISN'T
MOVE T1,[2,,T2] ;SET UP UUO AC
MOVEI T2,.TOTRM ;WANT TO READ TERMINAL TYPE
MOVE T3,J$LION(J) ;GET I/O INDEX
TRMOP. T1, ;READ TERMINAL TYPE
$RETF ;PREHISTORIC MONITOR
CAME T1,['LN01S '] ;LN01 ON A TTY LINE?
CAMN T1,['LN01 '] ;ALTERNATE NAME?
$RETT ;RETURN GOODNESS
$RETF ;NOPE
SUBTTL Global routines -- L01CLS - CLOSE device
L01CLS: PJRST LPTCLS## ;Call common CLOSE routine
SUBTTL Global routines -- L01FLS - Flush job
L01FLS: PJRST LPTFLS## ;Call common flush routine
SUBTTL Global routines -- L01VFU - Load VFU
L01VFU: $RETT ;Do nothing
SUBTTL Global routines -- L01RAM - Load RAM
L01RAM: $RETT ;Do nothing
SUBTTL Global routines -- L01LER - File LOOKUP error processing
L01LER: PJRST LPTLER## ;Call common error routine
SUBTTL Global routines -- L01IER - File input error processing
L01IER: PJRST LPTIER## ;Call common error routine
SUBTTL Global routines -- L01OUT - Output a buffer
L01OUT: PJRST LPTOUT## ;Call common output routine
SUBTTL Global routines -- L01OER - Output error processing
L01OER: PJRST LPTOER## ;Call common output routine
SUBTTL Global routines -- L01EOX - Output EOF processing
L01EOX: $RETT ;No special processing
SUBTTL Global routines -- L01IPC - Special IPCF message processing
L01IPC: MOVNI S1,1 ;We have no special messages
$RETF ;Return
SUBTTL Global routines -- L01SCD - Scheduler call
L01SCD: $RETT ;Do nothing
SUBTTL Global routines -- L01WAK - Wakeup time check
L01WAK: $RETT ;Return
SUBTTL Global routines -- L01OPX - OPEN device
L01OPX: MOVX T1,.IOAS8 ;Open mode-ASCII, suppress VFU
PUSHJ P,LPTOPN## ;Setup I/O, OPEN channel, etc.
JUMPF OPEN.1 ;Can't have it right now
PUSHJ P,INTCNL## ;Connect to interrupt system
JUMPF OPEN.2 ;Give up
TXO S,INTRPT ;Indicate we're connected
MOVEI S1,%RSUOK ;Load the code
$RETT ;Return
OPEN.1: SKIPA S1,[%RSUNA] ;Unit not available
OPEN.2: MOVEI S1,%RSUDE ;Unit will never be available
$RETF ;Return
SUBTTL Global routines -- L01REQ - Begining of job initialization
; This routine will be called at the beginning of each request.
; It will be used to reset the fonts to the default ROM fonts.
;
; Call: $CALL L01BFL
;
; Returns: TRUE always
L01BJB: SETOM J$XTOP(J) ;Flag top of page
$TEXT(SENDCH,<^I/RIS/^A>) ;Reset the printer
$TEXT(SENDCH,<^7/$ESC/[1!}^A>) ;Offset the paper
$RETT
BOXSQX: ITEXT(<^7/$ESC/[0;100;100;2350;10!|^7/$ESC/[0;100;3190;2350;10!|^A>)
BOXSQY: ITEXT(<^7/$ESC/[1;100;100;3100;10!|^7/$ESC/[1;2450;100;3100;10!|^A>)
SUBTTL Global routines -- L01EJB - End of job
L01EJB: $RETT ;Do nothing
SUBTTL Global routines -- L01BFL - Begining of file initialization
; This routine is much like the above routine except that it will be
; called on a per file basis for non-stick font specs and attributes.
;
; $CALL L01BFL
;
; Returns: TRUE always
L01BFL: $SAVE <P1> ;Save a scratch reg
LOAD S1,.FPLEN(E),FP.LEN ;Get the lenght of the FP
CAIN S1,FPXSIZ ;Long enough for a font to be there?
SKIPN .FPFNM(E) ;Yes, Did the user specify a font name
JRST FILI.9 ;No, go set to default font
MOVEI S1,.FPFNM(E) ;Get the address of the name
PUSHJ P,SRCROM ;Is this in the ROM?
JUMPT FILI80 ;Yes, don't really load the font
MOVEI S1,.FPFNM(E) ;Get the address of the name
SKIPN S2,J$FONT(J) ;Do we have a font already loaded?
JRST FILI.6 ;No, go see about a loaded list
PUSHJ P,SRCENT ;Go compare the two
JUMPT FILI.8 ;Same font, don't reload it
FILI.6: MOVEI S1,.FPFNM(E) ;Get the address of the name
SKIPN S2,J$FNTL(J) ;Do we have any fonts already loaded?
JRST FILI.7 ;No, go try to find it
PUSHJ P,SRCLST ;Search the loaded list
JUMPF FILI.7 ;Not found search file
MOVEM S1,J$FONT(J) ;Store the font header address
JUMPT FILI.8 ;It was there, don't reload it
FILI.7: MOVEI S1,.FPFNM(E) ;Get back the name again
PUSHJ P,FNDFNT ;Go see if it is in LPFONT.INI
$RETIF ;It wasn't, that's fatal
MOVEM S1,J$FONT(J) ;Store linked list of names
MOVE S1,FN.FIL(S1) ;Get the file name
PUSHJ P,FNTOPN ;Open it
$RETIF ;If not found, it's fatal
MOVE P1,S1 ;Save the IFN for LODFNT
PUSHJ P,SETSVF ;Suppress the VFU while loading font
PUSHJ P,SNDLCS ;Send the load character set sequence
PUSHJ P,LODFNT ;Load up the font, into the printer
$RETIF ;Error is fatal
PUSHJ P,ENDLOD ;And end the load
SETOM J$XTOP(J) ;Put us at top of form
MOVE S1,J$FONT(J) ;Point S1 at the font header
$TEXT(LOGCHR##,<^I/LPMSG/Loaded font named ^T20/FN.RNM(S1)/>)
FILI.8: PUSHJ P,SENDFF## ;Send a form feed to the next page
$TEXT(SENDCH,<^7/$ESC/P1;12}^T20/FN.RNM(S1)/^7/$ESC/^7/[134]/^A>)
$TEXT(SENDCH,<^7/$ESC/[12m^A>) ;Select primary font
SKIPN FN.LND(S1) ;Landscape font?
JRST FILI90 ;No, set portrait parameters
JRST FILI92 ;Yes, go set landscape parameters
FILI80: SKIPN FN.LND(S1) ;Landscape font?
JRST FILI93 ;No, load portrait from ROM
JRST FILI91 ;Yes, load landscape from ROM
FILI.9: SKIPN S1,J$FORM(J) ;User specify a form type?
JRST FILI91 ;No, assume normal font
CAME S1,[SIXBIT \NORMAL\] ;User wants portrait default?
CAMN S1,[SIXBIT \NARROW\] ; . . .
TRNA ;Yes to either, set portrait mode
JRST FILI91 ;No, set landscape
FILI93: PUSHJ P,SENDFF## ;Go to the next page
$TEXT(SENDCH,<^I/PRTRAT/^A>) ;Set portrait mode from ROM
FILI90: $TEXT(SENDCH,<^I/PRTMRG/^A>) ;Set up proper margins
SET80C: MOVEI S1,^D80 ;Set for eighty columns
MOVEM S1,J$FWID(J) ;Store it into per stream data
MOVEI S1,2 ;Make it width class 2
MOVEM S1,J$FWCL(J) ;Store it
JRST SETESC ;Set up escape mask
FILI91: PUSHJ P,SENDFF## ;Next page
$TEXT(SENDCH,<^I/LANDSQ/^A>) ;Else set to default font
FILI92: $TEXT(SENDCH,<^I/LNDMRG/^A>) ;Set up proper margins
SETOM J$XPOS(J) ;And put us at top of form
L01WID:
SET132: MOVEI S1,^D132 ;Set for 132 columns
MOVEM S1,J$FWID(J) ;Store it into per stream data
MOVEI S1,3 ;Make it width class 3
MOVEM S1,J$FWCL(J) ;Store it
TXNE S,BANHDR ;Loading a font?
PJRST CLRSVF ;No, don't lose the <DC3>s in banners
SETESC: LOAD S1,.FPINF(E),FP.FPF ;Get the information bits
CAIN S1,%FPGRF ;Does he want graphics?
JRST SETES1 ;Yes, go set it up
SETZM J$DBRK(J) ;Assume no mask wanted
CLRSVF: MOVE S2,[TXZ TF,IO.SVF] ;Get intruction to turn on VFU
JRST SETES2 ;And go set it up
SETES1: XMOVEI S1,ESCMSK ;Get the escape mask
MOVEM S1,J$DBRK(J) ;Store into the stream data
SETSVF: MOVE S2,[TXO TF,IO.SVF] ;Yes, suppress VFU
SETES2: MOVE S1,J$LCHN(J) ;Get the channel number
LSH S1,^D23 ;Position it
TLO S1,(GETSTS 0,TF) ;Or in the UUO
XCT S1 ;Get the status
XCT S2 ;Modify staus as needed
TLC S1,(<SETSTS@>^!<GETSTS>);Convert to set instruction
XCT S1 ;Set the desired status
$RETT
SNDLCS: SKIPLE J$LDNF(J) ;Already sent this sequence?
POPJ P, ;Yes, return now
$TEXT(SENDCH,<^7/$ESC/P1;1y^A>) ;Initialize load font escape sequence
MOVEI S1,1 ;Set flag that we've sent out
MOVEM S1,J$LDNF(J) ; ...this sequence
POPJ P,
ENDLOD: $TEXT(SENDCH,<^7/$ESC/^7/[134]/^A>)
SETZM J$LDNF(J) ;No londer loading
POPJ P, ;Return
ESCMSK: EXP 1B27,0,0,0 ;Escape is all we really need
LNDMRG: ITEXT(^7/$ESC/[75;2550r^7/$ESC/[75;3300s)
PRTMRG: ITEXT(^7/$ESC/[75;3300r^7/$ESC/[75;2550s)
SUBTTL Global routines -- L01RUL - Draw banner ruler
L01RUL: $RETT ;No special ruler action
SUBTTL Global routines -- L01EFL - End of file
L01EFL: $RETT ;Do nothing
SUBTTL GLobal routines -- L01BAN - Initialize the banners
; This routine will initialize the banners and header for a file
; before it starts printing.
;
; Call: J/ Stream number
; DEVOUT## ready for characters
;
; Returns: TRUE always
L01BAN:
L01HDR: JUMPE S1,SET132 ;If he just wants to set parameters
SETOM J$XTOP(J) ;Flag top of page
$TEXT(SENDCH,<^I/RIS/^A>) ;Reset the printer, select landscape
;Make a border
$TEXT(SENDCH,<^I/BOXSQX/^A>) ;Type out the X escape sequence
$TEXT(SENDCH,<^I/BOXSQY/^A>) ;Now do the Y
$TEXT(SENDCH,<^I/LANDSQ/^A>) ;Select landscape
$TEXT(SENDCH,<^I/MARGNS/^A>) ;Setup proper margins
PJRST SET132 ;Go set 132 columns wide
SENDCH: MOVE C,S1 ;Copy the character
JRST DEVOUT## ;And go output it
LANDSQ: ITEXT(^7/$ESC/[10m)
PRTRAT: ITEXT(^7/$ESC/[11m)
MARGNS: ITEXT(^7/$ESC/[200;2350r^7/$ESC/[250;3100s)
RIS: ITEXT(^7/$ESC/c) ;Master reset sequence
SUBTTL Global routines -- L01CHO - Physical character output
L01CHO: $RETT ;DEVOUT needs no help
SUBTTL Global routines -- L01SHT - Shut down a stream handler
; This routine should be called on stream shutdown, before the
; LPT data page is released. It will delete all linked lists.
;
; Call: J/ Stream number
L01SHT: SKIPE S1,J$CTMP(J) ;Do we have a text buffer page?
$CALL M%RPAG ;Yes, return it
SETZM J$CTMP(J) ;And clear it for next time
SETZM J$FONT(J) ;Get rid of /FONT specifier
SKIPE S1,J$FNTL(J) ;Do we have a font list loaded?
$CALL L%DLST ;Yes, return it
SETZM J$FNTL(J) ;And clear it for next time
$RETT
SUBTTL Global routines -- L01CHR - Escape character handler
; This routine will handle the interpretation of escape sequences
; embedded in the file. If the escape sequence is a new font specifier,
; it will load the font into the printer, otherwise, it will simply
; output any intercepted characters and return.
;
; Call: C/ Intercepted character
; J/ Stream number
;
; Returns: TRUE Font file(s) loaded or output sent
; FALSE S1/ Error code
;
; Possible errors:
; Font file not found
; File read errors
L01CHR: $SAVE <P1,P2,P3,P4> ;Get some scratch regs
SKIPN S1,J$CTMP(J) ;Do we have an escape buffer
$CALL M%GPAG ;No, Make one now
MOVEM S1,J$CTMP(J) ;Remember it
MOVE S1,J$FNTL(J) ;Get the name of the old list
MOVEM S1,J$OLDL(J) ;Remember it
SETZM J$FNTL(J) ;Clear the font list
SETZM J$LDNF(J) ;Clear loading font flags
MOVE P1,J$CTMP(J) ;Point to escape buffer
HRLI P1,(POINT NAMBYT,) ;Make it a byte pointer
PUSH P,P1 ;Save it
JRST CHAR10 ;And go try to interpret the sequence
CHAR.1: PUSH P,P1 ;Save the byte pointer
PUSHJ P,FILBYT ;Get a character
JUMPF CHAR.3 ;Error, go flush buffer
CHAR10: IDPB C,P1 ;Store the character
CAIE C,.CHESC ;Escape character?
JRST CHAR.3 ;No, go flush the buffer
PUSHJ P,INTERP ;Interpret the sequence
JUMPF CHAR.3 ;Return if not valid
JUMPN S1,CHAR.2 ;LCS sequence, Go load it all in
POP P,(P) ;Destroy saved pointer
MOVEI S1,J$NMTP(J) ;Get the address to place the name in
PUSHJ P,GETNAM ;Read it in
JUMPF CHAR.4 ;Error, go output what we have
MOVEI S1,J$NMTP(J) ;Get the address of the name
PUSHJ P,SRCROM ;See if it's already loaded
MOVE S2,S1 ;In case of success
JUMPT CHAR14 ;ROM font only needs to be assigned
SKIPN S1,J$FNTL(J) ;Do we have a list yet?
$CALL L%CLST ;No, get one now
MOVEM S1,J$FNTL(J) ;Store the list name
SKIPE S2,J$OLDL(J) ;Get address of old list, if existing
SKIPE J$LDNF(J) ;Must we load fonts?
JRST CHAR11 ;Yes, don't bother with old list
MOVEI S1,J$NMTP(J) ;Get the address of the name
PUSHJ P,SRCLST ;Go see if name loaded
JUMPT CHAR13 ;Found, go write real name
CHAR11: SKIPN J$LDNF(J) ;Loading fonts?
JRST CHAR12 ;No, no user fonts loaded
MOVEI S1,J$NMTP(J) ;Else look in loading list
MOVE S2,J$FNTL(J) ; in case we just loaded it
PUSHJ P,SRCLST ; and the name is in it
JUMPF CHAR12 ;Not found, Go search main lists
SKIPN J$LDNF(J) ;Already flagged to load fonts?
SETOM J$LDNF(J) ;Remember we must load fonts
JRST CHAR14 ;And go store the name
;Here we look through all fonts
CHAR12: MOVEI S1,J$NMTP(J) ;Get the address of where the name is
SKIPE S2,FNTLST ;Save the list for searching it
JRST CHA121 ;List exists, go search it
PUSHJ P,FNDFNT ;First time through, read in file
TRNA ;Check if success
CHA121: PUSHJ P,SRCLST ;Go search the list
JUMPT CHA122 ;Found, onward
MOVEI S1,J$NMTP(J) ;Get the font name
JRST NOFONT ;Not found, go tell user
CHA122: SKIPN J$LDNF(J) ;Already flagged to load fonts?
SETOM J$LDNF(J) ;Remember we must load fonts
CHAR13: PUSH P,S1 ;Save the name
MOVE S1,J$FNTL(J) ;Get the list name
MOVEI S2,FC.SIZ ;Get the size of the entry
$CALL L%CENT ;Create the entry
POP P,(S2) ;Get the address of the list
MOVE S1,(S2) ;And get the entry address
CHAR14: MOVEI S2,FN.RNM(S1) ;Get the address of the real name
HRLI S2,(POINT NAMBYT,) ;Make a byte pointer to it
MOVEI S1,RNMLTH ;Get the number of bytes in a name
CHAR15: ILDB C,S2 ;Get a character
IDPB C,P1 ;Store it into the buffer
SOJG S1,CHAR15 ;Loop for all characters
MOVEI C,.CHESC ;Close the ACS sequence
IDPB C,P1
MOVEI C,"\"
IDPB C,P1
JRST CHAR.1 ;Name already cached, loop for next
CHAR.2: POP P,P1 ;Restore pointer to overwrite LCS seq.
PUSHJ P,SNDLCS ;Send the load character set seq.
PUSHJ P,GTFONT ;Output the font(s)
$RETIF
JRST CHAR.1 ;Go see if more font specs
CHAR.3: POP P,(P) ;Adjust the stack
CHAR.4: SKIPE J$LDNF(J) ;Do we have any fonts to load?
JRST CHAR.5 ;Yes, go load them
MOVE S1,J$OLDL(J) ;Else, get the old fonts
MOVEM S1,J$FNTL(J) ;Preserve them for next time
JRST CHAR.6 ;And go do new font assignments
CHAR.5: SKIPE S1,J$OLDL(J) ;Get the old list
$CALL L%DLST ;Destroy it
PUSHJ P,LODLST ;Go load the font list
CHAR.6: $TEXT (SENDCH,<^T/@J$CTMP(J)/^A>) ;Send all the assign name sequences
$RETT
; Here on a load font record sequence. We will allow the user to
;specify embedded fonts in his file.
;Here we verify the header flag word
GTFONT: PUSHJ P,.SAVE4 ;Save P1-P4
PUSHJ P,GTFHDR ;Get the font header
JUMPF FMTERR ;Header not good, inform him
MOVE S1,J$FNTL(J) ;Get the list header for the font names
JUMPN S1,GTFN.1 ;List exists
$CALL L%CLST ;None yet, get one
MOVEM S1,J$FNTL(J) ;Save it
GTFN.1: MOVE S1,J$FNTL(J) ;Get the list name
MOVX S2,FN.SIZ ;And get the lenght of a block
$CALL L%CENT ;Create an entry block
HRRI P2,FN.RNM(S2) ;Calculate the place to store the name
HRLI P2,(POINT NAMBYT,) ;Build a pointer to the storage area
MOVEI P4,-<RNMLTH+6>(C) ;Save lenght (minus bytes read)
MOVX P3,RNMLTH ;Get the number of chars in a name
GTFN01: PUSHJ P,GETBYT ;Get a byte
JUMPF FMTERR
IDPB C,P2 ;Build the name string
SOJG P3,GTFN01 ;Loop over the whole name
;Now we read in the rest of the font, based on the lenght of the file
;that we got from the font header.
GTFN.2: PUSHJ P,GETBYT ;Get a byte
$RETIF ;Never happen
GTFN20: SOJN P4,GTFN.2 ;Yes, count it down, and loop for all
PUSHJ P,CIFMOR ;Any more fonts?
JUMPF .RETT ;No more, return now
JRST GTFN.1 ;More, go get it
;We might have extra padding characters between fonts. Try to find
;the next synch word if it exists.
CIFMOR: PUSHJ P,FILBYT ;Get the next character
$RETIF
CAIE C,"i" ;This character is 'sixelled' first
; part of font header word (AAAAH)
JRST GTFN.3 ;It isn't try for other delimiters
PUSHJ P,BACKUP ;Backup the byte handler
PUSHJ P,GTFHDR ;Read in the header info
$RETIF
$RETT ;Else return good
GTFN.3: CAIN C,";" ;Start of comment record?
JRST GTFN.4 ;Yes, go eat the font
CAIN C,.CHESC ;Delimiter?
JRST GTFN.5 ;End the load character set sequence
PUSHJ P,DEVOUT## ;Else output this character
JRST CIFMOR ;And loop for a delimiter
GTFN.4: PUSHJ P,DEVOUT## ;Output the semi-colon
PUSHJ P,EATFNT ;Eat the rest of the record
$RETF ;And return 'No more'
GTFN.5: PUSHJ P,ENDLCS ;End the LCS sequence
$RETF ;Return 'No more'
GTFHDR: SETZM J$BCT8(J) ;Clear any left over converted chars
PUSHJ P,GET2BY ;Get a word
$RETIF ;Should never happen
CAIE C,125252 ;Real header word?
JRST FMTERR ;No, must be error
GTFN.0: PUSHJ P,GETBYT ;02H : REV
$RETIF
PUSHJ P,GETBYT ;03H : FONT TYPE
$RETIF
SETZM FN.LND(P2) ;Assume portrait font
TRNE C,1 ;Landscape instead
SETOM FN.LND(P2) ;Yes, remember it
PUSHJ P,GET2BY ;04H-05H: FILE SIZE
$RETIF
$RETT
FMTERR: MOVE S1,STREAM## ;Get the stream number back
$WTO(<Aborting job>,<Font file ^F/FNTFOB/ in wrong format>,@JOBOBA##(S1))
$TEXT(LOGCHR##,<^I/LPERR/Job aborted because font ^F/FNTFOB/ is incorrectly formatted>)
MOVE S1,P1 ;Get the IFN
$CALL F%REL ;Close the file
$RETF ;Give bad return
SUBTTL Support routines -- INTERP - Interpret escape sequence
; This routine will read the sequence of characters following the
;escape character. It will return an index as to the function found.
; Call:
; C/ Last char read
; P1/ Byte pointer to temporary area
INTERP: PUSHJ P,INTCMN ;Interpret common chars
JUMPF INTER1 ;Wasn't
PUSHJ P,FILBYT ;Get the next
$RETIF
CAIE C,"0" ;Must be numeric
CAIN C,"1" ;0 or 1
TRNA ;It is
JRST INTER1 ;Nope, must be some other function
IDPB C,P1 ;Store this character
PUSHJ P,FILBYT ;Get the next
$RETIF
CAIN C,"y" ;Is this a load font command?
JRST RETLCS ;Return load character set code
CAIL C,"0" ;Else it must be numeric decimal
CAILE C,"9" ; . . .
JRST INTER1 ;It isn't
IDPB C,P1 ;Save the character in the buffer
PUSHJ P,FILBYT ;Get the next byte
$RETIF ;Error
CAIE C,"}" ;Must be octal 175
JRST INTER1 ;Too bad
TDZA S1,S1 ;Return a 0 to specify ACS
RETLCS: SETO S1, ;Return -1 to specify LCS
IDPB C,P1 ;Store it
$RETT ;But return true
INTER1: IDPB C,P1 ;Store the character
CAIL C,60 ;Final character in this sequence?
CAILE C,176 ; . . .
JRST INTER2 ;No, get another
SETZ C, ;Make a null byte
IDPB C,P1 ;End the string
$RETF ;Return false
INTER2: PUSHJ P,FILBYT ;Next character
JUMPT INTER1 ;Process it if it's good
$RETF
INTCMN: MOVE P4,[POINT 7,CMNCHR] ;Get pointer to common characters
MOVEI P3,3
PUSHJ P,FILBYT ;Get the next character
$RETIF ;Return if false
CAIN C,"[" ;Control sequence introducer?
JRST CMN.1 ;Yes, go eat it
JRST INTC10 ;Else process possible good string
INTCM1: PUSHJ P,FILBYT ;Get a byte
$RETIF
INTC10: ILDB S1,P4 ;Get the byte to compare to
CAME C,S1 ;Valid sequence?
$RETF ;No, return now
IDPB C,P1 ;Store if valid
SOJG P3,INTCM1 ;Loop for all characters
$RETT
CMN.1: IDPB C,P1 ;Store the character for output
PUSHJ P,FILBYT ;Get the next byte
CAIL C,100 ;Valid parameter character?
CAILE C,176 ; . . .
JUMPT CMN.1 ;Else loop till final character
$RETF ;And return
CMNCHR: ASCII |P1;|
SUBTTL Support routines -- LODLST - Load fonts in linked list
; This routine will search through the linked list of fonts and will
;load all the fonts into the LN01.
LODLST: $SAVE <P1,P2> ;Save some regs
PUSHJ P,SNDLCS ;Send the LCS sequence for loading
MOVE S1,J$FNTL(J) ;Get the name of the list
$CALL L%FIRST ;Point to the first entry
JUMPT LODL.2 ;Go process this entry
$RETT
LODL.1: MOVE S1,J$FNTL(J) ;Get the list of fonts back
$CALL L%NEXT ;NExt font
JUMPT LODL.2 ;All done
PUSHJ P,ENDLOD ;Go end the load sequence
SETOM J$XTOP(J) ;Put us at the top of form
$RETT
LODL.2: MOVE P2,S2 ;Save the address
$CALL L%SIZE ;Size of the entry
CAIE S2,FC.SIZ ;Pointer to font header?
JRST LODL.1 ;User defined font, already loaded
MOVE P2,(P2) ;Get the address of the list header
MOVE S1,FN.FIL(P2) ;Get the file name
PUSHJ P,FNTOPN ;Open the file
$RETIF ;Return if error
MOVE P1,S1 ;Save the IFN
PUSHJ P,LODFNT ;Go load it
$RETIF
$TEXT(LOGCHR##,<^I/LPMSG/Loaded font named ^T20/FN.RNM(P2)/>)
JRST LODL.1 ;And loop for all fonts
SUBTTL Support routines -- FNTOPN - Open font file
; This routine will open the font file whose SIXBIT name is in S1. It will
;return the IFN in S1, or will return false.
FNTOPN: CAMN S1,[-1] ;Internal font file
$RETT ;Yes, make believe it's already loaded
MOVEM S1,FONTFD+.FDNAM ;Store the file for open
MOVEI S1,FOB.SZ ;Get the lenght of the font file FOB
XMOVEI S2,FNTFOB ;And its address
$CALL F%IOPN ;And go get it
JUMPT .RETT ;All fine?
MOVE S1,STREAM## ;Get the stream number
$WTO(<Aborting job>,<Cannot find font file ^F/FNTFOB/>,@JOBOBA##(S1))
$TEXT(LOGCHR##,<^I/LPERR/Job aborted because font named ^T/J$NMTP(J)/ could not be found>)
$RETF ;Give bad return
SUBTTL Support routines -- P/FLUSH - Flush temporary buffer to printer
; This routine will output the temporary buffer area.
;Call FLUSH with last char in C. Call PFLUSH with no char in C, just
;the buffer to be output.
FLUSH: MOVE P2,C ;Save the character
PFLUSH: MOVEI P1,J$CTMP(J) ;Point to the area
HRLI P1,(POINT NAMBYT,) ; to store the characters
FLUSH1: ILDB C,P1 ;Get a character
JUMPE C,FLUSH2 ;Return if done
PUSHJ P,DEVOUT## ;Otherwise output it
JRST FLUSH1 ;And loop for all characters
FLUSH2: MOVE C,P2 ;Get the last character
PUSHJ P,DEVOUT## ;Send it to the printer
$RETF ;Return bad
SUBTTL Support routines -- FNDFNT - Find font file in LPFONT.INI
; This routine will see if the font the user wants exists.
;It will first try to check the incore font cache and then will
;parse the file FNT:LPFONT.INI.
;
; Call: S1/ Address of name
;
; Returns: TRUE/ S1/ Linked list of names set up
; FALSE/ Name could not be found
;
;Temporary AC usage
; P1/ LPFONT.INI IFN
; P2/ Address of name to find
; P3/ Current name list address
; P4/ Flags
FNDFNT: $SAVE <P1,P2,P3,P4> ;Scratch regs
MOVE P2,S1 ;Save the name
SETZ P4, ;Clear any stray flags
MOVEI S1,FOB.SZ ;Get the lenght of the ini file FOB
XMOVEI S2,INIFOB ;And get the address
$CALL F%IOPN ;Open the file
JUMPT FNDF.1 ;Get found it, continue
MOVEI S1,STREAM## ;Get the stream number
$WTO(<Aborting job>,<Cannot find system font name file ^F/INIFOB/>,@JOBOBA##(S1))
$TEXT(LOGCHR##,<^I/LPERR/Job aborted because system font name file could not be found>)
$RETF ;Give bad return
;Here when we found the file. First we see if it has changed
;since we last parsed it. If yes, we reparse it to update our cache.
;If no and we have a cache, we will search through the cache. If we
;find the name, we return it. If we don't find it in the cache, we
;try to find the name in the file by reparsing.
FNDF.1: MOVE P1,S1 ;Save the IFN of the .INI file
SKIPN INIUDT ;Have we ever read LPFONT.INI?
JRST FNDF.2 ;No, force a reread
MOVX S2,FI.CRE ;Say we want creation date
$CALL F%INFO ;Get it
CAMN S1,INIUDT ;Has it changed?
JRST FNDF.3 ;Not updated, no need to rebuild
MOVEM S1,INIUDT ;Remember new time
FNDF.2: PUSHJ P,CRECHC ;Rebuild the font cache
$RETIF ;Propegate error
FNDF.3: PUSHJ P,ICLOSE ;Close the file
MOVE S1,P2 ;Get the address of the name
MOVE S2,FNTLST ;Get the cache list name
PUSHJ P,SRCLST ;Go search the list
JUMPT .RETT ;Return good
MOVE S1,P2 ;Get the address of the name
NOFONT: MOVE S2,STREAM## ;Otherwise we have a problem
$WTO(<Aborting job>,<No such font ^T/(S1)/>,<@JOBOBA##(S2)>)
$TEXT(LOGCHR##,<^I/LPERR/Job aborted because font ^T/(S1)/ does not exist>)
$RETF
;Here we parse the file and (re)build our cache. Note that it expects
;S1 to contain the UDT of the creation date so it can store it.
CRECHC: SKIPE FNTLST ;Old cache?
PUSHJ P,CLRCHC ;Yes, clear it
$CALL L%CLST ;Create a new one
MOVEM S1,FNTLST ;Store it
CREC.1: PUSHJ P,FNTSIX ;Get the file name
JUMPF CIFEOF ;Error, probably end of file
MOVE P4,S1 ;Save the file name
MOVX S2,FN.SIZ ;Else, Get the size of the header entry
MOVE S1,FNTLST ;Get the name of the list
$CALL L%CENT ;Create a header entry
MOVE P3,S2 ;Store its address
MOVEM P4,FN.FIL(P3) ;Store the file name into it
PUSHJ P,FNTNBC ;Get the next non-blank character
CAIN C,"=" ;Seperator?
JRST CREC.2 ;YEs, continue
MOVE S1,STREAM## ;Illegal LPFONT.INI format
$WTO(<Aborting job>,<Illegal character ^7/C/ found in LPFONT.INI>,<@JOBOBA##(S1)>)
$TEXT(LOGCHR##,<^I/LPERR/Job aborted due to error parsing system LPFONT.INI file>)
PUSHJ P,CLRCHC ;Clear the cache to force a reparse
$RETF ;Error return
CREC.2: MOVE S1,P3 ;Get the list header address
PUSHJ P,FNTRNM ;Get the real name out of the line
JUMPF INIERR
JUMPL C,CREC.1 ;End of line, Go parse next line
PUSHJ P,FNTLIN ;Read a logical line of names
JUMPF INIERR ;Error
MOVEM S1,FN.LNM(P3) ;Store the list address
JRST CREC.1 ;Loop for all lines
CIFEOF: CAIN S1,EREOF$ ;We here because of EOF?
$RETT ;Yes, all's well
INIERR: MOVE S2,STREAM## ;Get the stream number
$WTO(<Job error>,<Error while reading LPFONT.INI>,@JOBOBA##(S2))
NOTFOU: PUSHJ P,ICLOSE ;Close the file
$RETF ;But return false
SUBTTL FNTRNM - Extract first name in line in LPFONT.INI
FNTRNM: $SAVE <P2,P3> ;Get some scratch regs
MOVEI P2,FN.RNM(S1) ;Get the place to store the name
HRLI P2,(POINT 7,) ;Get the pointer for it
MOVEI P3,RNMLTH ;Get the number of characters to read
PUSHJ P,FNTNBC ;Get a non-blank character
TRNA ;Already have one
FNTR.1: PUSHJ P,LINCHR ;Get a character
$RETIF ;Bad format
CAIG C," " ;Legal
JRST FNTR.2 ;No,
IDPB C,P2 ;Store it into the buffer
SOJG P3,FNTR.1 ;Loop for all characters
FNTR.2: MOVEI S1," " ;Pad the rest with spaces
IDPB S1,P2 ;Do it
SOJG P3,.-1 ;Loop for all chars
FNTR.3: JUMPL C,.RETT ;EOL means we're done
CAIN C,.CHTAB ;Tab character?
$RETT ;Yes, done with this name
PUSHJ P,LINCHR ;Get a character
$RETIF
JRST FNTR.3 ;Go see if valid
SUBTTL Support routines -- SRCLST - See if named font already loaded
; This routine checks to see if a given font is already loaded into the
;LN01.
;
; Call: S1/ Address of name
; S2/ List name
;
; Return: TRUE/ Pointer to name list header in S1
; FALSE/ Font not loaded
SRCLST: $SAVE <P1,P2,P3,P4> ;Make room
DMOVE P1,S1 ;Save the parameters
PUSHJ P,CIFROM ;Go see if the font is internal
$RETIT ;If yes, we can return now
MOVE S1,P2 ;Get the font list name
$CALL L%FIRST ;Rewind to the first entry
$RETIF ;Not found? No fonts at all then
JRST SRCL.2 ;And go process it
SRCL.1: MOVE S1,P2 ;Get the real name list address
$CALL L%NEXT ;Get the next entry
$RETIF ;No more, font not here
SRCL.2: PUSH P,S2 ;Save the entry address
$CALL L%SIZE ;Get the size
POP P,S1 ;Get back the address of the entry
CAIN S2,FC.SIZ ;Is this pointing to an entry?
MOVE S1,(S1) ;Then entry points to real entry
MOVE S2,S1 ;Also to send to entry searcher
MOVE S1,P1 ;Get the user sent name
PUSHJ P,SRCENT ;Search this entry
JUMPF SRCL.1 ;Else go search the next entry
$RETT ;Return good
SRCENT: $SAVE <P1,P2> ;Save some regs
DMOVE P1,S1 ;Save the inputs
MOVEI S2,FN.RNM(S2) ;Get the address of the real name
PUSHJ P,CIFRNM ;See if it is the real name
JUMPT SRCE.1 ;It is loaded, return good
SKIPN S2,FN.LNM(P2) ;Get the list of font names
$RETF ;None for this, return false
MOVE S1,P1 ;Get back the user name
PUSHJ P,SRCPLS ;Search the pseudoname list
$RETIF ;Not found
SRCE.1: MOVE S1,P2 ;Get the entry address
$RETIT ;Found
;Here to search through a list of pseudonames.
SRCPLS: $SAVE <P1,P2> ;Get a scratch reg
DMOVE P1,S1 ;Save the list address
MOVE S1,P2 ;Get the name of the pseudoname chain
$CALL L%FIRST ;Rewind to the first entry
JRST SRCL21 ;Go process it
SRCL20: MOVE S1,P2 ;Get the name of our chain
$CALL L%NEXT ;Next name
$RETIF ;Not here
SRCL21: MOVE S1,P1 ;Get the address of the user name
MOVEI S2,FM.NAM(S2) ;Get the address of the pseudo name
PUSHJ P,CIFPNM ;See if this is a pseudoname
$RETIT ;Yes, return it
JRST SRCL20 ;Otherwise, try next name
$RETT
SUBTTL CIFROM - Check for fonts in ROM
SRCROM: $SAVE P1 ;Place for S1
SKIPA P1,S1 ;Save S1 for portrait check
CIFROM: MOVE S1,P1 ;Get the name sent
MOVEI S2,LNDROM+FN.RNM ;And the name to check
PUSHJ P,CIFRNM ;Se if the desired name
JUMPF ROM.1 ;Wasn't
MOVEI S1,LNDROM ;Was, return address of block
$RETT
ROM.1: MOVE S1,P1 ;Get user font
MOVEI S2,PRTROM+FN.RNM ;Get the portrait font
PUSHJ P,CIFRNM ;Names the same
$RETIF
MOVEI S1,PRTROM ;Return the name
$RETT
LNDROM: EXP 0 ;No pseudoname list
ASCII |DELandscape13.6-@ | ;Name
EXP -1 ;No file flag
EXP -1 ;No lenght flag
EXP -1 ;Landscape font
PRTROM: EXP 0 ;No pseudoname list
ASCII |DETitan10-R | ;Name
EXP -1 ;No file flag
EXP -1 ;No lenght
EXP 0 ;Not Landscape flag
SUBTTL Support routines -- CIFRNM/CIFPNM - See if real/pseudo names
; These routines will compare two names whose address are sent to them in
;S1 and S2, and will see if they are alike. The difference between the two
;is that CIFRNM will only check 4 words worth of name (although it checks to
;make sure the last two words of the user name are 0), and CIFPNM will
;check for 6 words worth of data.
;
; Call: S1/ Address of user name
; S2/ Address of possible real name
;
; Returns: TRUE/ If names match
; FALSE/ Otherwise
CIFRNM: MOVEI TF,RNMLTH ;Get the number of words to check
TRNA ;And go check them
CIFPNM: MOVEI TF,NAMLTH ;Get the lenght of a long name
$SAVE <P1> ;Save a scratch reg
HRLI S1,(POINT 7,) ;Build byte pointers
HRLI S2,(POINT 7,)
CIFP.1: ILDB C,S1 ;Get a word from the user name
ILDB P1,S2 ;Is it different from what we have
CAME C,P1 ;Characters the same
JRST CIFP.2 ;No, go see about trailing spaces
SOJG TF,CIFP.1 ;Else loop over all characters
$RETT ;If we get here, names match
CIFP.2: JUMPN C,.RETF ;User name must be exhausted
CIFP.3: CAIE P1," " ;The rest of font name must be spaces
$RETF
SOJLE TF,.RETT ;Characters exhausted return good
ILDB P1,S2 ;Get next character in font name
JUMPE P1,.RETT ;Null is the end
JRST CIFP.3 ;Else go check this char
SUBTTL Support routines -- GETNAM - Get font name from ACS sequence
; This routine is used to get the font name out of the ACS sequence in
;the user's print file. It will read until an escape delimits the name,
;but it will only keep the first FNMLTH (30) characters as remembered.
;
; Call: S1/ Address of place to store name
;
; Return: TRUE/ Name stored
; FALSE/ Error reading file
GETNAM: $SAVE <P1,P2> ;Save some regs
MOVE P1,S1 ;Save the address
SETZM (P1) ;Clear out any old names
HRL S1,S1 ;Build a BLT pointer to do it
AOS S1 ; . . .
BLT S1,FNMLTH(P1) ;Clear it out
HRLI P1,(POINT NAMBYT,) ;Build a byte pointer to storage
MOVEI P2,NAMLTH ;Get the number of characters
GETN.1: PUSHJ P,FILBYT ;Get a character
$RETIF ;Return now
CAIN C,.CHESC ;Escape character delimiter?
JRST GETN.2 ;Yes, return now
SOSLE P2 ;Count chars read. Past name lenght?
IDPB C,P1 ;No, so store it away
JRST GETN.1 ;Loop until delimiter
GETN.2: PUSHJ P,FILBYT ;Next character
$RETIF
CAIE C,"\" ;Real delimiter?
JRST GETN.1 ;No, keep on looping
$RETT ;Yes, retunr good
SUBTTL Support routines -- EATFNT - Eat font until terminator
; This routine is to be called when we can't trust the font record
;to be a valid font. We therefore dump the record into the printer,
;looking for the valid terminator sequence (ESC \)
EATFNT: PUSHJ P,FILBYT ;Get a byte
$RETIF ;No good
CAIN C,.CHESC ;End of load?
JRST ENDLCS ;Yes, go end it
PUSHJ P,DEVOUT## ;Type it out
JRST EATFNT ;And continue to look fo delimiter
ENDLCS: PUSHJ P,FILBYT ;Next character
CAIE C,"\" ;What we're looking for?
PUSHJ P,DEVOUT## ;No, Type it out (We don't presume to
;Get too much in the user's way)
$RETT ;Else, return without outputting it
SUBTTL Support routines -- CLRCHC - Clear cached font information
; This routine takes the font information that is built into the
;linked list at request time, and deletes it from memory. It is to be
;used primarily before new fonts are to be loaded.
CLRCHC: SKIPN S1,FNTLST ;Get the cache header
$RETT ;Return now
CLRLST: $SAVE P1 ;Save a reg
MOVE P1,S1 ;Save the list name
$CALL L%FIRST ;Point to the first
$RETIF ;Return if none
CLRF.1: SKIPE S1,FN.LNM(S2) ;Get the list of names it is known by
$CALL L%DLST ;And get rid of it
MOVE S1,(P1) ;Get back the name
$CALL L%NEXT ;Get the next
JUMPT CLRF.1 ;Loop for all entries
MOVE S1,P1 ;Get back the main list of fonts
$CALL L%DLST ;And get rid of it also
POPJ P, ;Return
$RETT
SUBTTL LODFNT - Load and parse font file
; This routine will load a font file from FNT: and will parse it
; to determine the correct (20 character) font name, so that the
; caller can know the 'physical' name of the file he is loading for
; the Assign Character Set sequence.
;
; Call: P1/ Font file IFN
;
; Return:
; True/ Font file loaded ok
;
; False/ Error code in S1
; Message already given
LODFNT: PUSHJ P,FNTBYT ;Get a byte
JUMPF LDFN.3 ;Error, go find out why
PUSHJ P,DEVOUT## ;Send out this byte
JRST LODFNT ;Loop for whole file
LDFN.3: CAXE S1,EREOF$ ;End of file?
JRST FNTERR ;No, go return the bad news
ICLOSE: MOVE S1,P1 ;Get the IFN for the font file
$CALL F%REL ;Close the file
$RETT ;Return good
FNTERR: MOVE S2,STREAM## ;Get the stream number
$WTO(<Aborting job>,<Error ^E/S1/ reading font file ^F/FNTFOB/>,@JOBOBA##(S2))
$TEXT(LOGCHR##,<^I/LPERR/Job aborted due to error reading font file ^F/FNTFOB/>)
PUSHJ P,ICLOSE ;Close the file
$RETF ;But return false
SUBTTL Font input routines
; These routines will be used to return values from the font file.
;
; Call: P1/ File IFN
;
; Return:
; True/ Character or quantity in C
; False/ Error code in S1
;
SUBTTL Font input routines -- FNTLIN - Read line from LPFONT.INI
; This routine will read a logical line from LPFONT.INI and will
;build a list of pseudonames suitable for being linked into the FN.LNM
;field of the header block. It will return the name of the list in S1.
FNTLIN: $SAVE <P1,P2,P3,P4> ;Save some registers
$CALL L%CLST ;Assume we will have a list
MOVE P2,S1 ;Save it from destruction
LIN.1: PUSHJ P,FNTNBC ;Get the next non-blank character
JUMPF LIN.6 ;Bad return, clean up and return
JUMPL C,LIN.5 ;If EOL go return the name of the list
MOVE S1,P2 ;Get the name of the list
MOVEI S2,FNMLTH ;And lenght of pseudonames
$CALL L%CENT ;Create an entry
MOVE P4,S2 ;Save the entry address
HRLI P4,(POINT NAMBYT,) ;Make it a byte pointer
MOVEI P3,NAMLTH ;Get the max number of characters
LIN.3: IDPB C,P4 ;Store this character
PUSHJ P,LINCHR ;Get next valid line character
JUMPF LIN.6 ;Error, destroy partial list and return
JUMPL C,LIN.5 ;Negative is eol,,go return
CAIN C,.CHTAB ;Delimiter?
JRST LIN.1 ;Yes, go store name in the list
SOJG P3,LIN.3 ;Loop for maximum characters
LIN.4: PUSHJ P,LINCHR ;Eat the characters until delimiter
JUMPF LIN.6 ;Error, go clean up
CAIN C,.CHTAB ;Delimiter?
JRST LIN.1 ;Yes, try for another name
JUMPGE C,LIN.4 ;Non-EOL, loop for more characters
LIN.5: MOVE S1,P2 ;Else return the name of the list
$RETT
LIN.6: SKIPE S1,P2 ;Get the name of the list
$CALL L%DLST ;destroy it
$RETT
LINCHR: PUSHJ P,FNTBYT ;Get a character
$RETIF ;Bad return if bad
CAIL C," " ;Control character?
$RETT ;No, return now
CAIN C,.CHTAB ;A delimiter?
$RETT ;Yes, this name is done
CAIE C,.CHCRT ;Another type of delimiter?
$RETT ;No, normal characters
PUSHJ P,FNTBYT ;Get the line feed
$RETIF
SETO C, ;Make the EOL flag
$RETT ;Return
SUBTTL Font input routines -- GET2BY - Get 2 bytes in word format
GET2BY: PUSHJ P,GETBYT ;Get a byte
$RETIF ;Shouldn't ...
PUSH P,C ;Save the byte
PUSHJ P,GETBYT ;Get the high order byte
JUMPF GET2.1 ; ... happen
ASH C,8 ;Make room for low order byte
ADD C,(P) ;Add it in
GET2.1: POP P,(P) ;Throw away
$RETT
SUBTTL Font input routines -- GETBYT - Get byte from SIXELed stream
; This routine will read a sixeled character from the give input stream
;setup in J$NMIF and will build a binary byte from it depending on how
;far it is in the byte reading process. It will also output the byte to the
;output device directly to keep the data stream synchronous.
GETBYT: SOSLE J$BCT8(J) ;Attempt to get already translated byte
JRST GETBYD ;Got one
$SAVE <P1,P2,P3> ;Save some regs
SETZM J$BYT8(J) ;Clear destination word
MOVEI P2,^D3 ;Number of bytes left over
MOVEM P2,J$BCT8(J) ;Stash
MOVE P2,[POINT 6,J$BYT8(J)] ;Point to destination
MOVEI P3,^D4 ;Get 4 bytes
GETBY1: PUSHJ P,FILBYT ;Get the next character
$RETIF
CAIGE C,77 ;Improper character?
JRST GETBY1 ;Yes, this doesn't count
PUSH P,C ;Save it
PUSHJ P,DEVOUT## ;Type it to the printer
POP P,C ;Restore it for use
SUBI C,77 ;Convert to six bits
IDPB C,P2 ;Stash byte
SOJG P3,GETBY1 ;And loop
GETBYD: MOVE S2,J$BYT8(J) ;Get the bytes
SETZ S1, ;Clear destination word
LSHC S1,^D8 ;Get a byte
MOVEM S2,J$BYT8(J) ;And stash leftover
MOVE C,S1 ;Return it in the proper register
$RETT
SUBTTL Font input routines -- FNTSIX - Input a SIXBIT quantity
FNTSIX: $SAVE <P1,P2,P3,P4> ;Save some regs
MOVE P3,[POINT 6,P4] ;Build a pointer to where it belongs
MOVEI P2,6 ;Get the number of chars to read
SETZ P4, ;And clear the place to store them
PUSHJ P,FNTNBC ;Get non-blank byte to start with
JUMPT SIX.2 ;If valid, go process character
$RETIF ;Else return error
SIX.1: PUSHJ P,FNTBYT ;Get a byte from the file
$RETIF ;Return false on error
SIX.2: CAIE C," " ;A valid delimiter?
CAIN C,.CHTAB ; . . .
JRST RETSIX ;Done, go return the value
CAIN C,"=" ;This is also a delimiter
JRST RETSVC ;If this then done (endif)
SUBI C,"A"-'A' ;Convert character to SIXBIT
IDPB C,P3 ;Store it into the word
SOJGE P2,SIX.1 ;Loop for all characters in the name
MOVE S1,STREAM## ;Wrong format if we get here
$WTO(<Aborting job>,<Error parsing FNT:LPFONT.INI. File name too long>,<@JOBOBA##(S1)>)
$TEXT(LOGCHR##,<^I/LPERR/Job aborted due to system error. (Parsing LPFONT.INI file)>)
$RETF ;Return false if too long
RETSVC: PUSHJ P,BACKUP ;Back up this character
RETSIX: MOVE S1,P4 ;Here to return the file name
$RETT ;Return true
SUBTTL Font input routines -- FNTWRD - Input a word
FNTWRD: PUSHJ P,FNTBYT ;Get a byte
$RETIF ;Error
PUSH P,C ;Save the value
PUSHJ P,FNTBYT ;Get the most significant byte
JUMPF WRD.1 ;Error, go clean up stack
LSH C,8 ;Shift value to most significant byte
ADD C,(P) ;Add the least significant bits
POP P,(P) ;adjust the stack
$RETT ;Return good
WRD.1: POP P,(P) ;Adjust the stack
$RETF ;Return error code
SUBTTL Font input routines -- FNTNBC - Get next non-blank character
FNTNBC: PUSHJ P,FNTBYT ;Get the next character out of the file
$RETIF ;Error?
CAIE C," " ;A space
CAIN C,.CHTAB ;or tab?
JRST FNTNBC ;Yes, don't return it
$RETT ;Else return it
Subttl Font input routines -- BACKUP - Backup a character
BACKUP: MOVEM C,J$SVCH(J) ;Store this character away
$RETT ;And return
SUBTTL Font input routines -- FNTBYT - Input a byte
FNTBYT: SETZ C, ;Make a zero
EXCH C,J$SVCH(J) ;Get the last character
JUMPN C,.RETT ;There was one, go return it
BYT.0: SOSGE J$FCNT(J) ;Any characters in the buffer?
JRST BYT.1 ;Yes, go get one
ILDB C,J$FBTP(J) ;Get the character
$RETT
BYT.1: MOVE S1,P1 ;Otherwise, get the IFN
$CALL F%IBUF ;Get a buffer full
$RETIF ;Error, return now
DMOVEM S1,J$FCNT(J) ;Store count and byte pointer
AOS J$ADRD(J) ;Increment number of blocks read
JRST BYT.0 ;And try again
FILBYT: SETZ C, ;Make a zero
EXCH C,J$SVCH(J) ;Get the last character
JUMPN C,.RETT ;There was one, go return it
JRST INPBYT## ;Ask for another character
SUBTTL Literal pool
L01LIT: LIT
SUBTTL End of LPTL01
L01END::!END