home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
lispmachine
/
lmical.lsp
< prev
next >
Wrap
Text File
|
1988-08-15
|
18KB
|
471 lines
;;; -*- mode:lisp; package:kermit; base:8; ibase:8 -*-
;1; Note that ibase will not be recognized on the 3600.
;******************************************************************************
; Copyright (c) 1984, 1985 by Lisp Machine Inc.
; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
; Permission to copy all or part of this material is granted, provided
; that the copies are not made or distributed for resale, and the
; copyright notices and reference to the source file and the software
; distribution version appear, and that notice is given that copying is
; by permission of Lisp Machine Inc. LMI reserves for itself the
; sole commercial right to use any part of this KERMIT/H19-Emulator
; not covered by any Columbia University copyright. Inquiries concerning
; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
;
; Version Information:
; LMKERMIT 1.0 -- Original LMI code, plus edit ;1; for 3600 port
;
; Authorship Information:
; Mark David (LMI) Original version, using KERMIT.C as a guide
; George Carrette (LMI) Various enhancements
; Mark Ahlstrom (Honeywell) Port to 3600 (edits marked with ";1;" comments)
;
; Author Addresses:
; George Carrette ARPANET: GJC at MIT-MC
;
; Mark Ahlstrom ARPANET: Ahlstrom at HI-Multics
; PHONE: (612) 887-4006
; USMAIL: Honeywell MN09-1400
; Computer Sciences Center
; 10701 Lyndale Avenue South
; Bloomington, MN 55420
;******************************************************************************
;;; this code is designed to unify the protocol and
;;; perform the basic protol in which globals are safely
;;; bound to their proper values. This also makes "cold
;;; boots" of the system easier.
;;; all these instance variables are declared special
;;; in elsewhere in the sources (mostly in the kermit-protocol
;;; file).
;;; kstate should be a special instance variable of the kermit
;;; frame for this to really work for it.
;1; for lack of a better place to put it...
;1; The 3600 does not have the si:with-help-stream stuff.
;1; I am guessing that this does something like typeout windows
;1; on the 3600, so I will implement it that way.
;1; I will have it be a typeout window that comes down over the
;1; kermit frame.
;GJC: good guess. In the LMI software it actually ends up in the terminal
;GJC: emulation window only. This seems to work fine though.
#+3600
(defmacro with-kermit-typeout-stream (stream label &body body)
`(let ((,stream (send kermit-frame :typeout-window)))
(unwind-protect
(progn (send ,stream :expose-for-typeout)
(send ,stream :select)
(if ,label (send ,stream :set-label ,label))
,@body
(format ,stream "~&~%~%Type any character to get rid of this display:")
(send ,stream :tyi))
(send ,stream :deexpose)
;1; (send kermit-frame :refresh) ;1; used to have :refresh :complete-redisplay
))) ;1; tried just removing it to avoid erasing.
;1; Yup, that did it...
(defvar kstate)
#+3600
(declare (special *kermit-serial-stream-open-form-list*))
;1; I added this... this should be the first occurance of kermit-default-pathname.
(defvar kermit-default-pathname nil)
(defflavor kstate
(
;; main user settables
(*soh* 1)
(*mytime* #o12)
(*myquote* #\#)
(*myeol* #o15)
(*mypad* 0)
(*mypchar* 0)
(*filnamcnv* ':generic)
(*8-bit-lispm* t) ;to do lispm-ascii translation right
(*image* nil)
(*debug* nil)
(*checksum-type* 1)
(ascii-extra-safe-filter?
'(lambda (char)
(if (< char #\space) #\space char)))
(kermit-default-pathname (string (fs:user-homedir)))
(*rpsiz* 0)
(*spsiz* 0)
(*pad* 0)
(*timint* 0)
(*remote* nil)
(*filecount* 0)
(*size* 0)
(*packet-number* 0)
(*numtry* 0)
(*oldtry* 0)
(*state* 0)
(*padchar* 0)
(*quote* 0)
(*eol* #o15)
(*escchr* 0)
(*eof* 0)
(bufemp-ignore-line-feed nil)
(*recpkt* (make-array *maxpacksiz* ':type 'art-string ':fill-pointer 0))
(*packet* (make-array *maxpacksiz* ':type 'art-string ':fill-pointer 0))
(*string-array-buffer* (make-array (* 2 *maxpacksiz*)
;; should be enough for padding
;; soh, eol, type, num, len, and data
':type 'art-string ':fill-pointer 0))
(*filnam* nil)
(*filelist* ())
(*ttyfd* nil)
(*fp* nil)
(*kermit-beginning-time* nil)
(*packcount-wraparound* 0))
()
(:settable-instance-variables
kermit-default-pathname)
:special-instance-variables)
;1; OK, OK, OK....
;1; In absolute frustration, I am changing things to try to straighten out the
;1; confusion between the global and instance kermit-default-pathname. I took
;1; it out of here entirely, and now handle it a a global with faked messges,
;1; and have it initialized in the make-kermit-ready-for-commands function
;1; in lmiwin.
;#+3600
;(defmethod (kstate :kermit-default-pathname) ()
; kermit-default-pathname)
;
;#+3600
;(defmethod (kstate :set-kermit-default-pathname) (name)
; (setq kermit-default-pathname name))
(defmethod (kstate :string-for-kermit)
(filename) ;*filnamcnv* is specially bound by method
(string-for-kermit filename))
(defmethod (kstate :filelist)
(filename)
(kermit-filelist filename))
(defmethod (kstate :simple-receive)
(stream)
(declare (special *ttyfd*)) ;1;
(let ((*ttyfd* stream))
(recsw)))
;;;..............................
(defconst kermit-max-delay-before-transaction 500.
"Maximum time Kermit will delay before doing a file send or receive.")
(defvar kermit-delay-before-transaction 0
"Time to delay before starting a send transaction.")
(DECLARE (SPECIAL *FILNAM* *FILELIST*))
;1; The filelist sent to the :simple-send method is either
;1; a list of filenames or a list of (filename asfilename)
;1; pairs. The strange thing, as it appears to me, is that
;1; :simple-send only calls sendsw with the first
;1; file in the list, and just hangs the rest on
;1; *filelist*. This would seem to cause the bug I observed,
;1; namely that only the first file was sent for a wildcard send.
;1; But since I interpret "simple send" as just sending a single
;1; file, I will put the needed loop in the higher level send-files
;1; function rather than here, and I hope that I don't break
;1; anything else.
(defmethod (kstate :simple-send) (stream filelist)
(declare (special *filnam* *as-filnam* *filelist* *ttyfd*)) ;1; added to avoid warnings
(let ((*filnam*
(if (#-3600 consp #+3600 listp (car filelist)) ;1; see comment below regarding consp vs listp
(first (car filelist))
(car filelist)))
(*as-filnam*
(if (#-3600 consp #+3600 listp (car filelist)) ;1; no consp on 3600 anymore, if consp is still
(second (car filelist)))) ;1; equivalent to listp on LMI, this can simply be changed to listp
;1; Wrongooo... changed by MLA 6/17/85
;1; (*filelist* (cdr filelist))
;GJC: really, next time around you should just say #+3600 (DEFMACRO CONSP ...)
;GJC: not that important of course, but LISTP in common-lisp will be true for () also.
(*filelist* filelist)
(*ttyfd* stream))
(sendsw)))
(defmethod (kstate :server-receive)
(stream filename as-filename)
(declare (special *filnam* *as-filnam* kermit-default-pathname *ttyfd*)) ;1;
(let ((*filnam* filename)
(*as-filnam* as-filename)
(kermit-default-pathname as-filename) ;for multi files, option to win
(*ttyfd* stream))
(flushinput)
;1; the length gave an error on 3600...
#-3600 (spack #/R 0 (length *filnam*) *filnam*)
#+3600 (spack #/R 0 (string-length *filnam*) *filnam*)
(recsw)))
(defmethod (kstate :remote-server) (stream
&optional
working-directory?)
(declare (special kermit-default-pathname *ttyfd* *remote*)) ;1;
(let-if
working-directory?
((kermit-default-pathname working-directory?))
(let ((*ttyfd* stream)
(*remote* t))
(server-command-wait))))
(defmethod (kstate :bye-server)
(stream)
(declare (special *ttyfd*)) ;1;
(let ((*ttyfd* stream))
(flushinput)
(spack #\G *packet-number* 1 "L")
(selectq (rpack)
(#\Y (format interaction-pane "~% ...BYE~%"))
(#\N (format interaction-pane "~% ...unable to say BYE~%"))
(t (format interaction-pane "~% ...error saying BYE~%")))))
(defmethod (kstate :finish-server)
(stream)
(declare (special *ttyfd*)) ;1;
(let ((*ttyfd* stream))
(flushinput)
(spack #\G *packet-number* 1 "F")
(selectq (rpack)
(#\Y (format interaction-pane "~% ...Finished~%"))
(#\N (format interaction-pane "~% ...unable to finish~%"))
(t (format interaction-pane "~% ...error finishing~%")))))
(defmethod (kstate :set-params) ()
(declare (special kermit-frame serial-stream-open-form kermit-default-pathname
file-closing-disposition* *local-echo-mode* *use-bit-7-for-meta*
*auto-cr-on-lf-flag* *auto-lf-on-cr-flag*)) ;1;
(let ((oldx tv:mouse-x) (oldy tv:mouse-y)
(menux (tv:sheet-inside-right kermit-frame))
(menuy (tv:sheet-inside-bottom kermit-frame))
;; append new symbols to these two lists:
(vars '(kermit-default-pathname serial-stream-open-form
*file-closing-disposition* *filnamcnv* *8-bit-lispm* *image*
ascii-extra-safe-filter?
*soh* *mytime* *myquote* *mypad* *mypchar* *image* *debug*
*checksum-type* ;1; let's add a few more for term emulation
*local-echo-mode* *use-bit-7-for-meta* *auto-cr-on-lf-flag*
*auto-lf-on-cr-flag*
))
(old-vals (list kermit-default-pathname serial-stream-open-form
*file-closing-disposition* *filnamcnv* *8-bit-lispm* *image*
ascii-extra-safe-filter?
*soh* *mytime* *myquote* *mypad* *mypchar* *image* *debug*
*checksum-type*
*local-echo-mode* *use-bit-7-for-meta* *auto-cr-on-lf-flag*
*auto-lf-on-cr-flag*
))
;1; also add the following so that kermit-default-pathname merging works better.
#+3600
(fs:*default-pathname-defaults*
(send (fs:parse-pathname kermit-default-pathname) :new-pathname :name :wild :type :wild))
)
(tv:mouse-warp (- menux 50.) (- menuy 50.)) ;try to put the mouse around the ctr of menu
(multiple-value-bind (nil abort-p)
(*catch 'legal-abortion
(tv:choose-variable-values
`(" MODIFY PARAMETERS used by KERMIT by clicking with the mouse "
" over the appropriate value, typing a new value, and hitting the "
" return key. When all values are satisfactory, click the box "
" labelled /"EXECUTE:/" in the lower left corner. "
"================================================================================"
(kermit-default-pathname
:documentation "Where to write to or read from by default"
:pathname kermit-default-pathname)
(serial-stream-open-form
:documentation "The serial stream//device for connections."
:menu-alist
;; one could map over fs:*pathname-host-list* to get these devices...
#+3600 ;1; different for 3600
,*kermit-serial-stream-open-form-list* ;1; defined in lmiwin
#-3600
(("Serial Port B" (open "SDU-SERIAL-B:"))
;; one should make sure the pathname exists; otherwise, you'll
;; open an 'i//o stream' to some random file probably.
. ,(loop for share-tty in unix:*share-ttys*
as port-number from 0
collect
(list
(format nil "Unix Port ~D (//dev//ttyl~D)"
port-number port-number)
`(open
,(format nil "UNIX-STREAM-~D:"
port-number)))))
) ;1; just changed format for clarity
"--------------------------------------------------------------------------------"
(*filnamcnv* :documentation "Specify your OS for filename conversion purposes."
:menu-alist ,(cons '("Raw - no conversion" :raw)
(cons '("Unknown - generic" :generic)
(mapcar #'(lambda (x)
(list (car x) (car x)))
;1; changed this as best I could figure out...
;1; what I think it does it get canonical type names
;1; for all types which have a :LISP entry. --mla
#+3600 (loop for item in fs:*canonical-types-alist*
when (assq ':LISP (cdr item))
collect item)
#-3600 (get (locf fs:canonical-types) ;1;
':lisp)
)
)))
(*8-bit-lispm* :documentation
"Yes if you can send 8-bit characters, want lispm//ascii chars translated right."
:boolean)
(ascii-extra-safe-filter?
:documentation
"Either nil, or a lisp function that filters wierd ctrl characters.")
(*image* :documentation
"Yes if you want 8-bit, binary mode. (no character translation)"
:boolean)
(*debug* :documentation
"Yes, if you want verbose debugging information during xfer"
:boolean)
(*terminal-debug-mode* :documentation "Yes for debugging the terminal emulator"
:boolean)
(*file-closing-disposition*
:documentation
"Decide whether files only partially written due to interrupt should be saved."
:menu-alist (("delete-if-abort" :abort)
("dont-delete" nil)))
"--------------------------------------------------------------------------------"
;1; added by mla...
"Parameters for terminal emulation characteristics..."
(*local-echo-mode* :documentation
"Yes if local character echoing should be done."
:boolean)
(*use-bit-7-for-meta* :documentation
"Yes if remote host will support bit 7 as Meta bit."
:boolean)
(*auto-cr-on-lf-flag* :documentation
"Yes if linefeed should display as a <CR><LF>."
:boolean)
(*auto-lf-on-cr-flag* :documentation
"Yes if return should display as a <CR><LF>."
:boolean)
"--------------------------------------------------------------------------------"
"Some less commonly changed, packet level parameters requiring a more advanced"
"knowledge of the Kermit Protocol and//or the specific operating system"
"being dealt with and their (mis)features."
(*soh* :documentation
"mark for start of packet (a non-printing character)"
:number)
(*mytime* :documentation
"max time to wait for packet"
:number)
(*myquote* :documentation "Character to use to quote non-printing chars."
:number)
(*myeol* :documentation "mark for end of packet"
:number)
(*mypad* :documentation
"Number of padding characters to use in packet (usually 0)"
:number)
(*mypchar* :documentation
"Padding character to use in packet (usually NUL (0))"
:number)
(*checksum-type* :documentation
"[Only one character checksums are supported at this time]"
:menu-alist (("Normal-one-character" 1)))
" ")
':near-mode `(:point ,menux ,menuy)
':superior kermit-frame
':margin-choices '("EXECUTE (use displayed values)"
("ABORT (ignore changes)" (*throw 'legal-abortion nil)))))
(and abort-p
(loop for var in vars and old-val in old-vals doing (set var old-val)))
nil)
(tv:mouse-warp oldx oldy)))
(defconst kstate () ;should be bound during program
"The flavor instance of kstate which calls Kermit programs and bind globals.")
(compile-flavor-methods kstate)