home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / printing.seq < prev    next >
Text File  |  1991-04-10  |  17KB  |  433 lines
  1. \ PRINTING.SEQ  Export & Import for SED.           by 1987 Tom Zimmer
  2.  
  3. editor definitions
  4.  
  5. \ The following few lines allows you to remove the printer driver code
  6. \ and still load this printing facility onto SED.  Afterall you may not
  7. \ need special printer attributes like BOLD and UNDERLINE.
  8.  
  9. defined ptype nip 0=    \ if PTYPE not already defined, define it.
  10. #if                     \ Along with some DUMMY words.
  11.                 : ptype         ( a1 n1 --- )
  12.                                 prnhndl hwrite #out +! ;
  13.                 : printer-init  ;
  14.                 : printer-reset ;
  15.                 : lineendoff ;
  16.                 variable compressvar
  17. #then
  18.  
  19. : pcr           ( --- ) 13 pemit 10 pemit #out off ;
  20.  
  21. defer pbutton   ' noop is pbutton
  22.  
  23. HEADERLESS      \ 05/28/90 21:22:34.73 TJZ
  24.  
  25. 0 value dolst
  26. 0 value file-date-val
  27. 0 value file-time-val
  28.  
  29. : pdate/time    ( --- )
  30.                 getdate form-date count ptype bl pemit
  31.                 gettime form-time count 6 - ptype ;
  32.                                         \ get rid of seconds and hundredths
  33.  
  34. variable controlines    \ number of control line encountered.
  35.  
  36. : skipto        ( a1 --- a2 )   \ skips all but one leading bl
  37.                 1+
  38.                 begin   dup c@ bl =
  39.                 while   1+
  40.                 repeat  1- ;
  41.  
  42. : ?escprint     ( --- f1 )
  43.                 linebuf 1+ dup c@ '.' =
  44.                 swap 1+ c@ '#' = and dup
  45.                 if      linebuf 3 +     controlines incr
  46.                         begin   skipto dup 1+ c@
  47.                                 '0' '9' between
  48.                         while   0.0 rot convert nip swap
  49.                                 255 min pemit
  50.                         repeat  drop
  51.                 then    ;
  52.  
  53. headers
  54.  
  55. : .offline      ( --- )
  56.                 ."  *** Printer OFF LINE, or NOT connected. *** " ;
  57.  
  58. : pspaces       ( n1 -- )
  59.                 0max    80 /mod 0
  60.                 ?do     spcs   80 ptype
  61.                 loop    spcs swap ptype ;
  62.  
  63. headerless
  64.  
  65. : .noprinter    ( --- )
  66.                 dolst 0=
  67.                 if      17 6 63 8 box&fill .offline beep
  68.                         cursor-off 2 seconds cursor-on
  69.                         showcur emptykbd scrshow
  70.                 else    cr .offline cr
  71.                 then    ;
  72.  
  73. : printline     ( --- )
  74.                 ?escprint ?exit
  75.                 lmargin @ pspaces
  76.                 stripbl's
  77.                 ?browse         \ if we are in browse mode then
  78.                 if              \ Supress hypertext destinations printout
  79.                         linebuf 1+ c@ hyperdest =
  80.                         if      linebuf count 2dup bl scan nip - blank
  81.                         then
  82.                 then
  83.                 linebuf count ptype
  84.                 pcr getline lineendoff ;
  85.  
  86. headers
  87.  
  88. variable pagenumber     1 pagenumber !
  89. variable firstpage      1 firstpage  !
  90. variable lastpage      99 lastpage   !
  91. variable copies         1 copies !      \ 05/28/90 21:27:21.00 TJZ
  92. variable pgtoprint      1 pgtoprint !   \ 05/28/90 21:27:20.34 TJZ
  93. variable lsttoprint    99 lsttoprint !  \ 05/28/90 21:27:19.74 TJZ
  94. variable pitem                          \ 05/28/90 21:24:55.56 TJZ
  95. variable pnumval                        \ 05/28/90 21:24:56.77 TJZ
  96.  
  97. 0 value ?listing
  98. 6 constant pitems                       \ 05/28/90 21:26:25.36 TJZ
  99.  
  100. headerless
  101.  
  102. : .underline    ( --- )                 \ underline current line.
  103.                 13 pemit #out off
  104.                 lmargin @ pspaces       \ tab over to left margin
  105.                 80 lmargin @ - 0MAX 0
  106.                 ?do     '_' pemit
  107.                 loop    pcr pcr ;
  108.  
  109. comment:  GET DATE & TIME OF CURRENTLY-OPEN FILE, & CONVERT TO DOS FORMATS
  110.  
  111.         The file printing routine in F-PC puts into the footer the date on
  112.         which the file was printed, which is fine as far as it goes. But in
  113.         many cases you'd really like to know the revision date of the file
  114.         itself. That is contained in the disk directory, and used to be
  115.         shown by programmers on the top line of each block. But that
  116.         practice in not now used, and you have no way to tell the "version"
  117.         (last revision date) of a program printout.
  118.  
  119.         The following words get from DOS the date and time of the currently
  120.         open file, in the special DOS file-date format, then converts them
  121.         to the standard DOS date and time formats, for printing in .FOOTER.
  122.  
  123.         References: R. Jourdain, "Programmer's Problem Solver for the IBM
  124.         PC", Brady, 1986. Sec 5.2.5 Get/set the time and date of a file (pg
  125.         262). (Typo: in one place, says erroneously to put 01 into AL to
  126.         get date. It is in fact 00 to get date.
  127.  
  128.         R. Duncan (ed), "The MS-DOS Encyclopedia", Microsoft Press, 1988.
  129.         Sec. 5 "System 2Calls", Interrupt 21H, Function 57H, Get/Set
  130.         Date/Time of File (pg 1388).
  131.  
  132. comment;
  133.  
  134. \ None of existing DOS calls pass the needed registers, so a new one is needed.
  135.  
  136. postfix         \ use the postfix assembler
  137. code get_file_date&time       ( handle# -- file-time file-date )
  138.                bx pop                        \ handle# -> bx
  139.                $057 # ah mov                 \ Function 57 -> ah
  140.                0 # al mov                    \ 0 -> al for "get"
  141.                $21 int                       \ gets the time & date
  142.                cx push                       \ the time to the stack
  143.                dx push                       \ the date over it
  144.                next     end-code
  145.  
  146. prefix          \ restore prefix assembler
  147.  
  148. : convert_file_date     ( file-date -- Y MD )  \ File-date format to DOS fmt.
  149.                0 $0200  um/mod          \ high 7 bits are ( year - 80 )
  150.                $050 +                   \ add the decimal 80
  151.                swap                     \ get the remainder
  152.                0 $020   um/mod          \ low 5 bits are day, next 4 are month
  153.                $0100 * +  ;             \ form bcd number MD
  154.  
  155. : convert_file_time     ( file-time -- HM 00 )  \ File-time format to DOS fmt.
  156.                0 $0800  um/mod          \ high 5 bits are hours
  157.                $0100 *                  \ To upper nibble of DOS bcd format
  158.                swap                     \ get the remainder
  159.                $020  /                  \ low 5 bits are seconds (discarded),
  160.                                         \ next 6 are minutes
  161.                +              \ Add upper & lower nibbles to make bcd number
  162.                00       ;     \ Not using seconds, so put in zero
  163.  
  164. : setfile_date&time     ( --- )
  165.                 ed1hndl hopen 0=
  166.         if      ed1hndl   \ gets beginning of handle stack = currently open
  167.                 >hndle @    \ move to handle number & fetch it
  168.                 get_file_date&time =: file-date-val =: file-time-val
  169.                 ed1hndl hclose drop
  170.         else    off> file-date-val off> file-time-val
  171.         then    ;
  172.  
  173. : .file_date    ( --- )
  174.                 file-date-val
  175.                 convert_file_date  form-date count ptype bl pemit
  176.                 file-time-val
  177.                 convert_file_time  form-time count 6 - 0MAX ptype ;
  178.  
  179. : .footer       ( --- )
  180.                 pagenumber @
  181.                 if      .underline
  182.                         lmargin @ pspaces       \ Move over to left margin
  183.                         " Page " ptype
  184.                         pagenumber @ 0 <# #s #> ptype "  of " ptype
  185.                         pagenumber incr
  186.                         lastpage @ 0 <# #s #> ptype
  187.                         2 pspaces
  188.                         " Printed " ptype  pdate/time
  189.                         ed1hndl c@       \ Get length of complete file name
  190.                         22 lmargin @ - 0MAX >
  191.                         if pcr then \ CR if too long to fit on same line
  192.                         60 ed1hndl c@ - #out @ - 80 min pspaces
  193.                         ed1hndl count ptype
  194.                         "  of " ptype  .file_date  \ Print file date
  195.                 then    ;
  196.  
  197. : newpage       ( --- )
  198.                 formfeed pemit ;
  199.  
  200. : setpage       firstpage @ pagenumber ! ;
  201.  
  202. : linesleft     ( --- )         \ lines left to print on page
  203.                 curline controlines @ 1- 0MAX - 0MAX
  204.                 prtlines mod ;
  205.  
  206. : .header       ( --- ) \ print first line of the current file
  207.                 pcr pcr
  208.                 0 #lineseg 1 over 0 c@l >r ?cs: pad r@ cmovel
  209.                 lmargin @ pspaces
  210.                 pad r> ptype
  211.                 .underline ;
  212.  
  213. : ?newpage      ( --- )
  214.                 linesleft 0=
  215.                 if      .footer newpage .header
  216.                 then    ;
  217.  
  218. : todocpage     ( --- )
  219.                 pgtoprint @ 1- 0MAX 199 min prtlines *
  220.                 to.line first.textline =: screenline
  221.                 dolst 0=
  222.                 if      scrshow
  223.                 then    ;
  224.  
  225.  
  226. : ?lastppg      ( --- f1 )
  227.                 lsttoprint @ 199 min prtlines * 2-
  228.                 curline < ;
  229.  
  230. : setlastpg     ( --- )
  231.                 lastline prtlines /mod swap
  232.                 if      1+ then dup lsttoprint ! lastpage ! ;
  233.  
  234. : doprint       ( --- )
  235.                 ?printer.ready ?listing or 0=
  236.                 if  .noprinter exit then
  237.                 0 save!> ?listing
  238.                 printer-init
  239.                 setfile_date&time
  240.                 copies @ 0
  241.         ?do     <shom>  dolst 0=
  242.                 if      scrshow
  243.                 then    .header
  244.                 todocpage setpage controlines off
  245.                 begin   curline 7 and 0= if showstat then
  246.                         curline 0=
  247.                         if      pcr
  248.                         else    printline
  249.                         then
  250.                         ?lastline 0=
  251.                         key?      0= and
  252.                         ?lastppg  0= and
  253.                 while   dolst 0=
  254.                         if      dnln
  255.                         else    <sdln>
  256.                         then    ?newpage
  257.                 repeat  prtlines linesleft - 1- 0MAX
  258.                 0 ?do      pcr loop
  259.                 .footer newpage    key? ?leave
  260.         loop    printer-reset
  261.                 <shom>  dolst 0=
  262.                 if      scrshow emptykbd
  263.                 then
  264.                 restore> ?listing ;
  265.  
  266. defer escattrib ' >rev is escattrib
  267.  
  268. : torev         ['] >rev     is escattrib ;
  269. : toblnk        ['] >revblnk is escattrib ;
  270.  
  271. create prtmenu pitems c,
  272.         28 ,  10 ,  ," First Page to print"      pgtoprint ,
  273.         28 ,  12 ,  ,"  Last Page to print"     lsttoprint ,
  274.         28 ,  14 ,  ," Left margin indent"         lmargin ,
  275.         65 ,  10 ,  ," Start numbering pages at" firstpage ,
  276.         65 ,  12 ,  ," Copies to print"             copies ,
  277.         65 ,  14 ,  ," Compressed printing"    compressvar ,
  278.  
  279. : showpdata     ( --- )
  280.                 >rev    prtmenu count 1- 0
  281.                 do      dup 2@ swap at
  282.                         4 + count + dup @ @ 5 .l 2+
  283.                 loop    dup 2@ swap at
  284.                         4 + count + dup @ @
  285.                         if      ."  ON  "
  286.                         else    ."  OFF "
  287.                         then    2+
  288.                 drop >norm ;
  289.  
  290. : showcmds      ( --- )
  291.                 11 16 at  escattrib
  292.                 ."  ESC \3 = cancel "    escattrib
  293.                 ."  P \3 = Print " escattrib
  294.                 ."  S \3 = Set print device or file "
  295.                  9 18 at ." \1Currently printing to \0 "
  296.                 >attrib3 prnhndl count type
  297.                 >norm 72 #out @ - spaces ;
  298.  
  299.  
  300. : showpform     ( --- )
  301.                  6 4 73 19 box&fill
  302.                 27 5 at ." \r Printing Setup Menu "
  303.                 17 7 at ." \3Use Enter or Arrows to move between fields"
  304.                 24 8 at ." \3Use + or - to change values"
  305.                 prtmenu count 0
  306.                 do      dup 2@ 2 pick 4 + c@ - 1- swap at
  307.                         4 + count 2dup type + 2+
  308.                 loop    drop 64 9 at ." 0=no #'s" showcmds ;
  309.  
  310. : >pitem        ( --- a1 )
  311.                 prtmenu 1+ pitem @ 0
  312.                 ?do     4 + count + 2+
  313.                 loop    ;
  314.  
  315. HEADERS         \ 05/28/90 21:27:58.08 TJZ
  316.  
  317. : sc            ( --- )
  318.                 torev showcmds ;
  319.  
  320. : showpcur      ( --- )
  321.                 >pitem 2@ 6 + swap at ;
  322.  
  323. HEADERLESS      \ 05/28/90 21:28:03.40 TJZ
  324.  
  325. : ptohome       pitem off pnumval off torev showpcur ;
  326.  
  327. : penter        ( c1 --- c1 ) dup 13 =  \ Enter key
  328.                 over 208 = or            \ down arrow
  329.                 if      pitem @ 1+ pitems mod pitem ! sc
  330.                         showpcur pnumval off drop 0
  331.                 then    ;
  332.  
  333. : pincr         ( c1 --- c1 ) dup 43 =  \ plus "+" sign
  334.                 if      >pitem  4 + count + @
  335.                          pitem  @ pitems 1- =
  336.                         if      dup @ 0= swap !
  337.                         else    incr
  338.                         then    showpdata sc showpcur drop 0
  339.                 then    ;
  340.  
  341. : pdecr         ( c1 --- c1 )
  342.                 dup 45 =        \ minus "-" sign
  343.                 if      >pitem  4 + count + @
  344.                         dup @ 1- 0MAX swap !
  345.                         showpdata sc showpcur drop 0
  346.                 then    ;
  347.  
  348. : prright       ( c1 --- c1 )
  349.                 dup 203 =        \ left arrow
  350.                 over 205 = or     \ right arrow
  351.                 if      pitem @ 3 + pitems mod pitem ! sc
  352.                         showpcur pnumval off drop 0
  353.                 then    ;
  354.  
  355. : prup          ( c1 --- c1 )
  356.                 dup 200 =         \ up arrow
  357.                 if      pitem @ pitems 1- + pitems mod pitem ! sc
  358.                         showpcur pnumval off drop 0
  359.                 then    ;
  360.  
  361. : pbkspace      ( c1 --- c1 )
  362.                 dup 8 =           \ back space
  363.                 if      pnumval off
  364.                         >pitem  4 + count + @ off
  365.                         showpdata sc showpcur drop 0
  366.                 then    ;
  367.  
  368. : pnum          ( c1 --- c1 )           \ number between 0 and 9
  369.                 dup '0' >= over '9' <= and
  370.                 if      dup '0' - pnumval @ 10 * + 199 min
  371.                         dup pnumval ! >pitem 4 + count + @ !
  372.                         showpdata sc showpcur drop 0
  373.                 then    ;
  374.  
  375. 0 value pfileing
  376.  
  377. : pset          ( c1 --- c1 )
  378.                 dup bl or 's' =             \ s = set print file
  379.                 if      prnhndl pad over c@ 1+ cmove
  380.                         on> autoclear
  381.                         >attrib1
  382.                         32 18 pad 40 lineeditor       ( --- f1 )
  383.                         >norm
  384.                         cursor-off
  385.                         pad c@ 0<> and
  386.                         if      on> pfileing
  387.                                 pad $pfile
  388.                                 if      32 18 at >rev
  389.                                      ."  Could not to create requested file  "
  390.                                         beep 1 seconds off> pfileing
  391.                                 then
  392.                         else    pclose off> pfileing
  393.                         then    showcmds drop 0
  394.                         showpcur cursor-on
  395.                 then    ;
  396.  
  397. : pmenu         ( --- )         \ print menu
  398.                 ['] pbutton save!> dobutton
  399.                 savescr
  400.                 setlastpg
  401.                 showpform  showpdata ptohome
  402.                 begin   key dup 27 <>     over
  403. ( Alt-P )                      153 <> and over bl or
  404.                                'p' <> and
  405.                 while   penter  pincr  pdecr  pnum  pbkspace
  406.                         prright prup   pset
  407.                         if toblnk showcmds torev beep showpcur
  408.                         then
  409.                 repeat  restscr
  410.                 showscreen bl or 'p' =
  411.                 if      doprint
  412.                 then    pfileing        \ if we were printing to a file
  413.                 if      pclose          \ then close the print file
  414.                 then
  415.                 restore> dobutton ;
  416.  
  417. ' pmenu is pmenux
  418.  
  419. headers
  420.  
  421. : elisting       ( --- )
  422.                 [ editor ]
  423.                 setlastpg
  424.                 cr ." Printing..."
  425.                 savecursor
  426.                 on> dolst doprint off> dolst
  427.                 off> edready
  428.                 restcursor ;
  429.  
  430. forth definitions
  431.  
  432.  
  433.