home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / lispmachine / lmical.lsp < prev    next >
Text File  |  2020-01-01  |  18KB  |  471 lines
  1. ;;; -*- mode:lisp; package:kermit; base:8; ibase:8 -*-
  2. ;1; Note that ibase will not be recognized on the 3600.
  3.  
  4. ;******************************************************************************
  5. ; Copyright (c) 1984, 1985 by Lisp Machine Inc.
  6. ; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
  7. ; Permission to copy all or part of this material is granted, provided
  8. ; that the copies are not made or distributed for resale, and the 
  9. ; copyright notices and reference to the source file and the software
  10. ; distribution version appear, and that notice is given that copying is
  11. ; by permission of Lisp Machine Inc.  LMI reserves for itself the 
  12. ; sole commercial right to use any part of this KERMIT/H19-Emulator
  13. ; not covered by any Columbia University copyright.  Inquiries concerning
  14. ; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
  15. ;
  16. ; Version Information:
  17. ;      LMKERMIT 1.0     --      Original LMI code, plus edit ;1; for 3600 port
  18. ;
  19. ; Authorship Information:
  20. ;      Mark David (LMI)           Original version, using KERMIT.C as a guide
  21. ;      George Carrette (LMI)      Various enhancements
  22. ;      Mark Ahlstrom (Honeywell)  Port to 3600 (edits marked with ";1;" comments)
  23. ;
  24. ; Author Addresses:
  25. ;      George Carrette     ARPANET: GJC at MIT-MC
  26. ;
  27. ;      Mark Ahlstrom       ARPANET: Ahlstrom at HI-Multics
  28. ;                          PHONE:   (612) 887-4006
  29. ;                          USMAIL:  Honeywell MN09-1400
  30. ;                                   Computer Sciences Center
  31. ;                                   10701 Lyndale Avenue South
  32. ;                                   Bloomington, MN  55420
  33. ;******************************************************************************
  34.  
  35.  
  36.  
  37. ;;; this code is designed to unify the protocol and
  38. ;;; perform the basic protol in which globals are safely
  39. ;;; bound to their proper values. This also makes "cold
  40. ;;; boots" of the system easier.
  41.  
  42.  
  43. ;;; all these instance variables are declared special
  44. ;;; in elsewhere in the sources (mostly in the kermit-protocol
  45. ;;; file).
  46.  
  47.  
  48. ;;; kstate should be a special instance variable of the kermit
  49. ;;; frame for this to really work for it.
  50.  
  51.  
  52. ;1; for lack of a better place to put it...
  53.  
  54. ;1; The 3600 does not have the si:with-help-stream stuff.
  55. ;1; I am guessing that this does something like typeout windows
  56. ;1; on the 3600, so I will implement it that way.
  57. ;1; I will have it be a typeout window that comes down over the 
  58. ;1; kermit frame.
  59. ;GJC: good guess. In the LMI software it actually ends up in the terminal
  60. ;GJC: emulation window only. This seems to work fine though.
  61.  
  62. #+3600
  63. (defmacro with-kermit-typeout-stream (stream label &body body)
  64.   `(let ((,stream (send kermit-frame :typeout-window)))
  65.      (unwind-protect
  66.      (progn (send ,stream :expose-for-typeout)
  67.         (send ,stream :select)
  68.         (if ,label (send ,stream :set-label ,label))
  69.         ,@body
  70.         (format ,stream "~&~%~%Type any character to get rid of this display:")
  71.         (send ,stream :tyi))
  72.        (send ,stream :deexpose)
  73. ;1;       (send kermit-frame :refresh)        ;1; used to have :refresh :complete-redisplay
  74.        )))                    ;1; tried just removing it to avoid erasing.
  75.                         ;1; Yup, that did it...
  76.  
  77.  
  78. (defvar kstate)
  79. #+3600
  80. (declare (special *kermit-serial-stream-open-form-list*))
  81.  
  82. ;1; I added this... this should be the first occurance of kermit-default-pathname.
  83. (defvar kermit-default-pathname nil)
  84.  
  85. (defflavor kstate
  86.              (
  87.  
  88.               ;; main user settables
  89.               (*soh* 1)
  90.               (*mytime* #o12)
  91.               (*myquote* #\#)
  92.               (*myeol* #o15)
  93.               (*mypad* 0)
  94.               (*mypchar* 0)
  95.               (*filnamcnv* ':generic)
  96.               (*8-bit-lispm* t)                             ;to do lispm-ascii translation right
  97.               (*image* nil)
  98.               (*debug* nil)
  99.               (*checksum-type* 1)
  100.  
  101.               (ascii-extra-safe-filter?
  102.                 '(lambda (char)
  103.                      (if (< char #\space) #\space char)))
  104.  
  105.               (kermit-default-pathname (string (fs:user-homedir)))
  106.               (*rpsiz* 0)
  107.               (*spsiz* 0)
  108.               (*pad* 0)
  109.               (*timint* 0)
  110.  
  111.               (*remote* nil)
  112.               (*filecount* 0)
  113.               (*size* 0)
  114.               (*packet-number* 0)
  115.               (*numtry* 0)
  116.               (*oldtry* 0)
  117.  
  118.               (*state* 0)
  119.  
  120.               (*padchar* 0)
  121.               (*quote* 0)
  122.               (*eol* #o15)
  123.               (*escchr* 0)
  124.               (*eof* 0)
  125.  
  126.               (bufemp-ignore-line-feed nil)
  127.  
  128.               (*recpkt* (make-array *maxpacksiz* ':type 'art-string ':fill-pointer 0))
  129.               (*packet* (make-array *maxpacksiz* ':type 'art-string ':fill-pointer 0))
  130.               (*string-array-buffer* (make-array (* 2 *maxpacksiz*)
  131.                                                          ;; should be enough for padding
  132.                                                          ;; soh, eol, type, num, len, and data
  133.                                                          ':type 'art-string ':fill-pointer 0))
  134.  
  135.  
  136.  
  137.               (*filnam* nil)
  138.               (*filelist* ())
  139.  
  140.               (*ttyfd* nil)
  141.               (*fp* nil)
  142.               (*kermit-beginning-time* nil)
  143.               (*packcount-wraparound* 0))
  144.  
  145.              ()
  146.   (:settable-instance-variables
  147.    kermit-default-pathname)
  148.   :special-instance-variables)
  149.  
  150. ;1; OK, OK, OK....
  151. ;1; In absolute frustration, I am changing things to try to straighten out the
  152. ;1; confusion between the global and instance kermit-default-pathname.  I took 
  153. ;1; it out of here entirely, and now handle it a a global with faked messges,
  154. ;1; and have it initialized in the make-kermit-ready-for-commands function
  155. ;1; in lmiwin.
  156.  
  157. ;#+3600
  158. ;(defmethod (kstate :kermit-default-pathname) ()
  159. ;  kermit-default-pathname)
  160. ;
  161. ;#+3600
  162. ;(defmethod (kstate :set-kermit-default-pathname) (name)
  163. ;  (setq kermit-default-pathname name))
  164.  
  165. (defmethod (kstate :string-for-kermit)
  166.              (filename)                ;*filnamcnv* is specially bound by method
  167.   (string-for-kermit filename))
  168.  
  169. (defmethod (kstate :filelist)
  170.              (filename)
  171.   (kermit-filelist filename))
  172.  
  173. (defmethod (kstate :simple-receive)
  174.              (stream)
  175.   (declare (special *ttyfd*))            ;1;
  176.   (let ((*ttyfd* stream))
  177.     (recsw)))
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185. ;;;..............................
  186.  
  187.  
  188.  
  189. (defconst kermit-max-delay-before-transaction 500.
  190.   "Maximum time Kermit will delay before doing a file send or receive.")
  191.  
  192.  
  193.  
  194.  
  195.  
  196. (defvar kermit-delay-before-transaction 0
  197.   "Time to delay before starting a send transaction.")
  198.  
  199.  
  200. (DECLARE (SPECIAL *FILNAM* *FILELIST*))
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216. ;1; The filelist sent to the :simple-send method is either
  217. ;1; a list of filenames or a list of (filename asfilename)
  218. ;1; pairs.  The strange thing, as it appears to me, is that
  219. ;1; :simple-send only calls sendsw with the first
  220. ;1; file in the list, and just hangs the rest on
  221. ;1; *filelist*.  This would seem to cause the bug I observed,
  222. ;1; namely that only the first file was sent for a wildcard send.
  223. ;1; But since I interpret "simple send" as just sending a single
  224. ;1; file, I will put the needed loop in the higher level send-files
  225. ;1; function rather than here, and I hope that I don't break
  226. ;1; anything else.
  227.  
  228. (defmethod (kstate :simple-send) (stream filelist)
  229.   (declare (special *filnam* *as-filnam* *filelist* *ttyfd*))    ;1; added to avoid warnings
  230.   (let ((*filnam*
  231.             (if (#-3600 consp #+3600 listp (car filelist))    ;1; see comment below regarding consp vs listp
  232.                 (first (car filelist))
  233.               (car filelist)))
  234.           (*as-filnam*
  235.             (if (#-3600 consp #+3600 listp (car filelist))    ;1; no consp on 3600 anymore, if consp is still
  236.                 (second (car filelist))))    ;1; equivalent to listp on LMI, this can simply be changed to listp
  237. ;1; Wrongooo... changed by MLA 6/17/85
  238. ;1;          (*filelist* (cdr filelist))
  239. ;GJC: really, next time around you should just say #+3600 (DEFMACRO CONSP ...)
  240. ;GJC: not that important of course, but LISTP in common-lisp will be true for () also.      
  241.       (*filelist* filelist)
  242.           (*ttyfd* stream))
  243.     (sendsw)))
  244.  
  245.  
  246.  
  247. (defmethod (kstate :server-receive)
  248.              (stream filename as-filename)
  249.   (declare (special *filnam* *as-filnam* kermit-default-pathname *ttyfd*))    ;1;
  250.   (let ((*filnam* filename)
  251.           (*as-filnam* as-filename)
  252.           (kermit-default-pathname as-filename)   ;for multi files, option to win
  253.           (*ttyfd* stream))
  254.     (flushinput)
  255.     ;1; the length gave an error on 3600...
  256.     #-3600 (spack #/R 0 (length *filnam*) *filnam*)
  257.     #+3600 (spack #/R 0 (string-length *filnam*) *filnam*)
  258.     (recsw)))
  259.  
  260.  
  261. (defmethod (kstate :remote-server) (stream
  262.                                             &optional
  263.                                             working-directory?)
  264.   (declare (special kermit-default-pathname *ttyfd* *remote*))    ;1;
  265.   (let-if
  266.     working-directory?
  267.     ((kermit-default-pathname working-directory?))
  268.     (let ((*ttyfd* stream)
  269.             (*remote* t))
  270.       (server-command-wait))))
  271.  
  272.  
  273.  
  274. (defmethod (kstate :bye-server)
  275.              (stream)
  276.   (declare (special *ttyfd*))            ;1;
  277.   (let ((*ttyfd* stream))
  278.     (flushinput)
  279.     (spack #\G *packet-number* 1 "L")
  280.     (selectq (rpack)
  281.       (#\Y (format interaction-pane "~% ...BYE~%"))
  282.       (#\N (format interaction-pane "~% ...unable to say BYE~%"))
  283.       (t (format interaction-pane "~% ...error saying BYE~%")))))
  284.  
  285.  
  286. (defmethod (kstate :finish-server)
  287.              (stream)
  288.   (declare (special *ttyfd*))            ;1;
  289.   (let ((*ttyfd* stream))
  290.     (flushinput)
  291.     (spack #\G *packet-number* 1 "F")
  292.     (selectq (rpack)
  293.       (#\Y (format interaction-pane "~% ...Finished~%"))
  294.       (#\N (format interaction-pane "~% ...unable to finish~%"))
  295.       (t (format interaction-pane "~% ...error finishing~%")))))
  296.  
  297.  
  298.  
  299.  
  300.  
  301. (defmethod (kstate :set-params) ()
  302.   (declare (special kermit-frame serial-stream-open-form kermit-default-pathname
  303.             file-closing-disposition* *local-echo-mode* *use-bit-7-for-meta*
  304.             *auto-cr-on-lf-flag* *auto-lf-on-cr-flag*))    ;1;
  305.   (let ((oldx tv:mouse-x) (oldy tv:mouse-y)
  306.           (menux (tv:sheet-inside-right kermit-frame))
  307.           (menuy (tv:sheet-inside-bottom kermit-frame))
  308.  
  309.           ;; append new symbols to these two lists:
  310.           (vars '(kermit-default-pathname serial-stream-open-form
  311.                      *file-closing-disposition* *filnamcnv* *8-bit-lispm* *image*
  312.                      ascii-extra-safe-filter?
  313.                      *soh* *mytime* *myquote* *mypad* *mypchar* *image* *debug*
  314.                      *checksum-type*        ;1; let's add a few more for term emulation
  315.              *local-echo-mode* *use-bit-7-for-meta* *auto-cr-on-lf-flag*
  316.              *auto-lf-on-cr-flag*   
  317.                       ))
  318.           (old-vals (list kermit-default-pathname serial-stream-open-form
  319.                               *file-closing-disposition* *filnamcnv* *8-bit-lispm* *image*
  320.                               ascii-extra-safe-filter?
  321.                               *soh* *mytime* *myquote* *mypad* *mypchar* *image* *debug*
  322.                               *checksum-type*
  323.                   *local-echo-mode* *use-bit-7-for-meta* *auto-cr-on-lf-flag*
  324.                   *auto-lf-on-cr-flag*  
  325.                               ))
  326.       ;1; also add the following so that kermit-default-pathname merging works better.
  327.       #+3600
  328.       (fs:*default-pathname-defaults*
  329.         (send (fs:parse-pathname kermit-default-pathname) :new-pathname :name :wild :type :wild))
  330.       )
  331.  
  332.     (tv:mouse-warp (- menux 50.) (- menuy 50.))   ;try to put the mouse around the ctr of menu
  333.     (multiple-value-bind (nil abort-p)
  334.           (*catch 'legal-abortion
  335.             (tv:choose-variable-values
  336.               `("     MODIFY PARAMETERS used by KERMIT by clicking with the mouse     "
  337.                 "     over the appropriate value, typing a new value, and hitting the     "
  338.                 "     return key. When all values are satisfactory, click the box      "
  339.                 "     labelled /"EXECUTE:/" in the lower left corner.     "
  340.  
  341.                 "================================================================================"
  342.  
  343.                 (kermit-default-pathname
  344.                     :documentation "Where to write to or read from by default"
  345.                     :pathname kermit-default-pathname)
  346.  
  347.                 (serial-stream-open-form
  348.                     :documentation "The serial stream//device for connections."
  349.                     :menu-alist
  350.                     ;; one could map over fs:*pathname-host-list* to get these devices...
  351.             #+3600            ;1; different for 3600
  352.             ,*kermit-serial-stream-open-form-list*    ;1; defined in lmiwin
  353.                     #-3600
  354.             (("Serial Port B" (open "SDU-SERIAL-B:"))
  355.                      ;; one should make sure the pathname exists; otherwise, you'll
  356.                      ;; open an 'i//o stream' to some random file probably.
  357.                      . ,(loop for share-tty in unix:*share-ttys*
  358.                                 as port-number from 0
  359.                                 collect
  360.                                  (list
  361.                                    (format nil "Unix Port ~D (//dev//ttyl~D)"
  362.                                              port-number port-number)
  363.                                    `(open
  364.                                         ,(format nil "UNIX-STREAM-~D:"
  365.                                                    port-number)))))
  366.             )                ;1; just changed format for clarity
  367.  
  368.                 "--------------------------------------------------------------------------------"
  369.  
  370.  
  371.                 (*filnamcnv* :documentation "Specify your OS for filename conversion purposes."
  372.                                  :menu-alist ,(cons '("Raw - no conversion" :raw)
  373.                                                         (cons '("Unknown - generic" :generic)
  374.                                                                 (mapcar #'(lambda (x)
  375.                                                                                 (list (car x) (car x)))
  376.                         ;1; changed this as best I could figure out...
  377.                         ;1; what I think it does it get canonical type names
  378.                         ;1; for all types which have a :LISP entry.  --mla
  379.                                     #+3600 (loop for item in fs:*canonical-types-alist*
  380.                                              when (assq ':LISP (cdr item))
  381.                                                collect item)
  382.                                                                         #-3600 (get (locf fs:canonical-types)    ;1;
  383.                                                                                  ':lisp)
  384.                                       )
  385.                                 )))
  386.                 (*8-bit-lispm* :documentation
  387.                  "Yes if you can send 8-bit characters, want lispm//ascii chars translated right."
  388.                  :boolean)
  389.  
  390.                 (ascii-extra-safe-filter?
  391.                     :documentation
  392.                     "Either nil, or a lisp function that filters wierd ctrl characters.")
  393.  
  394.                 (*image* :documentation
  395.                              "Yes if you want 8-bit, binary mode. (no character translation)"
  396.                            :boolean)
  397.                 (*debug* :documentation
  398.                              "Yes, if you want verbose debugging information during xfer"
  399.                            :boolean)
  400.                 (*terminal-debug-mode* :documentation "Yes for debugging the terminal emulator"
  401.                                              :boolean)
  402.                 (*file-closing-disposition*
  403.                     :documentation
  404.                       "Decide whether files only partially written due to interrupt should be saved."
  405.                     :menu-alist (("delete-if-abort" :abort)
  406.                                    ("dont-delete" nil)))
  407.                 "--------------------------------------------------------------------------------"
  408.         ;1; added by mla...
  409.         "Parameters for terminal emulation characteristics..."
  410.  
  411.         (*local-echo-mode* :documentation
  412.                    "Yes if local character echoing should be done."
  413.                    :boolean)
  414.         (*use-bit-7-for-meta* :documentation
  415.                       "Yes if remote host will support bit 7 as Meta bit."
  416.                       :boolean)
  417.         (*auto-cr-on-lf-flag* :documentation
  418.                       "Yes if linefeed should display as a <CR><LF>."
  419.                       :boolean)
  420.         (*auto-lf-on-cr-flag* :documentation
  421.                       "Yes if return should display as a <CR><LF>."
  422.                       :boolean)
  423.  
  424.                 "--------------------------------------------------------------------------------"
  425.  
  426.                 "Some less commonly changed, packet level parameters requiring a more advanced"
  427.               "knowledge of the Kermit Protocol and//or the specific operating system"
  428.               "being dealt with and their (mis)features."
  429.  
  430.                 (*soh* :documentation
  431.                            "mark for start of packet (a non-printing character)"
  432.                          :number)
  433.                 (*mytime* :documentation
  434.                                 "max time to wait for packet"
  435.                               :number)
  436.                 (*myquote* :documentation "Character to use to quote non-printing chars."
  437.                                :number)
  438.                 (*myeol* :documentation "mark for end of packet"
  439.                            :number)
  440.                 (*mypad* :documentation
  441.                              "Number of padding characters to use in packet (usually 0)"
  442.                            :number)
  443.                 (*mypchar* :documentation
  444.                                  "Padding character to use in packet (usually NUL (0))"
  445.                                :number)
  446.                 (*checksum-type* :documentation
  447.                                      "[Only one character checksums are supported at this time]"
  448.                                      :menu-alist (("Normal-one-character" 1)))
  449.                 "      ")
  450.  
  451.               ':near-mode `(:point ,menux ,menuy)
  452.               ':superior kermit-frame
  453.               ':margin-choices '("EXECUTE (use displayed values)"
  454.                  ("ABORT (ignore changes)" (*throw 'legal-abortion nil)))))
  455.       (and abort-p
  456.              (loop for var in vars and old-val in old-vals doing (set var old-val)))
  457.       nil)
  458.  
  459.     (tv:mouse-warp oldx oldy)))
  460.  
  461.  
  462.  
  463.  
  464.  
  465. (defconst kstate ()                               ;should be bound during program
  466.   "The flavor instance of kstate which calls Kermit programs and bind globals.")
  467.  
  468.  
  469. (compile-flavor-methods kstate)
  470.  
  471.