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