(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Sep-88 18:56:59" {PHYLUM}<LISP>LYRIC>PATCHES>TEDITHARDCOPYPATCH.;3 17071
changes to%: (VARS TEDITHARDCOPYPATCHCOMS)
previous date%: " 1-Sep-88 16:53:26" {PHYLUM}<LISP>LYRIC>PATCHES>TEDITHARDCOPYPATCH.;1)
(* "
Copyright (c) 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TEDITHARDCOPYPATCHCOMS)
(RPAQQ TEDITHARDCOPYPATCHCOMS
(
(* ;; "Patch TEdit Hardcopy so it doesn't get into an infinite loop when the formatting fns shrink the TEXTLEN out from under it.")
[DECLARE%: FIRST (P (if (NOT (STRING-EQUAL MAKESYSNAME 'LYRIC))
then
(ERROR (CONCAT "You shouldn't be loading this patch into the "
MAKESYSNAME " release of Lisp. ↑ out of this break"]
(FNS TEDIT.FORMAT.HARDCOPY TEDIT.FORMATBOX TEDIT.FORMATTEXTBOX)))
(* ;;
"Patch TEdit Hardcopy so it doesn't get into an infinite loop when the formatting fns shrink the TEXTLEN out from under it."
)
(DECLARE%: FIRST
(if (NOT (STRING-EQUAL MAKESYSNAME 'LYRIC))
then (ERROR (CONCAT "You shouldn't be loading this patch into the " MAKESYSNAME
" release of Lisp. ↑ out of this break")))
)
(DEFINEQ
(TEDIT.FORMAT.HARDCOPY
(LAMBDA (STREAM FILE DONTSEND BREAKPAGETITLE SERVER PRINTOPTIONS IMAGETYPE FIRSTPG#) (* ; "Edited 1-Sep-88 16:48 by bvm:") (* ;;; "Format a document for hardcopy") (RESETLST (PROG ((TEXTOBJ (TEXTOBJ STREAM)) (FORCENEXTPAGE NIL) (FORMATTINGSTATE (create PAGEFORMATTINGSTATE PAGE# ← (COND ((NUMBERP FIRSTPG#)) (T NIL)) FIRSTPAGE ← T STATE ← FIRSTPG# MINPAGE# ← NIL MAXPAGE# ← 65535 CHNO ← 1 PAGEHEADINGS ← (LIST NIL NIL) PAGE#GENERATOR ← (AND (LISTP FIRSTPG#) (CDR FIRSTPG#)) PAGE#TEXT ← (AND (LISTP FIRSTPG#) (CAR FIRSTPG#)))) THISLINE LINE REGION LINES NCHNO PRSTREAM PAGEFRAMES SCRATCHFILE WASOPEN BEFOREFN AFTERFN) (SETQ PAGEFRAMES (OR (fetch TXTPAGEFRAMES of TEXTOBJ) TEDIT.PAGE.FRAMES)) (COND ((LISTP PAGEFRAMES) (* ; "If it's a list, pack it into a real set of specs.") (SETQ PAGEFRAMES (TEDIT.COMPOUND.PAGEFORMAT (CAR PAGEFRAMES) (CADR PAGEFRAMES) (CADDR PAGEFRAMES))))) (SETQ THISLINE (fetch THISLINE of TEXTOBJ)) (replace PRESSREGION of FORMATTINGSTATE with TEDIT.DEFAULTPAGEREGION) (* ; "Print in the usual region on the page") (SETQ BREAKPAGETITLE (COND (BREAKPAGETITLE) ((LISTGET PRINTOPTIONS (QUOTE DOCUMENT.NAME))) ((OR (NOT (fetch TXTFILE of TEXTOBJ)) (type? STRINGP (fetch TXTFILE of TEXTOBJ)) (type? STREAM (fetch FULLNAME of (fetch TXTFILE of TEXTOBJ))) (type? STRINGP (fetch FULLNAME of (fetch TXTFILE of TEXTOBJ)))) (* ; "This isn't a real file, so print a generic name on the document break page.") "TEdit Hardcopy Output") (T (* ; "It's a real file, so use the file name on the break page.") (fetch FULLNAME of (fetch TXTFILE of TEXTOBJ))))) (SETQ BEFOREFN (TEXTPROP TEXTOBJ (QUOTE BEFOREHARDCOPYFN))) (COND (BEFOREFN (* ; "Let the guy do any pre-hardcopy processing he wants to do") (COND ((EQ (QUOTE DON'T) (APPLY* BEFOREFN TEXTSTREAM TEXTOBJ)) (* ; "If it says not to do the hardcopy, then don't.") (RETURN))))) (SETQ SCRATCHFILE (OR FILE (PRINTER.SCRATCH.FILE (TEXTSTREAM STREAM)))) (RESETLST (SETQ AFTERFN (TEXTPROP TEXTOBJ (QUOTE AFTERHARDCOPYFN))) (AND AFTERFN (RESETSAVE NIL (LIST AFTERFN TEXTSTREAM))) (* ; "Set up to do the user's cleanup on the way out, as well.") (TEDIT.PROMPTPRINT TEXTOBJ "Formatting for print..." T) (COND ((AND FILE (OPENP FILE) (IMAGESTREAMTYPE FILE)) (* ; "The file he handed us is already an image-type file. Just append the new stuff to it.") (SETQ WASOPEN T) (SETQ PRSTREAM FILE)) (T (* ; "T'wasn't an image stream, so let's open us one.") (RESETSAVE (SETQ PRSTREAM (OPENIMAGESTREAM SCRATCHFILE (OR IMAGETYPE (SETQ IMAGETYPE (CAR (PRINTERPROP (PRINTERTYPE SERVER) (QUOTE CANPRINT))))) (LIST (QUOTE FONT) (FONTCREATE (QUOTE GACHA) 10) (QUOTE BREAKPAGEFILENAME) BREAKPAGETITLE))) (QUOTE (AND RESETSTATE (DELFILE (CLOSEF? OLDVALUE))))))) (* ; "So we close and delete the file in case of trouble.") (STREAMPROP PRSTREAM (QUOTE FORMATTINGSTATE) FORMATTINGSTATE) (* ; "So that subsidiary people can find out the state of the formatting.") (DSPRIGHTMARGIN 65535 PRSTREAM) (while (ILEQ (fetch CHNO of FORMATTINGSTATE) (fetch TEXTLEN of TEXTOBJ)) do (for REGION inside PAGEFRAMES do (TEDIT.FORMATBOX TEXTOBJ PRSTREAM (fetch CHNO of FORMATTINGSTATE) REGION FORMATTINGSTATE IMAGETYPE))) (COND ((NOT WASOPEN) (* ; "Only if we created the image stream should we close it.") (SETQ PRSTREAM (CLOSEF PRSTREAM)) (OR DONTSEND (SEND.FILE.TO.PRINTER PRSTREAM SERVER (APPEND PRINTOPTIONS (LIST (QUOTE DOCUMENT.NAME) BREAKPAGETITLE)))))) (OR FILE (DELFILE SCRATCHFILE))) (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (MKSTRING (fetch (PAGEFORMATTINGSTATE PAGECOUNT) of FORMATTINGSTATE)) "pg done.")))))
)
(TEDIT.FORMATBOX
(LAMBDA (TEXTOBJ PRSTREAM CH# REGION FORMATTINGSTATE SERVERTYPE) (* ; "Edited 1-Sep-88 16:50 by bvm:") (* ;; "Grab text from the TEXTOBJ, starting with CH#, and use it to fill REGION on a page. Return a list of line descriptors which, taken together, fill the region.") (PROG ((REGIONSPEC (fetch (PAGEREGION REGIONSPEC) of REGION)) CHNO NCHNO LINES SUBREGIONSPEC) (SELECTQ (fetch REGIONFILLMETHOD of REGION) (TEXT (* ; "A normal text region. Fill it with text formatted the usual way.") (COND ((\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) (* ; "Only format if we're not looking for something else.") (SETQ LINES (TEDIT.FORMATTEXTBOX TEXTOBJ PRSTREAM CH# REGION FORMATTINGSTATE))))) (FOLIO (* ; "A Page Number. Fill it in according to the instructions") (COND ((\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) (* ; "Only format if we're not looking for something else.") (SETQ LINES (TEDIT.FORMATFOLIO TEXTOBJ PRSTREAM FORMATTINGSTATE REGION))))) (HEADING (* ; "A Page heading. Fill it in from a text source we saved for the occasion.") (COND ((\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) (* ; "Only format if we're not looking for something else.") (SETQ LINES (TEDIT.FORMATHEADING TEXTOBJ PRSTREAM FORMATTINGSTATE REGION))))) (PAGE (* ;; "This box is really a PAGE FRAME. Fill it in and do whatever other processing is needful for end of page.") (SETQ LINES NIL) (* ; "This will send along its own lines to the printer.") (\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) (* ; "So that if this is the box he's looking for, we'll spot it and stop searching") (TEDIT.FORMATPAGE TEXTOBJ PRSTREAM CH# REGION FORMATTINGSTATE)) ((RECURSIVE SEQUENCE ALTERNATE SELECTION REPEAT) (* ; "This box is really a list of boxes. Fill them.") (\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) (* ; "So that if this is the box he's looking for, we'll spot it and stop searching") (SELECTQ (fetch REGIONFILLMETHOD of REGION) ((SEQUENCE RECURSIVE) (* ; "Just run thru filling in the sub-boxes in order.") (bind SUBREGIONSPEC for SUBREGION in (fetch (PAGEREGION REGIONSUBBOXES) of REGION) while (ILEQ (fetch (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE) (fetch TEXTLEN of TEXTOBJ)) do (SETQ SUBREGIONSPEC (create REGION using (fetch REGIONSPEC of SUBREGION) LEFT ← (IPLUS (fetch LEFT of (fetch REGIONSPEC of SUBREGION)) (fetch LEFT of REGIONSPEC)) BOTTOM ← (IPLUS (fetch BOTTOM of (fetch REGIONSPEC of SUBREGION)) (fetch BOTTOM of REGIONSPEC)))) (TEDIT.FORMATBOX TEXTOBJ PRSTREAM (fetch (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE) (create PAGEREGION using SUBREGION REGIONSPEC ← SUBREGIONSPEC) FORMATTINGSTATE))) (ALTERNATE (* ; "Run through the sub-boxes repeatedly in sequence.") (while (ILEQ (fetch (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE) (fetch TEXTLEN of TEXTOBJ)) do (bind SUBREGIONSPEC for SUBREGION in (fetch (PAGEREGION REGIONSUBBOXES) of REGION) while (ILEQ (fetch (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE) (fetch TEXTLEN of TEXTOBJ)) do (SETQ SUBREGIONSPEC (create REGION using (fetch REGIONSPEC of SUBREGION) LEFT ← (IPLUS (fetch LEFT of (fetch REGIONSPEC of SUBREGION)) (fetch LEFT of REGIONSPEC)) BOTTOM ← (IPLUS (fetch BOTTOM of (fetch REGIONSPEC of SUBREGION)) (fetch BOTTOM of REGIONSPEC)))) (TEDIT.FORMATBOX TEXTOBJ PRSTREAM (fetch (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE) (create PAGEREGION using SUBREGION REGIONSPEC ← SUBREGIONSPEC) FORMATTINGSTATE)))) (SELECTION (* ; "Do one or another box, depending on some criterion.")) (SHOULDNT)) (* ; "For now, draw a box around it, too.")) NIL) (for LINE in LINES when LINE do (* ; "Run thru the lines displaying them all.") (BLOCK) (COND ((OR (NOT (fetch (PAGEFORMATTINGSTATE MINPAGE#) of FORMATTINGSTATE)) (IGEQ (fetch (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE) (fetch (PAGEFORMATTINGSTATE MINPAGE#) of FORMATTINGSTATE))) (* ; "We're beyond the min page number -- go ahead and print the line") (\TEDIT.HARDCOPY.DISPLAYLINE (fetch (TEXTSTREAM TEXTOBJ) of (fetch LTEXTOBJ of LINE)) LINE (fetch CACHE of LINE) REGION PRSTREAM))) (COND ((EQ TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of (fetch LTEXTOBJ of LINE))) (* ; "This line refers back to the main text, so update the current-char pointer.") (SETQ CHNO (ADD1 (fetch CHARLIM of LINE))))) (push (fetch (PAGEFORMATTINGSTATE PAGELINECACHE) of FORMATTINGSTATE) LINE) (replace LTEXTOBJ of LINE with NIL)) (COND (CHNO (replace (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE with CHNO)))))
)
(TEDIT.FORMATTEXTBOX
(LAMBDA (TEXTOBJ PRSTREAM CH# PAGEREGION FORMATTINGSTATE) (* ; "Edited 1-Sep-88 16:50 by bvm:") (* ;; "Grab text from the TEXTOBJ, starting with CH#, and use it to fill REGION on a page. Return a list of line descriptors which, taken together, fill the region.") (PROG* ((CHNO CH#) (REGION (for VALUE in (fetch (PAGEREGION REGIONSPEC) of PAGEREGION) collect (FIXR (FTIMES (DSPSCALE NIL PRSTREAM) VALUE)))) (COLUMNBOTTOM (fetch BOTTOM of REGION)) (FIRSTLINE T) (BREAKAFTERLASTPARA NIL) (STREAMSCALE (DSPSCALE NIL PRSTREAM)) (FORCENEXTPAGE NIL) (FOOTNOTELINES NIL) (PAGEFOOTNOTES NIL) THISLINE LINE YBOT LINES ORPHAN LASTLINE PREVLINE LHEIGHT FMTSPEC SPECIALYPOS NEWPAGETYPE) (SETQ FOOTNOTELINES (fetch PAGEFOOTNOTELINES of FORMATTINGSTATE)) (* ; "Account for lines carried over from prior columns") (while (AND (ILEQ COLUMNBOTTOM (fetch (REGION TOP) of REGION)) (SETQ LINE (pop FOOTNOTELINES))) do (* ; "Move as many potential footnote lines into this column as will fit.") (add COLUMNBOTTOM (fetch LHEIGHT of LINE)) (* ; "And move the bottom of the column up to account for them") (COND ((IGREATERP COLUMNBOTTOM (fetch (REGION TOP) of REGION)) (* ; "If we ran out of room for footnotes, put this line back on the queue") (push FOOTNOTELINES LINE)) (T (SETQ PAGEFOOTNOTES (NCONC1 PAGEFOOTNOTES LINE))))) (replace PAGEFOOTNOTELINES of FORMATTINGSTATE with FOOTNOTELINES) (* ; "Remember any remaining footnotes") (SETQ LINES (while (AND (ILEQ CHNO (fetch TEXTLEN of TEXTOBJ)) (NOT FORCENEXTPAGE)) collect (SETQ LINE (OR (pop (fetch (PAGEFORMATTINGSTATE PAGELINECACHE) of FORMATTINGSTATE)) (create LINEDESCRIPTOR))) (* ; "Grab a line descriptor from the recycling list, or create a new one.") (SETQ THISLINE (OR (fetch (LINEDESCRIPTOR CACHE) of LINE) (create THISLINE))) (* ; "And a recycled or new THISLINE cache for char widths &c") (BLOCK) (* ; "Allow other things to happen while we format....") (SETQ FORCENEXTPAGE (\TEDIT.HARDCOPY.FORMATLINE TEXTOBJ (fetch (REGION WIDTH) of REGION) CHNO THISLINE LINE PRSTREAM)) (* ; "Format the line, noting any form-feeds") (COND ((fetch LMARK of LINE) (* ;; "This line is a placeholder for a page heading. All it tells us is what character to skip to so we can continue.") (SETQ CHNO (ADD1 (fetch CHARLIM of LINE))) NIL) ((LISTGET (fetch FMTUSERINFO of (fetch LFMTSPEC of LINE)) (QUOTE FOOTNOTE)) (* ; "This paragraph is a footnote para.") (SETQ FOOTNOTELINES (\TEDIT.FORMAT.FOOTNOTE TEXTOBJ LINE)) (* ; "Grab the lines of this footnote") (for LINE in FOOTNOTELINES as CL:REST on FOOTNOTELINES do (add COLUMNBOTTOM (fetch LHEIGHT of LINE)) (COND ((IGREATERP COLUMNBOTTOM (OR YBOT (fetch (REGION TOP) of REGION))) (replace PAGEFOOTNOTELINES of FORMATTINGSTATE with (APPEND (fetch PAGEFOOTNOTELINES of FORMATTINGSTATE) CL:REST)))))) (T (* ; "This line must not represent a special item, e.g. a page heading. If it does, ignore it.") (replace CACHE of LINE with THISLINE) (* ; "Mark this line as having cached print info.") (replace LTEXTOBJ of LINE with (fetch STREAMHINT of TEXTOBJ)) (* ; "And remember the document it came from.") (SETQ FMTSPEC (fetch LFMTSPEC of LINE)) (add (fetch LEFTMARGIN of LINE) (OR (AND (fetch FMTSPECIALX of FMTSPEC) (NOT (ZEROP (fetch FMTSPECIALX of FMTSPEC))) (fetch FMTSPECIALX of (fetch LFMTSPEC of LINE))) (fetch LEFT of REGION))) (* ; "Format the next possible line") (SETQ SPECIALYPOS NIL) (* ;; "So that only the first line of a specially-placed paragraph is guaranteed to appear in the current box.") (COND ((AND (fetch FMTSPECIALY of FMTSPEC) (NOT (ZEROP (fetch FMTSPECIALY of FMTSPEC))) (fetch 1STLN of LINE)) (* ; "There is a special Y location for this paragraph. Move there") (SETQ SPECIALYPOS (SETQ YBOT (fetch FMTSPECIALY of FMTSPEC)))) (YBOT (* ; "We're into it; take account of this line's height") (COND ((fetch FMTBASETOBASE of FMTSPEC) (SETQ LHEIGHT (IPLUS (fetch DESCENT of LINE) (fetch FMTBASETOBASE of FMTSPEC) (COND ((fetch 1STLN of LINE) (IPLUS (OR (fetch LEADBEFORE of FMTSPEC) 0) (OR (fetch LEADAFTER of (fetch LFMTSPEC of PREVLINE)) 0))) (T 0)))) (SETQ YBOT (IDIFFERENCE (fetch YBASE of PREVLINE) LHEIGHT))) (T (SETQ YBOT (IDIFFERENCE YBOT (fetch LHEIGHT of LINE)))))) (T (* ; "Just starting out; find the line's position with respect to the top of the region to be filled.") (SETQ YBOT (IDIFFERENCE (fetch (REGION TOP) of REGION) (IPLUS (fetch LTRUEASCENT of LINE) (fetch DESCENT of LINE)))))) (COND ((AND (ILESSP YBOT COLUMNBOTTOM) (NOT SPECIALYPOS)) (* ;; "This line hangs off the bottom; (and isn't the first line of a specially-placed paragraph) punt it.") (SETQ FORCENEXTPAGE T) (SETQ ORPHAN LINE) (* ; "Remember this potential orphan") NIL) ((AND (NOT FIRSTLINE) (fetch 1STLN of LINE) (SETQ NEWPAGETYPE (OR (fetch FMTNEWPAGEBEFORE of (fetch LFMTSPEC of LINE)) BREAKAFTERLASTPARA))) (* ; "We're supposed to put this line at the start of a new page/column (any box, later)") (SETQ FORCENEXTPAGE (QUOTE USERBREAK)) (SETQ ORPHAN NIL) (COND ((NEQ NEWPAGETYPE T) (* ; "This isn't simply go to a new box; we need to set up the search for it.") (replace (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE with (QUOTE SEARCHING)) (replace (PAGEFORMATTINGSTATE REQUIREDREGIONTYPE) of FORMATTINGSTATE with NEWPAGETYPE))) NIL) (T (* ; "This line is good; use it.") (COND ((AND (fetch FMTNEWPAGEAFTER of (fetch LFMTSPEC of LINE))) (* ; "We're supposed to put this line at the start of a new page/column (any box, later)") (SETQ BREAKAFTERLASTPARA T))) (replace YBOT of LINE with YBOT) (replace YBASE of LINE with (IPLUS YBOT (fetch DESCENT of LINE))) (SETQ FIRSTLINE NIL) (* ; "Note that we have put text out on this page/column/box, for first line checking.") (SETQ CHNO (ADD1 (fetch CHARLIM of LINE))) (* ; "Keep track of the next character...") (SETQ PREVLINE LINE) LINE)))))) (SETQ LINES (DREMOVE NIL LINES)) (* ; "Remove any NILs from the line list; they're artifacts of running across page headings in-stream") (COND (LINES (* ; "Only worry about widows and orphans if there are really lines to worry about") (SETQ LASTLINE (CAR (FLAST LINES))) (* ; "Find the last line in this box (column or page)") (COND ((AND ORPHAN (fetch LSTLN of ORPHAN) (NOT (fetch 1STLN of ORPHAN))) (* ;; "There was an overhanging line, and it was the last line of the paragraph. Remove the penultimate line.") (DREMOVE LASTLINE LINES) (SETQ LASTLINE (CAR (FLAST LINES))))) (COND ((AND LASTLINE (fetch 1STLN of LASTLINE) (NOT (fetch LSTLN of LASTLINE)) (ILESSP (fetch CHARLIM of LASTLINE) (fetch TEXTLEN of TEXTOBJ))) (* ; "The last line on the page is a widow. Remove it, too.") (DREMOVE LASTLINE LINES) (SETQ LASTLINE (CAR (FLAST LINES))))) (COND ((AND (NEQ FORCENEXTPAGE (QUOTE USERBREAK)) (ILEQ CHNO (fetch TEXTLEN of TEXTOBJ))) (* ;; "Only do widow/orphan detection if this is NOT a page break the user asked for. And this isn't the end of the document.") (for LASTLINE in (REVERSE LINES) while (fetch FMTHEADINGKEEP of (fetch LFMTSPEC of LASTLINE)) do (* ;; "Run thru, removing any trailing headings. However, assure that there's at least one line on a page.") finally (COND ((AND LASTLINE (NOT (fetch FMTHEADINGKEEP of (fetch LFMTSPEC of LASTLINE)))) (* ;; "OK we found a line that DOESN'T need to be kept with the other paragraphs. Chop off the list starting AFTER it.") (SETQ LINES (LDIFF LINES (CDR (MEMB LASTLINE LINES))))) (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "WARNING: Page full of headings on page " (fetch (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE)))))))))) (RETURN (COND (LINES) (ORPHAN (* ; "If there's only one line left for this box, return it anyhow.") (LIST ORPHAN))))))
)
)
(PUTPROPS TEDITHARDCOPYPATCH COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1365 16981 (TEDIT.FORMAT.HARDCOPY 1375 . 4934) (TEDIT.FORMATBOX 4936 . 9369) (
TEDIT.FORMATTEXTBOX 9371 . 16979)))))
STOP