From 79330791c089d2c358eb925f5f500db4bf0efdc8 Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Mon, 8 Nov 2021 13:32:36 +0100 Subject: [PATCH] LMODEM - Xmodem written in Maclisp. Files courtesy of Eric J. Swenson. Published with permission from Edward Barton. --- Makefile | 2 +- build/timestamps.txt | 6 + doc/_info_/lmodem.help | 70 ++ doc/programs.md | 1 + src/cpm/help.lmodem | 1 + src/eb/dsk8.33 | 185 ++++++ src/eb/errmac.84 | 341 ++++++++++ src/eb/sfadcl.3 | 19 + src/eb/signal.31 | 94 +++ src/ejs/lmodem.255 | 1437 ++++++++++++++++++++++++++++++++++++++++ 10 files changed, 2155 insertions(+), 1 deletion(-) create mode 100755 doc/_info_/lmodem.help create mode 120000 src/cpm/help.lmodem create mode 100644 src/eb/dsk8.33 create mode 100644 src/eb/errmac.84 create mode 100644 src/eb/sfadcl.3 create mode 100644 src/eb/signal.31 create mode 100644 src/ejs/lmodem.255 diff --git a/Makefile b/Makefile index 5c0f0c60..2863a60b 100644 --- a/Makefile +++ b/Makefile @@ -44,7 +44,7 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ mits_s rab stan_k bs cstacy kp dcp2 -pics- victor imlac rjl mb bh \ lars drnil radia gjd maint bolio cent shrdlu vis cbf digest prs jsf \ decus bsg muds54 hello rrs 2500 minsky danny survey librm3 librm4 \ - klotz atlogo clusys cprog r + klotz atlogo clusys cprog r eb cpm DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ diff --git a/build/timestamps.txt b/build/timestamps.txt index 02407de2..f853409e 100644 --- a/build/timestamps.txt +++ b/build/timestamps.txt @@ -339,7 +339,12 @@ eak/file.2 198102151946.24 eak/lims.7 198304301601.54 eak/limser.19 198304100834.46 eak/macros.36 198007121123.43 +eb/dsk8.33 198105211814.47 +eb/errmac.84 198111112102.45 +eb/signal.31 198105211819.00 +eb/sfadcl.3 198006292019.46 ecc/quotes.55 198304202101.03 +ejs/lmodem.255 198212122125.42 ellen/check.52 198204200346.45 ellen/option.88 198107161335.12 ellen/primer.239 198406151546.11 @@ -833,6 +838,7 @@ _info_/lisp.string 198202060209.57 info/lispt.22 197803112120.26 _info_/lisp.trace 197501181143.25 _info_/lisp.whovar 198102200255.12 +_info_/lmodem.help 198106051040.17 info/macsym.12 198303130147.18 info/mail.12 198201140231.54 info/meter.1 197707100346.21 diff --git a/doc/_info_/lmodem.help b/doc/_info_/lmodem.help new file mode 100755 index 00000000..088cb7a2 --- /dev/null +++ b/doc/_info_/lmodem.help @@ -0,0 +1,70 @@ +LMODEM is a Maclisp implementation of the MODEM/XMODEM protocol that +is often used for transferring files between microcomputer systems +running the CP/M operating system. It requires the MODEM program on +the CP/M end. (See the files MC:CPM;MODEM 206ASM, MODEM 206DOC, MODEM +926, and MODEM DOC ; the file MBOOT ASM may also be of interest.) + +In order to use LMODEM you should be connected to AI, MC, or ML +through one of the following connection paths: + (1) TIP connection + (2) Dialup (MC only) + (3) Connected to the machine in one of those ways and running + the CRTSTY program +LMODEM cannot be used through the AI or ML dialups without modifying +the program that runs on the CP/M end. When LMODEM starts up it will +tell you whether it intends to use "7-bit" or "8-bit" protocol; 7-bit +protocol CANNOT be used without a modified CP/M MODEM program. + +LMODEM can deal with text (7-bit, ASCII) or binary (8-bit, "COM") files. +You must specify what kind of file because different kinds are stored +on ITS in different ways. The basic usage of LMODEM is as follows: + +Run MODEM T on your CP/M system, connect to ITS and run LMODEM, and +give LMODEM one of the following commands, including the parentheses: + (send-ascii-file "") + (send-com-file "") + (receive-ascii-file "") + (receive-com-file "") + (receive-file "") + (send-file "") +(SEND means send from ITS, RECEIVE means receive onto ITS.) Wait +until LMODEM types the message READY; then exit the MODEM T option +by typing whatever escape character is assembled into your MODEM +program and (quickly) issue one of the following CP/M commands: + MODEM R fn.ft + MODEM S fn.ft +Obviously you should use R on CP/M if you told LMODEM to SEND, +S on CP/M if you told LMODEM to RECEIVE. The transfer will then +proceed, either terminating successfully or aborting due to +excessively numerous errors or timeouts. After the transfer +LMODEM will await another command. + +(Note: In typing a filename, the slash character "/" must be doubled.) + +LMODEM must adjust your ITS console and your TIP connection in a +strange way in order to do its transfers. If a file transfer +terminates normally then everything will be restored, but if +a transfer aborts then control-Z may no longer get you back to +DDT. If this happens you can do (RESTORE-TTY) to fix things back; +the (QUIT) command, which kills LMODEM, will also restore things. +If for some reason these commands fail, or you get some cryptic +message like ;BKPT WRNG-NO-ARGS from LISP, type control-G and try +things again. + +Control-L and control-K will redisplay LMODEM commands while you +are typing them. + +The commands (ascii-stat "") and (com-stat "") +can be used to print the size that a file would be on CP/M. + +LMODEM keeps a log file named LMDLOG that tries to indicate +what kinds of errors happen during transfers. The file can be +examined after you kill LMODEM with (QUIT) (or ^Z and :kill). +In problematic cases it is also possible to find out the entire +sequence of characters sent and received by LMODEM if a flag is +set before the transfer; contact BUG-LMODEM if you need this. + +SEND-ASCII-FILE, etc. may be abbreviated as SAF, SCF, RAF, and RCF. + +Send mail to BUG-LMODEM at AI, ML, or MC if you have problems or +questions. diff --git a/doc/programs.md b/doc/programs.md index 9e02df3e..3b70bb8f 100644 --- a/doc/programs.md +++ b/doc/programs.md @@ -193,6 +193,7 @@ - LISP11, PDP-11 Lisp. - LIVE, PALX Game of Life. - LLOGO, Logo implemented in Maclisp. +- LMODEM, Xmodem file transfer. - LOADP, displays system load. - LOCK, shut down system. - LOGASS, 6502 assembler in Logo. diff --git a/src/cpm/help.lmodem b/src/cpm/help.lmodem new file mode 120000 index 00000000..26253f02 --- /dev/null +++ b/src/cpm/help.lmodem @@ -0,0 +1 @@ +_info_/lmodem.help \ No newline at end of file diff --git a/src/eb/dsk8.33 b/src/eb/dsk8.33 new file mode 100644 index 00000000..bf45d6cd --- /dev/null +++ b/src/eb/dsk8.33 @@ -0,0 +1,185 @@ +;; -*- lisp -*- + +; 8-bit disk storage SFA + +(herald DSK8 >) + +(eval-when (eval compile) + (or (get 'extmac 'version) + (load '((lisp)extmac))) + (or (get 'iota 'macro) + (load "liblsp;iota")) + (or (get 'condition-handlers 'macro) + (load "eb;signal")) + (or (get 'er-error 'macro) + (load "eb;errmac")) + (or (get 'declare-sfa-layout 'macro) + (load "eb;sfadcl"))) + +(defun signalling-open (f options) + (let ((v (errset (open f options)))) + (if (null v) + (signal 'open-error f options) + (car v)))) + +(declare-sfa-layout 8-bit-disk-sfa (file direction untyi-stack + word bits-to-right eoffn + nominal-direction)) + +(defvar *dsk8-sixbit (car (pnget 'dsk8 6))) + +(defun 8-bit-disk-sfa-handler (sfa op val) + (prog (direction n btr w) + (or (setq direction (8-bit-disk-sfa-direction sfa)) + (memq op '(which-operations close filemode open renamef truename)) + (er-error "~A operation on closed SFA (~A)." op sfa)) + (go dispatch) + wrong-direction + (er-error "SFA (~A) open in wrong direction for ~A operation." + sfa op) + dispatch + (return (caseq op + (tyi (or (eq direction 'input) + (go wrong-direction)) + (if (8-bit-disk-sfa-untyi-stack sfa) + (pop (8-bit-disk-sfa-untyi-stack sfa)) + (condition-handlers c + ((EOF (file) + (or (fixp val)(setq val -1)) + (let ((f (8-bit-disk-sfa-eoffn sfa))) + (if f (funcall f sfa val) + (close sfa) + val)))) + (setq btr (8-bit-disk-sfa-bits-to-right sfa)) + (cond ((< btr 0) + (setf btr 28. + w (in (8-bit-disk-sfa-file sfa)) + (8-bit-disk-sfa-word sfa) w)) + (t (setq w (8-bit-disk-sfa-word sfa)))) + (setq n (load-byte w btr 8.)) + (setf (8-bit-disk-sfa-bits-to-right sfa) + (- btr 8.)) + n))) + (tyo (or (eq direction 'output)(go wrong-direction)) + (setq btr (8-bit-disk-sfa-bits-to-right sfa)) + (cond ((< btr 0) + (setf btr 28. w 0.) + (out (8-bit-disk-sfa-file sfa) + (8-bit-disk-sfa-word sfa))) + (t (setq w (8-bit-disk-sfa-word sfa)))) + (setq w (deposit-byte w btr 8. val)) + (setf (8-bit-disk-sfa-bits-to-right sfa) (- btr 8.) + (8-bit-disk-sfa-word sfa) w) + t) + (untyi (or (eq direction 'input)(go wrong-direction)) + (push val (8-bit-disk-sfa-untyi-stack sfa)) + val) + (which-operations + (caseq direction + (nil '(tyi tyo untyi open close filemode renamef lengthf eoffn + truename)) + (input '(tyi untyi open close filemode renamef lengthf eoffn + truename)) + (output '(tyo open close filemode renamef truename)))) + (truename (truename (8-bit-disk-sfa-file sfa))) + (open + (and val (atom val)(setq val (ncons val))) + (loop for option in val + unless (memq option '(dsk in out image)) + do (er-error "Open keyword (~A) is not DSK, IN, OUT, or IMAGE." + option)) + (and direction (close sfa)) ; flush buffers, etc. + (cond ((or (memq 'out val) + (and (null val)(eq (8-bit-disk-sfa-nominal-direction sfa) + 'output))) + (signalling-open (8-bit-disk-sfa-file sfa) '(dsk out fixnum)) + (setq btr 28.) + (setq direction 'output) + (out (8-bit-disk-sfa-file sfa) *dsk8-sixbit)) + (t (signalling-open (8-bit-disk-sfa-file sfa) '(dsk in fixnum)) + (setq btr -4.) + (setq direction 'input) + (eoffn (8-bit-disk-sfa-file sfa) + #'(lambda count + (signal 'EOF (arg 1)))) + (setq w (condition-handlers c ((EOF (file) + (fool-the-compiler file) + 0)) + (in (8-bit-disk-sfa-file sfa)))))) + (setf (8-bit-disk-sfa-word sfa) 0) + (setf (8-bit-disk-sfa-bits-to-right sfa) btr) + (setf (8-bit-disk-sfa-eoffn sfa) nil) + (recompute-8-bit-disk-sfa-pname sfa direction) + (setf (8-bit-disk-sfa-direction sfa) direction) + (cond ((and (eq direction 'input) + (not (= w *dsk8-sixbit))) + (close sfa) + (signal 'invalid-file-format sfa))) + sfa) + (close + (if (null direction) nil + (and (eq direction 'output) + (out (8-bit-disk-sfa-file sfa) (8-bit-disk-sfa-word sfa))) + (close (8-bit-disk-sfa-file sfa)) + (setf (8-bit-disk-sfa-direction sfa) nil) + t)) + (renamef ; doing renamef on file object will close it, + ; so must flush buffered word etc. + (and (eq direction 'output) + (out (8-bit-disk-sfa-file sfa) + (8-bit-disk-sfa-word sfa))) + (renamef (8-bit-disk-sfa-file sfa) val) + (close (8-bit-disk-sfa-file sfa)) ; paranoia & clarity + (setf (8-bit-disk-sfa-direction sfa) nil) + (recompute-8-bit-disk-sfa-pname sfa direction) + sfa) + (filemode + (and direction (cons '(SFA) (sfa-call sfa 'which-operations nil)))) + (eoffn (or (eq direction 'input)(go wrong-direction)) + (setf (8-bit-disk-sfa-eoffn sfa) (car val)) + (car val)) + (lengthf (or (eq direction 'input)(go wrong-direction)) + (* 4. (1- (lengthf (8-bit-disk-sfa-file sfa))))) + (t (er-error "Attempt to invoke unsupported operation ~A on ~A." + op sfa))))))) + +(defun recompute-8-bit-disk-sfa-pname (sfa direction) + (setf (8-bit-disk-sfa-nominal-direction sfa) direction) + (setf (sfa-get sfa 'pname) + (symbolconc (if (eq direction 'output) + '|8-bit output to | + '|8-bit input from |) + (namestring + (truename (8-bit-disk-sfa-file sfa)))))) + +(defun create-8-bit-disk-sfa (filename keywords) + (let ((fob (open "NUL:" '(in fixnum))) + (sfa (sfa-create '8-bit-disk-sfa-handler + (8-bit-disk-sfa-storage-size) + 'not-initialized))) + (close fob) + (cnamef fob (mergef filename defaultf)) + (setf (8-bit-disk-sfa-file sfa) fob) + (condition-handlers c ((open-error (f options) + (signal 'open-error filename options))) + (open sfa keywords)))) + +(defun convert-old-format-com-file (f) + (setq f (namelist f)) + (let ((dir (car f)) + (w)) + (iota ((old f '(dsk in fixnum)) + (new `(,dir _CONV_ OUTPUT) '(dsk out fixnum))) + (out new *dsk8-sixbit) + (setq w (in old)) + (if (= w *dsk8-sixbit) + (progn (er-warn "~A already looks like DSK8 format, not converting." + (namestring f)) + nil) + (out new w) + (loop for i from 2 to (lengthf old) + do (out new (in old))) + (close old) + (renamef new f))))) + +(defun fool-the-compiler (x) x) diff --git a/src/eb/errmac.84 b/src/eb/errmac.84 new file mode 100644 index 00000000..ab60cb87 --- /dev/null +++ b/src/eb/errmac.84 @@ -0,0 +1,341 @@ +;;; -*- lisp -*- +;;; No Tabs!! + +(eval-when (eval compile) + (and (status feature Multics) + (or (status macro /#) + (load ">udd>Mathlab>Lisp>sharpsign")))) + +#+Multics (%include "lisp_prelude") + +#+Multics (lisp-need-at-compile-time backquote defmacro let loop + format) +#+Multics ;(lisp-need-at-run-time format) + (load ">udd>Student>EBarton>format") +#+Multics (declare (*lexpr format)(special compiler-state)) + +#+Multics (or (status feature compiler) + (setq compiler-state nil)) + +#-Multics (herald errmac >) + +#+ITS +(eval-when (eval compile load) + (or (get 'defmacro 'macro) ; yes, runtime too + (load '((lisp) defmacro))) + (or (fboundp 'format) + (load '((lisp)format)))) + +#+ITS +(eval-when (compile eval) + (or (get 'loop 'macro) + (load '((liblsp) loop)))) + +(*rset t) + +;; Rewritten to use special macro-defining form and hairy +;; FORMAT features, and to not use crockish examination of +;; FORMAT call arguments. Some functions are now of marginal +;; usefulness. + +;; Now uses FAIL-ACT error channel rather than explicit BREAK +;; for better interaction with ERRSET. + +;; An error produced with macros in this file has three +;; basic parts: +;; +;; +;; +;; (ER-ERROR ... args ...) does all of these. +;; (ER-ERROR-HEADER) does only the header. +;; (ER-ERROR-NO-HEADER ... args ...) omits the header. +;; (ER-ERROR-0) enters the error loop. +;; ER-CONTINUE-WARN can be used to print additional error messages +;; if needed. + +;; Similarly, for warnings there are +;; (ER-WARN ... args ... ), +;; (ER-WARN-HEADER), +;; (ER-WARN-NO-HEADER ... args ...), +;; (ER-CONTINUE-WARN ... args ...). +;; The last two are identical. + +;; In addition, there are ER-CONDITIONAL- versions of +;; all of these macros. They take an additional first +;; argument that is a Boolean. + + + +(defvar *er-topfn-symbol) + +(eval-when (eval load) + (and (status feature #+Multics compiler #-Multics complr) + (setq *er-topfn-symbol + #-Multics + (let ((obarray sobarray)) + (implode '(T O P F N))) + #+Multics + (let ((obarray cobarray)) + (intern (make_atom "current-function")))))) + +;; Stack-Crawling Functions leading up to ER-FIND-MACRO-CALLER + +(defun er-unique (x) + (loop for zt on x + unless (memq (car zt)(cdr zt)) + collect (car zt))) + +(defun er-walk-find (form superform) + (if (eq form superform) t + (caseq (typep superform) + (symbol nil) + (list (loop for l /= superform then (cdr l) + until (atom l) + when (er-walk-find form (car l)) return t + finally (return nil))) + (t nil)))) + +(defun er-find-form-in-defs (form fns) + (prog (atoms f prop val) + (setq atoms (loop for fn in fns when (eq (typep fn) 'symbol) collect fn)) + atom-loop + (and (null atoms) (go try-lambdas)) + (setq f (pop atoms)) + atom-loop-1 + (desetq (prop val) (getl f '(expr fexpr subr lsubr macro))) + (or (memq prop '(expr fexpr macro)) + (go atom-loop)) + (cond ((atom val) + (setq f val) + (go atom-loop-1))) + (and (er-walk-find form val) + (return f)) + (go atom-loop) + try-lambdas + (return (loop for fn in (reverse fns) + when (and (eq (typep fn) 'list) + (eq (car fn) 'lambda) + (er-walk-find form (cddr fn))) + do (return fn))))) + +(defun er-get-stacked-functions () + #+PDP10 (mapcar 'car (baklist)) + #-PDP10 (loop as pdlptr = nil then (cadr evalframe) + as evalframe = (evalframe pdlptr) + until (null evalframe) + collect (car (caddr evalframe))) + ) + +(declare (special f fa)) + +(defun er-find-macro-caller (form) + ;; Crock function to attempt to determine in what function a + ;; macro call appears. Returns NIL if it can't tell. + ;; Assumes that FORM is currently under evaluation or compilation. + ;; We always search the stack because otherwise we screw up if + ;; during the expansion of a macro whose defn is interpreted + ;; we encounter a call to ER-ERROR. If we don't search the stack + ;; in that case we will get the wrong function name. + (prog (f fa) + (cond ((null *rset) + (format #+ITS msgfiles #+Multics t + "~&;Setting *RSET to T for convenience of ERRMAC macros~%") + (*rset t) + (return nil))) + (setq f (er-find-form-in-defs form (er-get-stacked-functions))) + (if (null f) + (cond ((memq compiler-state '(compile maklap)) + (return (symeval *er-topfn-symbol))) + (t (return nil)))) + (and (null f)(return nil)) + (and (atom f)(return f)) + (mapatoms #'(lambda (a) + (and (eq f (get a 'macro)) + (setq fa a)))) + (return fa))) + +(declare (unspecial f fa)) + + +;; (DEFINE-*CALLER-MACRO +;;
+;; ) +;; is something of a crock for defining the other macros. +;; It may break if DEFMACRO is changed. Its output calls +;; ER-FIND-MACRO-CALLER. + +#+PDP10 +(defmacro define-*caller-macro (name arglist form1 form2) + (let* ( (defmacro-displace-call nil) + (defmacro-value + (funcall (get 'defmacro 'macro) + `(defmacro ,name ,arglist + (cond (*caller ,form1) + (t ,form2))))) + (defmacro-macro-form + (assq 'macro defmacro-value)) + name1 + ((nil name-clause (macroarg) . body) defmacro-macro-form)) + (if defmacro-macro-form 'OK + (format msgfiles "~&; Bug in DEFINE-*CALLER-MACRO.~%~ + ; DEFMACRO result has no MACRO form:~%~ + ; ~S~%" defmacro-value) + (error '|| 'error 'fail-act)) + (if (and (eq (car defmacro-value) 'progn) + (equal (cadr defmacro-value) ''compile)) + 'OK + (format msgfiles "~&; Bug in DEFINE-*CALLER-MACRO.~%~ + ; DEFMACRO result not (PROGN 'COMPILE ...):~%~ + ; ~S~%" defmacro-value) + (error '|| 'error 'fail-act)) + (setq name1 (if (atom name-clause) name-clause (car name-clause))) + (if (eq name name1) + 'OK + (format msgfiles + "~&; Bug in DEFINE-*CALLER-MACRO.~%~ + ; Def form from DEFMACRO has wrong name.~%~ + ; Original name ~S, macro name ~S.~%" + name name1) + (error '|| 'error 'fail-act)) + (let ((lambda-expression `(lambda (,macroarg) ,@ body)) + (temp (gensym))) + (loop for form in defmacro-value + collect (if (eq form defmacro-macro-form) + `(defun (,name macro) (,macroarg) + (or (macrofetch ,macroarg) + (prog (*caller ,temp) + (setq *caller (er-find-macro-caller ,macroarg)) + (setq ,temp (,lambda-expression ,macroarg)) + (return + (cond + (*caller + (macromemo ,macroarg ,temp ',name)) + (t ,temp)))))) + form))))) + + +#+Multics +(defmacro define-*caller-macro (name arglist form1 form2) + (let* ( (defmacro-value + (funcall (get 'defmacro 'macro) + `(defmacro ,name ,arglist + (if *caller ,form1 ,form2)))) + (defmacro-defun (assq 'defun defmacro-value)) + ((nil name1 (macroarg) . body) defmacro-defun) ) + (if defmacro-defun 'OK + (format t "~&; Bug in DEFINE-*CALLER-MACRO.~%~ + ; DEFMACRO result has no DEFUN:~%~ + ; ~S~%" defmacro-value) + (error '|| 'error 'fail-act)) + (if (eq (car defmacro-value) 'eval-when) 'ok + (format t "~&; Bug in DEFINE-*CALLER-MACRO.~%~ + ; DEFMACRO result not (EVAL-WHEN ...):~%~ + ; ~S~%" defmacro-value) + (error '|| 'error 'fail-act)) + (if (samepnamep name1(catenate name " macro")) + 'ok + (format t "~&; Bug in DEFINE-*CALLER-MACRO.~%~ + ; Def form from DEFMACRO has wrong name.~%~ + ; Original name ~S, macro name ~S.~%" + name name1) + (error '|| 'error 'fail-act)) + (let ((lambda-expression `(lambda (,macroarg) ,@ body)) + (temp (gensym))) + (loop for form in defmacro-value + collect (if (eq form defmacro-defun) + `(defun (,name macro) (,macroarg) + (prog (*caller ,temp) + (setq *caller (er-find-macro-caller ,macroarg)) + (setq ,temp (,lambda-expression ,macroarg)) + (return + (cond (*caller + (displace ,macroarg ,temp)) + (t ,temp))))) + form))))) + + +;; The actual macros + +(define-*caller-macro er-error (string &rest args) + `(progn (format #+ITS msgfiles + #+Multics t + "~%; Error in ~S:~%; ~1@{~:}" + ',*caller ,string ,@ args) + (er-error-0)) + `(progn (format #+ITS msgfiles + #+Multics t + "~%; ~1@{~:}" + ,string ,@ args) + (er-error-0))) + +(define-*caller-macro er-error-header () + `(format #+ITS msgfiles + #+Multics t + "~%; Error in ~S:~%" ',*caller) + '(progn nil)) + +(defmacro er-error-no-header (msg &rest args) + `(progn (format #+ITS msgfiles + #+Multics t + ,msg ,@ args) + (er-error-0))) + +(defmacro er-error-0 () + '(progn (error '|| 'error 'fail-act) + (^g))) + +(define-*caller-macro er-warn (string &rest args) + `(format #+ITS msgfiles + #+Multics t + "~&; Warning from ~S:~%; ~1@{~:}~%" + ',*caller ,string ,@ args) + `(format #+ITS msgfiles + #+Multics t + "~&; ~1@{~:}~%" ,string ,@ args)) + +(define-*caller-macro er-warn-header () + `(format #+ITS msgfiles + #+Multics t + "~&; Warning from ~S:~%" ',*caller) + '(progn nil)) + +(defmacro er-warn-no-header (msg &rest args) + `(er-continue-warn ,msg ,@ args)) + +(defmacro er-continue-warn (msg &rest args) + `(format #+ITS msgfiles + #+Multics t + "~&; ~1@{~:}~%" ,msg ,@ args)) + + +;; Conditional versions. + +#-Multics (declare (setq defmacro-for-compiling nil)) + +#+Multics (eval-when (eval compile load) + (defun symbolconc (x y) + (intern (make_atom (catenate x y))))) + +(defmacro er-define-conditional (what) + `(progn 'compile + (defmacro ,(symbolconc 'er-conditional- what) + (condition &rest args) + `(and ,condition + (,',(symbolconc 'er- what) + ,@ args))))) + +#-Multics (declare (setq defmacro-for-compiling t)) + +(er-define-conditional warn) +(er-define-conditional warn-header) +(er-define-conditional warn-no-header) +(er-define-conditional continue-warn) + +(er-define-conditional error) +(er-define-conditional error-header) +(er-define-conditional error-no-header) +(er-define-conditional error-0) + +(define-*caller-macro er-the-current-defun () + `(quote ,*caller) + '(quote unknown-function)) diff --git a/src/eb/sfadcl.3 b/src/eb/sfadcl.3 new file mode 100644 index 00000000..8ea6e43f --- /dev/null +++ b/src/eb/sfadcl.3 @@ -0,0 +1,19 @@ +;;; -*- lisp -*- + +(herald SFADCL) + +(eval-when (eval load) + (or (fboundp 'symbolconc) + (load '((lisp)macaid)))) + +(eval-when (eval compile) + (or (get 'loop 'macro) + (load '((liblsp)loop)))) + +(defmacro declare-sfa-layout (name layout) + `(progn 'compile + ,@ (loop for elt in layout as i from 0 by 1 + collect `(defmacro ,(symbolconc name '- elt) (sfa) + `(sfa-get ,sfa ,,i))) + (defmacro ,(symbolconc name '-storage-size) () + '(progn ,(length layout))))) diff --git a/src/eb/signal.31 b/src/eb/signal.31 new file mode 100644 index 00000000..74e795d2 --- /dev/null +++ b/src/eb/signal.31 @@ -0,0 +1,94 @@ +; -*- lisp -*- +;; No Tabs!! +;; No Capitals!! + +(eval-when (eval compile) + (and (status feature Multics) + (or (status macro /#) + (load ">udd>Mathlab>Lisp>sharpsign")))) + +#+Multics (%include "lisp_prelude") +#+Multics (lisp-need-at-compile-time backquote defmacro let + loop) +#+Multics (eval-when (eval compile load) + (load ">udd>Student>EBarton>errmac")) +#+Multics (declare (*lexpr format)) + +#+ITS +(eval-when (eval compile) + (or (get 'loop 'version) + (load "lisp;loop")) + (or (get 'errmac 'version) + (load "eb;errmac"))) + +#-Multics (herald signal) + +(eval-when (eval compile load) + (and (status feature #+PDP10 complr #+Multics compiler) + (special *signal-comm-var-1 *signal-comm-var-2 + *signal-return-value))) + +(defmacro throw-to-signal-tag () + #+Multics '(throw nil signal) + #+PDP10 '(*throw 'signal nil)) + +(defmacro catch-with-signal-tag (&rest forms) + #+Multics `(catch (progn ,@ forms) signal) + #+PDP10 `(*catch 'signal ,@ forms)) + +(defmacro condition-handlers (cvar handlers &rest forms) + (or (eq (typep cvar) 'symbol) + (er-error "~A supplied as CVAR not a symbol" cvar)) + (or forms (er-error "No forms given: (condition-bind ~A ~A)" cvar handlers)) + (let ((default-segment + (if (memq (caar (last handlers)) '(t otherwise :otherwise)) + nil + '((t (setq *signal-comm-var-2 *signal-comm-var-1) + (throw-to-signal-tag)))))) + `(let ((*signal-comm-var-1 nil) + (*signal-return-value nil)) + (let ((*signal-comm-var-2 nil)) + (setq *signal-return-value (catch-with-signal-tag ,@ forms)) + ; A SIGNAL in the FORMS will set our *SIGNAL-COMM-VAR-2. + ; We must arrange for a SIGNAL in the HANDLERS to set + ; somebody else's. + (setq *signal-comm-var-1 *signal-comm-var-2)) + (cond ((null *signal-comm-var-1) *signal-return-value) + (t (let ((,cvar (car *signal-comm-var-1))) + (caseq ,cvar + ,@ (loop for (c-or-cs arglist . forms) in handlers + collect (or forms + (er-error "Handler has no forms:~%; ~A" + c-or-cs)) + `(,c-or-cs + (let + ((,arglist (cdr + *signal-comm-var-1))) + ,@ forms))) + ,@ default-segment))))))) + +(defmacro signal (condition &rest args) + `(progn (setq *signal-comm-var-2 (list ,condition ,@ args)) + (throw-to-signal-tag))) + +(defmacro apply-signal (condition arglist) + `(progn (setq *signal-comm-var-2 (cons ,condition ,arglist)) + (throw-to-signal-tag))) + +(defun unclaimed-signal-handler (tag) + (setq tag (car tag)) + (let ((condition (car *signal-comm-var-2)) + (args (cdr *signal-comm-var-2))) + (cond ((and (eq tag 'signal) *signal-comm-var-2) + (format #+PDP10 msgfiles #+Multics t + "~&; A condition has propagated to top level without being handled.~%~ + ; It was signalled with arguments as follows:~%~ + ; ~S ~S~%" condition (or args "()")) + nil) + (t ( #+PDP10 +internal-ugt-break + #+Multics *internal-unseen-go-tag-break + tag))))) + +(setq unseen-go-tag #'unclaimed-signal-handler) + + diff --git a/src/ejs/lmodem.255 b/src/ejs/lmodem.255 new file mode 100644 index 00000000..0547431c --- /dev/null +++ b/src/ejs/lmodem.255 @@ -0,0 +1,1437 @@ +; -*- Lisp -*- +;; No Tabs !! +;; Can't xfer back from Multics because of ctl chars!! + +(eval-when (eval compile load) + (and (status feature Multics) + (or (status macro /#) + (load ">udd>Mathlab>Lisp>sharpsign")))) + +#+Multics (%include "lisp_prelude") +#+Multics (lisp-need-at-compile-time backquote defmacro let loop + format) +#+Multics ;(lisp-need-at-run-time format) + (load ">udd>Student>EBarton>format") +#+Multics (eval-when (eval compile load) + (load ">udd>Student>EBarton>errmac")) +#+Multics (eval-when (eval compile) + (load ">udd>Student>EBarton>signal")) +#+Multics (declare (*lexpr format)) + +#+Multics (defmacro lexpr-funcall (f &rest args) + `(apply ,f (list* ,@ args))) + +#+Multics (defmacro fboundp (x) `(getl ,x '(expr fexpr subr fsubr lsubr macro))) + +#+Multics +(declare + (defpl1 get_input_char "do_get_chars_io_call" + (return fixed bin (35.))) + (defpl1 put_output_char "do_put_chars_io_call" + (fixed bin (35.)))) + +#+ITS (herald LMODEM >) + +#+ITS +(eval-when (eval compile) + (or (get 'signal 'version) + (load "eb;signal")) + (or (get 'umlmac 'version) + (load "lisp;umlmac")) + (or (get 'errmac 'version) + (load "eb;errmac")) + (or (get 'iota 'version) + (load "liblsp;iota")) + (or (get 'loop 'version) + (load "liblsp;loop"))) + +#+Multics (defmacro logand (x y) `(boole 1 ,x ,y)) +#+Multics (defmacro logior (x y) `(boole 7 ,x ,y)) +#+Multics (defmacro lognot (x) `(boole 6 ,x -1)) + +#+ITS +(eval-when (eval) + (or gc-daemon (load "liblsp;gcdemn"))) + +#+ITS +(eval-when (eval compile load) + (or (get 'format 'version) + (load "lisp;format"))) + +#+Multics (declare (special /#\-alist)) + +(eval-when (eval compile) + #+ITS + (or (get 'sharpm 'version) + (load "lisp;sharpm")) + #+ITS + (defun define-symbolic-character (sym n) + (declare (special /#-symbolic-characters-table)) + (or (assq sym /#-symbolic-characters-table) + (push (cons sym n) /#-symbolic-characters-table))) + #+Multics + (defun define-symbolic-character (sym n) + (let ((string (get_pname sym))) + (or (assoc string /#\-alist) + (push (cons string n) /#\-alist)))) + (define-symbolic-character 'nul 0.) + (define-symbolic-character 'soh #^A) + (define-symbolic-character 'eot #^D) + (define-symbolic-character 'ack #^F) + (define-symbolic-character 'nak #^U) + (define-symbolic-character 'can #^X) + ; These next are ITS-only but must be defined on Multics + ; too so the reader won't barf. + (define-symbolic-character '%tdqot #O 215) + (define-symbolic-character 'telnet-iac #O 377) + (define-symbolic-character 'telnet-do #O 375) + (define-symbolic-character 'telnet-dont #O 376) + (define-symbolic-character 'telnet-will #O 373) + (define-symbolic-character 'telnet-wont #O 374) + (define-symbolic-character 'telnet-trnbin #O 0)) + +#+ITS +(eval-when (eval load) + (or (get 'yesnop 'version) + (load "lisp;yesnop")) + (or (get 'defmax 'version) + (load "lisp;defmax")) + (or (get 'macaid 'version) + (load "lisp;macaid")) + (or (get 'dsk8 'version) + (load "eb;dsk8"))) + +#+Multics +(defun signalling-open (f options) ; from DSK8 + (let ((v (errset (open f options)))) + (if (null v) + (signal 'open-error f options) + (car v)))) + + +#+ITS +(defmacro to-sixbit (x) + `(car (pnget ,x 6.))) + +#+ITS +(defun from-sixbit (n) + (er-conditional-error (not (fixp n)) "~A is not a fixnum." n) + (let ((six-bit-bytes (loop for i from 30. downto 0. by 6. + collect (load-byte n i 6.))) + trailing-zero-tail ) + (loop for bt on six-bit-bytes unless (= (car bt) 0) + do (setq trailing-zero-tail bt)) + (setq trailing-zero-tail (cdr trailing-zero-tail)) + (implode + (loop for bt on six-bit-bytes until (eq bt trailing-zero-tail) + collect (+ (car bt) #\sp))))) + + + + +;; Log Files + +(defvar *log-flag t) +(defvar *log-error-messages t) +(defvar *log-status-messages nil) +(defvar *log-chars-received nil) +(defvar *log-chars-sent nil) + +(defun filename-defaults () + #+ITS `((DSK ,(status hsname)) ,(status xuname) >) + #+Multics `(,(status udir) lmodem_file txt)) + +(defun log-filename-defaults () + #+ITS `((DSK ,(status hsname)) ,(status xuname) LMDLOG) + #+Multics `(,(status udir) lmodem log)) + +(defvar *log-file 'not-initialized + "File object for log messages.") + +(defvar *log-character-direction 'received + "Last direction for a logged character. This is so that + characters sent by the slave can be enclosed in braces {}.") + +(defun begin-log-file (&optional (name #+ITS '((* *) * *) #+Multics '(* * *) + name-supplied)) + (condition-handlers c + ((open-error (f options) + (format #+ITS msgfiles #+Multics t "~%Can't open log file.~%") + (setq *log-flag nil) + nil)) + (end-log-file) + (setq name (mergef name (log-filename-defaults))) + (setq *log-file (signalling-open name '(dsk out single))) + (setq *log-character-direction 'received) + (setq *log-flag t) + (init-log-file) + *log-file)) + +(defun end-log-file () + (prog2 nil (and *log-flag *log-file) + (setq *log-flag nil) + (and #+ITS (or (filep *log-file) + (sfap *log-file)) + #+Multics (filep *log-file) + (close *log-file)))) + +(defun log-character (n direction numberp) + (caseq direction + (received (or (eq *log-character-direction 'received) + (tyo #/} *log-file))) + (sent (or (eq *log-character-direction 'sent) + (tyo #/{ *log-file))) + (t (er-error "Bad direction: ~A" direction))) + (setq *log-character-direction direction) + (cond (numberp (format *log-file "[~O]" n)) + ((member n '(#\cr #\lf)) (tyo n *log-file)) + ((< n #.(1+ #^Z)) + (format *log-file + (caseq n + (#\nul "[nul]") + (#\soh "[soh]") + (#\eot "[eot]") + (#\tab "[tab]") + (#\ack "[ack]") + (#\nak "[nak]") + (#\can "[can]") + (t "[~@C]")) n)) + ((= n #\rubout) + (format *log-file "[del]")) + ((= n #/[) + (format *log-file "[(]")) + ((= n #/]) + (format *log-file "[)]")) + ((= n #/{) + (format *log-file "[{]")) + ((= n #/}) + (format *log-file "[}]")) + ((< n #O 200) + (tyo n *log-file)) + (t (format *log-file "[~O]" n)))) + +(defun log-status (format &rest args) + (if (eq *log-character-direction 'sent) + (tyo #/} *log-file)) + (setq *log-character-direction 'received) + (format *log-file "~&>> ") + (lexpr-funcall #'format *log-file format args) + (terpri *log-file)) + + +;; Time-out Interrupt + +(defun alarmclock-handler ignored + (nointerrupt nil) + (signal 'timeout)) + +(defmacro timing-out-after (seconds &rest forms) + (or forms (er-error "No forms.")) + `(let ((alarmclock 'alarmclock-handler)) + (alarmclock 'time ,seconds) + ,@ forms)) + +(setq alarmclock nil) + +(defvar *short-timeout 3.0) +(defvar *error-line-clear-timeout 5.0) +(defvar *medium-timeout 15.0) +(defvar *initial-timeout 80.0) + + +;; Disk Input and Output Routines + +(defvar *disk-input 'not-initialized + "Character source. Must be capable of having an EOFFN.") + +(defvar *disk-input-eof nil + "Indicates whether *DISK-INPUT is in EOF state.") + +(defvar *disk-output 'not-initialized + "Destination file for blocks received.") + +(defvar *assume-7-bit-disk t + "Should be set up as NIL if we ever implement an SFA for storing + 8-bit characters on disk. See also *ASSUME-7-BIT-LINE.") + +(defvar *stop-on-data-truncation t + "If a bit is about to be lost and this flag is T, we abort + the transmission.") + +(defvar *sector-number 0 + "Number of sector being received or transmitted. Internal value + has same width as data path, for program convenience.") + +(defvar *sector-array + (array nil fixnum 128.) + "Array for character buffer, indexed from 0 to 127.") + +(defmacro sector-array (i) + `(arraycall fixnum *sector-array ,i)) + +(defvar *micro-sector-pad-char #^Z + "Disk input filled out to 128-byte multiple with this character.") + +(defvar *control-c-is-its-logical-eof t + "If this is T, control-C from *DISK-INPUT will be taken as + logical EOF and any following characters will not be transmitted.") + +(defun disk-input-eoffn ignored + (signal 'disk-input-eof t)) + +(defun read-sector () + "Reads a set of characters from *DISK-INPUT, padding if necessary. + Returns T if successful, NIL if there were no more characters to + read. Increments *SECTOR-NUMBER." + (prog (i) + (setq i 0) + (if *disk-input-eof (return nil)) ; EOF on the previous sector + (condition-handlers c ((disk-input-eof (real?) + (and *log-flag *log-status-messages + (log-status + "~:[Logical ~;~]EOF on *DISK-INPUT after ~D. characters of sector." + real? i)) + (setq *disk-input-eof t))) + (loop while (< i 128.) + as n fixnum = (tyi *disk-input) + when (and (= n #^C) *control-c-is-its-logical-eof) + do (signal 'disk-input-eof nil) + do (setf (sector-array i) n) + (setq i (1+ i)))) + (if (= i 0)(return nil)) ; no characters + (if *disk-input-eof + (loop while (< i 128.) do (setf (sector-array i) + *micro-sector-pad-char) + (setq i (1+ i)))) + (setq *sector-number (truncate-to-line-width (do-INC *sector-number))) + (return t))) + +(declare (fixnum (check-for-7-bit-disk fixnum))) + +(defun check-for-7-bit-disk (n) + (if (or (not *assume-7-bit-disk) + (< n #O 400)) + n + (and *log-flag *log-error-messages + (log-status "Warning: Character (~O) being ~ + truncated for disk storage!" n)) + (if *stop-on-data-truncation + (signal 'data-truncation n)) + (logand n #O 177))) + +(declare (notype (write-sector-1 fixnum))) + +(defvar *pad-char-is-logical-eof t + "If this is T, data bytes after an occurrence of *MICRO-SECTOR-PAD-CHAR + will not be written to disk. See also *CONTROL-C-IS-ITS-LOGICAL-EOF.") + +(defvar *extra-sector-limit 1. + "No more than *EXTRA-SECTOR-LIMIT sectors will be accepted after + logical EOF. The variable exists in case DDT and SAVE are used + to move text files from one diskette to another on a single-disk + system. In that case the second sector on a saved page may contain + garbage.") + +(defvar *internal-extra-sector-limit -1 + "WRITE-SECTOR decrements this variable. If the result is zero, + the variable is reset to +1 and EXTRA-SECTOR () is signalled. + If the result is negative, the sector is written. If the result + is positive, the sector is ignored.") + +(defun write-sector () + "Writes a set of characters to *DISK-OUTPUT. There is always a full + set of characters. *INTERNAL-EXTRA-SECTOR-LIMIT is hacked." + (setq *internal-extra-sector-limit (1- *internal-extra-sector-limit)) + (cond ((> *internal-extra-sector-limit 0) 'ignore-sector) + ((= *internal-extra-sector-limit 0) + (setq *internal-extra-sector-limit 1.) + (signal 'extra-sector)) + (t (loop for i from 0. to 127. + do (write-sector-1 (sector-array i)))))) + +(defun write-sector-1 (n) + (cond ((and (= n *micro-sector-pad-char) + *pad-char-is-logical-eof + (< *internal-extra-sector-limit 0)) + (and *log-flag *log-status-messages + (log-status "Logical EOF received, ignoring any following characters.")) + (setq *internal-extra-sector-limit (1+ (max *extra-sector-limit 0)))) + ((< *internal-extra-sector-limit 0) + (tyo (check-for-7-bit-disk n) *disk-output)) + (t 'ignore-character))) + + +;; Image Input and Output for TTY + +#+ITS (defvar *ttyifo (status ttyifo)) +#+ITS (defvar *ttyofo (status ttyofo)) + +;; For TTY input, we must have the TTY open in image mode. +;; We'll break all the interrupt characters, of course. +;; For TTY output, we must also open in image mode. + +(defvar *assume-7-bit-line t + "Primarily controls whether checksums and complemented block + numbers are sent and compared as 7 bits or 8. Rumor has it that + the AI dialup hardware won't permit the transmission of 8-bit + data. See also *ASSUME-7-BIT-DISK.") + +#+ITS (defvar *source-is-telser nil) ; set by initialization routines +#+ITS (defvar *telser-plist 'not-initialized) + +#+ITS +(defvar *crtsty-flag nil + "We have to quote twice as much if going through CRTSTY, if 8-bit + mode is going to work. Set by init routines.") + +(defvar *image-input-from-tty t) + +#+ITS (defvar *image-output) +#+ITS (defvar *image-input) + +#+ITS (defvar *ttyint-array) + +#+ITS (defvar *normal-ttyst1) +#+ITS (defvar *normal-ttyst2) +#+ITS (defvar *normal-ttysts) +#+ITS (defvar *normal-ttyopt) +#+ITS (defvar *normal-ttycom) +#+ITS (defvar *ttyopt-sixbit (to-sixbit 'ttyopt)) +#+ITS (defvar *ttycom-sixbit (to-sixbit 'ttycom)) +#+ITS (defvar *image-ttyopt) +#+ITS (defvar *image-ttysts) +#+ITS (defvar *image-ttycom) + +#+ITS +(defun backspace-error ignored + (format tyo "~&Do not use backspaces. Use rubouts to delete.~%") + (clear-input tyi) + (^g)) + +#+ITS +(defun syscall-1-a (call args lexical-defun) + (let ((val (lexpr-funcall #'syscall 1. call + (loop for x in args + collect (if (eq (typep x) 'symbol) + (to-sixbit x) + x))))) + (if (listp val) (car val) + (er-error-no-header "~%; Error in ~S:~%~ + ; ~A call got error ~O." + lexical-defun call val)))) + +#+ITS +(define-*caller-macro syscall-1 (call &rest args) + `(syscall-1-a ,call (list ,@ args) ',*caller) + `(syscall-1-a ,call (list ,@ args) "unidentified function")) + +#+ITS +(defun snarf-normal-tty-variables () + (setq *normal-ttyopt (syscall-1 'ttyvar *ttyifo 'ttyopt)) + (setq *normal-ttycom (syscall-1 'ttyvar *ttyifo 'ttycom)) + (desetq (*normal-ttyst1 *normal-ttyst2 *normal-ttysts) + (syscall 3. 'ttyget *ttyifo)) + ; Special hack to prevent losers from using backspace: + (setq *normal-ttyst2 (logior *normal-ttyst2 #O 1)) + (syscall 0. 'ttyset *ttyifo *normal-ttyst1 *normal-ttyst2 *normal-ttysts) + (sstatus ttyint #^H #'backspace-error) + (setq *ttyint-array (*array nil t #O 200)) + (loop for i from 0 to #O 177 + do (setf (arraycall t *ttyint-array i) (status ttyint i))) + ; in TTYOPT: Clear %TOALT, %TOCLC, %TPPRN, %TPTEL. + ; Set %TPMTA, %TOFCI. + ; in TTYSTS: Set %TSSII. + ; in TTYCOM: Set %TCRFS. + (setq *image-ttyopt + (logand *normal-ttyopt (lognot #O 30000000300))) + (setq *image-ttyopt + (logior *image-ttyopt #O 410)) + (setq *image-ttysts (logior *normal-ttysts #O 2000000)) + (setq *image-ttycom (logior *normal-ttycom #O 10000000000))) + +#+ITS (defvar *telser-adjustment-delay 4.0) +#+ITS (defvar *permit-negotiation-refusal nil + "If this is T, transfers may be attempted even though the TIP + refuses to enter binary mode.") + +#+ITS +(defun send-telnet-command (l) + (loop for n in l do (and *crtsty-flag (quote-and-output #\%tdqot)) + (quote-and-output n)) + (syscall 0. 'finish *image-output)) + +#+ITS +(defun open-tty-image () + (setq *image-output (open "TTY:" '(tty out single image))) + (setq *image-input (open "TTY:" '(tty in single fixnum))) + (syscall 0. 'ttyset *ttyofo #O 020202020202 #O 020202020202 *image-ttysts) + (syscall 0. 'ttyvar *ttyofo *ttyopt-sixbit *image-ttyopt) + (syscall 0. 'ttyvar *ttyofo *ttycom-sixbit *image-ttycom) + (loop for i from 0 to #O 177 + do (sstatus ttyint i nil)) + (and *source-is-telser + (do-binary-mode-telser-negotiation 'enter)) + (valret '|:nomsg 0/ +:contin |) + (if *log-file + (setq msgfiles (list tyo *log-file))) + T) + +#+Multics +(defun open-tty-image () + (cline + "stty -modes rawi,rawo,breakall,8bit,no_outp,^echoplex,^lfecho,^crecho")) + +#+Multics +(defun restore-tty () + (cline + "stty -modes ^rawi,^rawo,^breakall,^8bit,^no_outp,echoplex,lfecho,crecho")) + +#+Multics +(defun restore-tty-except-for-superimage-mode () + (restore-tty)) + +#+ITS +(defun restore-tty () + (restore-tty-except-for-superimage-mode) + (syscall 0. 'ttyset *ttyofo *normal-ttyst1 *normal-ttyst2 *normal-ttysts) + (loop for i from 0 to #O 177 + do (sstatus ttyint i (arraycall t *ttyint-array i))) + (valret '|:nomsg 1/ +:contin |)) + +#+ITS +(defun restore-tty-except-for-superimage-mode () + ; can't restore :nomsg here because of obscure lossage + (if (not (boundp '*image-output)) + 'not-initialized-yet + (and *source-is-telser + (filep *image-output) + (status filemode *image-output) + (do-binary-mode-telser-negotiation 'exit)) + (close *image-input) + (close *image-output)) + (syscall 0. 'ttyset *ttyifo *normal-ttyst1 *normal-ttyst2) + (syscall 0. 'ttyvar *ttyofo *ttyopt-sixbit *normal-ttyopt) + (syscall 0. 'ttyvar *ttyofo *ttycom-sixbit *normal-ttycom) + (loop for i in '(#^G #^H) + do (sstatus ttyint i (arraycall t *ttyint-array i))) + (setq msgfiles '(t))) + +#+ITS +(defun do-binary-mode-telser-negotiation (enter-or-exit) + (or (listp *telser-plist) + (er-error "*TELSER-PLIST is not set up.")) + (let ((trbinp #O 126) + (rcbinp #O 127)) + (cond ((eq enter-or-exit 'enter) + (if (get *telser-plist 'has-binary-negotiation-variables) + (progn (negotiate-binary-with-telser-variable + #\telnet-will trbinp -1 (not *permit-negotiation-refusal) + "TIP refuses to receive in binary mode.") + (negotiate-binary-with-telser-variable + #\telnet-do rcbinp -1 (not *permit-negotiation-refusal) + "TIP refuses to transmit in binary mode.")) + (send-telnet-command '(#\telnet-iac #\telnet-will #\telnet-trnbin)) + (sleep *telser-adjustment-delay) + (send-telnet-command '(#\telnet-iac #\telnet-do #\telnet-trnbin)) + (sleep *telser-adjustment-delay))) + ((eq enter-or-exit 'exit) + (if (get *telser-plist 'has-binary-negotiation-variables) + (progn (negotiate-binary-with-telser-variable + #\telnet-wont trbinp 0 nil + "TIP refuses stop receiving in binary mode.") + (negotiate-binary-with-telser-variable + #\telnet-dont rcbinp 0 nil + "TIP refuses to stop transmitting in binary mode.")) + (send-telnet-command '(#\telnet-iac #\telnet-wont #\telnet-trnbin)) + (sleep *telser-adjustment-delay) + (send-telnet-command '(#\telnet-iac #\telnet-dont #\telnet-trnbin)) + (sleep *telser-adjustment-delay))) + (t (er-error "Argument ~A is not ENTER or EXIT." enter-or-exit))))) + +#+ITS +(defun negotiate-binary-with-telser-variable (verb location value abort-on-failure + error-message) + (let* ((job-spec (get *telser-plist 'job-spec)) + (termid (syscall-1 'usrmem job-spec #O 100)) + (binary (syscall-1 'usrmem job-spec #O 125))) + (er-conditional-error (not (= termid (to-sixbit 'termid))) + "Unexpected TERMID value in TELSER.") + (er-conditional-error (not (= binary (to-sixbit 'binary))) + "Unexpected BINARY value in TELSER.") + (send-telnet-command (list #\telnet-iac verb #\telnet-trnbin)) + (loop for i from 1. to 15. + as binp = (syscall-1 'usrmem job-spec location) + when (= binp value) do (return nil) + when (not (member value '(0. -1.))) + do (er-error "Binary negotiation variable at ~O is ~A in TELSER." + location value) + do (sleep 1) + finally + (if abort-on-failure + (signal 'abort error-message) + (er-warn "~A" error-message))))) + +#+ITS +(defun maybe-recheck-TIP-connection () + (and *source-is-telser + (not *permit-negotiation-refusal) + (let* ((job-spec (get *telser-plist 'job-spec)) + (termid (syscall-1 'usrmem job-spec #O 100)) + (binary (syscall-1 'usrmem job-spec #O 125)) + (trbinp (syscall-1 'usrmem job-spec #O 126)) + (rcbinp (syscall-1 'usrmem job-spec #O 127))) + (er-conditional-error (not (= termid (to-sixbit 'termid))) + "Unexpected TERMID value in TELSER.") + (er-conditional-error (not (= binary (to-sixbit 'binary))) + "Unexpected BINARY value in TELSER.") + (or (= trbinp -1) + (signal 'abort "TIP left binary reception mode unexpectedly.")) + (or (= rcbinp -1) + (signal 'abort "TIP left binary transmission mode unexpectedly.")) + ))) + +(defun truncate-to-line-width (n) + (if *assume-7-bit-line + (logand n #O 177) + (logand n #O 377))) + +#+ITS +(defun read-line-character (seconds &optional numberp) + (let ((n (timing-out-after seconds + (car (syscall 1. 'IOT *image-input)))) + meta-bit ) + (setq meta-bit (logand n #O 400)) + (setq n (+ n (lsh meta-bit -1.))) + (setq n (truncate-to-line-width n)) + (and *log-flag *log-chars-received + (log-character n 'received numberp)) + n)) + +#+Multics +(defun read-line-character (seconds &optional numberp) + (let ((n (timing-out-after seconds (get_input_char)))) + (setq n (truncate-to-line-width n)) + (and *log-flag *log-chars-received + (log-character n 'received numberp)) + n)) + +(defun write-line-character (n &optional numberp) + (declare (fixnum n)) + (setq n (truncate-to-line-width n)) + (and *log-flag *log-chars-sent + (log-character n 'sent numberp)) + #+ITS (if *crtsty-flag (quote-and-output #\%tdqot)) + #+ITS (quote-and-output n) + #+Multics (put_output_char n) + #+ITS (cond ((and *source-is-telser (= n #\telnet-iac)) + (if *crtsty-flag (quote-and-output #\%tdqot)) + (quote-and-output #\telnet-iac))) + n) +#+Multics (declare (*lexpr write-line-character)) + +#+ITS +(defun quote-and-output (n) + (syscall 0. 'IOT *image-output #\%tdqot) + (syscall 0. 'IOT *image-output n)) + +(defun clear-tty-input-line (&optional (timeout *short-timeout)) + #+its (clear-input *image-input) + (condition-handlers c ((timeout () nil)) + (loop while t do (read-line-character timeout)))) + + +; CRTSTY passes through meta bits if %TPMTA was set before +; CRTSTY was run. We explain that to the user if they are not set, +; but only if that would help. + +; MORTON and TK-10 dialup lines cannot transmit 8 bits. + +; The only connection paths we will initially support are: +; Source = TIP or dialup +; Possible intervening CRTSTY + +; Symbolic descriptors for a link in the connection chain: +; CAR of plist: DIALUP, CRTSTY, TELSER, or UNKNOWN +; Properties for DIALUP: CONTROLLER (MORTON, TK-10, DTE-20, UNKNOWN) +; %TPMTA (T, NIL) +; %TOFCI (T, NIL) +; Properties for CRTSTY: JNAME (atom) +; STY-HAS-%TOFCI (T, NIL) +; Properties for TELSER: HOST-TYPE (ARPANET, LISP-MACHINE, PLASMA) +; TELSER-TYPE (TELSER, SUPSER, UNKNOWN) +; LOCATION-DESCRIPTION (atom) +; HOST-NUMBER (number) +; TIP-PORT-NUMBER (number or NIL) +; TTY-HAS-%TOFCI (T, NIL) +; TTY-HAS-%TPMTA (T, NIL) +; TTY-HAS-%TPTEL (T, NIL) +; HAS-BINARY-NEGOTIATION-VARIABLES (T, NIL) +; JOB-SPEC (number for USRMEM) +; Properties for UNKNOWN-STY-PROGRAM: +; UNAME (atom) +; JNAME (atom) +; Properties for UNKNOWN-INPUT-LINE: none + + +#+ITS +(defun asciz-words-to-symbol (word-list) + (implode (loop for w in word-list until (= w 0) + nconc (loop for i from 29. downto 1. by 7. + as byte = (load-byte w i 7.) + until (= byte 0) collect byte)))) + +#+ITS +(defun determine-connection-path (&optional (job-spec #O 777777)) + (reverse (determine-reversed-connection-path job-spec))) + +#+ITS +(defun determine-reversed-connection-path (job-spec) + (prog (uname6 jname6 console ttytyp xjname6) + (setq uname6 (syscall-1 'usrvar job-spec 'uname) + jname6 (syscall-1 'usrvar job-spec 'jname) + console (syscall-1 'usrvar job-spec 'cnsl)) + (and (= uname6 (to-sixbit 'telser)) (return nil)) + (and (signp le console) (return nil)) + (setq console (+ console #O 400000)) + (setq ttytyp (syscall-1 'ttyvar console 'ttytyp)) + (and (> (logand ttytyp #O 20000) 0) + (return (list (determine-dialup-properties console)))) + (or (> (logand ttytyp #O 200000) 0) + (return (list (ncons 'unknown-input-line)))) + (setq job-spec (logand #O 777777 (syscall-1 'styget console))) + (or (> job-spec 0) (er-error "STYGET returned ~O for STY mother." + job-spec)) + (setq job-spec (+ #O 400000 job-spec)) + (setq uname6 (syscall-1 'usrvar job-spec 'uname) + jname6 (syscall-1 'usrvar job-spec 'jname) + xjname6 (syscall-1 'usrvar job-spec 'xjname)) + (and (= jname6 (to-sixbit 'telser)) + (return (list (determine-telser-properties job-spec console)))) + (return (cons (if (= xjname6 (to-sixbit 'crtsty)) + (determine-crtsty-properties job-spec console) + `(unknown-sty-program uname + ,(from-sixbit uname6) + jname ,(from-sixbit jname6) + xjname ,(from-sixbit xjname6))) + (determine-reversed-connection-path job-spec))))) + +#+ITS +(defun determine-telser-properties (job-spec tty-spec) + (let ((plist (ncons 'telser)) + (ttyopt (syscall-1 'ttyvar tty-spec 'ttyopt)) + (termid (syscall-1 'usrmem job-spec #O 100)) + (location-description-asciz-words + (loop for i from #O 101 to #O 110 + collect (syscall-1 'usrmem job-spec i))) + (tip-port-number (syscall-1 'usrmem job-spec #O 121)) + (host-number (syscall-1 'usrmem job-spec #O 122)) + (binary (syscall-1 'usrmem job-spec #O 125)) + (sname-6 (syscall-1 'usrvar job-spec 'sname)) + (xjname-6 (syscall-1 'usrvar job-spec 'xjname))) + (putprop plist job-spec 'job-spec) + (putprop plist (= binary (to-sixbit 'binary)) + 'has-binary-negotiation-variables) + (putprop plist (not (= 0 (logand ttyopt #O 10000000))) 'tty-has-%tofci) + (putprop plist (not (= 0 (logand ttyopt #O 400))) 'tty-has-%tpmta) + (putprop plist (not (= 0 (logand ttyopt #O 100))) 'tty-has-%tptel) + (putprop plist (cond ((= sname-6 (to-sixbit 'plasma)) 'plasma) + ((= (logand sname-6 (to-sixbit '____)) + (to-sixbit 'cadr)) + 'lisp-machine) + (t 'arpanet)) 'host-type) + (putprop plist (cond ((= xjname-6 (to-sixbit 'telser)) 'telser) + ((= xjname-6 (to-sixbit 'supser)) 'supser) + (t 'unknown)) 'telser-type) + (and (= tip-port-number 0)(setq tip-port-number nil)) + (or (= termid (to-sixbit 'termid)) + (er-error "Got unexpected TERMID value looking with job-spec ~O." + job-spec)) + (putprop plist tip-port-number 'tip-port-number) + (putprop plist host-number 'host-number) + (putprop plist (asciz-words-to-symbol location-description-asciz-words) + 'location-description) + plist)) + +#+ITS +(defun determine-dialup-properties (tty-spec) + (let ((plist (ncons 'dialup)) + (ttytyp (syscall-1 'ttyvar tty-spec 'ttytyp)) + (ttyopt (syscall-1 'ttyvar tty-spec 'ttyopt))) + (putprop plist + (cond ((> (logand ttytyp #O 40000) 0) 'Morton) + ((> (logand ttytyp #O 400) 0) 'TK-10) + ((> (logand ttytyp #O 1000) 0) 'DTE-20) + (t 'unknown)) 'controller) + (putprop plist (not (= (logand ttyopt #O 400) 0)) '%TPMTA) + (putprop plist (not (= (logand ttyopt #O 10000000) 0)) '%TOFCI) + plist)) + +#+ITS +(defun determine-crtsty-properties (job-spec sty-tty-spec) + (let ((plist (ncons 'crtsty)) + (jname (from-sixbit (syscall-1 'usrvar job-spec 'jname))) + (sty-tty-ttyopt (syscall-1 'ttyvar sty-tty-spec 'ttyopt))) + (putprop plist jname 'jname) + (putprop plist (not (= 0 (logand #O 10000000 sty-tty-ttyopt))) + 'sty-has-%tofci) + plist)) + +#+ITS (defvar *connection-path) +#+ITS (defvar *connection-path-type) + +#+ITS (defun compute-connection-type () + (setq *connection-path (determine-connection-path)) + (setq *connection-path-type (mapcar #'car *connection-path)) + (setq *telser-plist (assq 'telser *connection-path))) + +#+ITS +(defun set-flags-from-connection-type () + (prog (ts message-file-list) + (setq message-file-list (if *log-flag (list tyo *log-file) tyo)) + (cond ((setq ts (assq 'telser *connection-path)) + (if (eq (get ts 'host-type) 'arpanet) 'OK + (format message-file-list + "~&You appear to be coming from a non-ARPA network (~A).~%" + (get ts 'host-type)) + (go punt)) + (if (eq (get ts 'telser-type) 'telser) 'OK + (format message-file-list + "~&Your network server is not an ordinary TELSER (type is ~A).~%" + (get ts 'telser-type)) + (go punt)))) + (cond ((equal *connection-path-type '(dialup)) + (go direct-dialup)) + ((equal *connection-path-type '(telser)) + (go direct-telser)) + ((equal *connection-path-type '(dialup crtsty)) + (go crtsty-dialup)) + ((equal *connection-path-type '(telser crtsty)) + (go crtsty-telser))) + ; random connection path + (format message-file-list + "~&Connected to LISP through the following path:~%~ + ~X ~S.~%" + *connection-path-type) + punt + (format message-file-list + "Unable to understand how to communicate over this path.~%~ + Cannot initalize properly for transfers.~%") + ; set flags despite message to avoid anomalies, but he will screw + ; himself if he tries to use things. + (setq *crtsty-flag nil *source-is-telser nil *telser-plist nil + *assume-7-bit-line nil) + (return nil) + direct-dialup + ; On a direct dialup, if the controller is OK we can set up for + ; 8 bits, otherwise we must set up for 7 bits. + (setq *source-is-telser nil) + (setq *crtsty-flag nil) + (and (eq (get (car *connection-path) 'controller) 'DTE-20) + (go set-8-bits)) + bad-controller + (format message-file-list + "~&Dialup controller (~A) on your line will not allow 8-bit protocol.~%" + (get (car *connection-path) 'controller)) + (go set-7-bits) + direct-telser + ; 8 bits should work because we can directly set bits. + (setq *source-is-telser t) + (setq *crtsty-flag nil) + (go set-8-bits) + crtsty-dialup + (setq *crtsty-flag t) + (setq *source-is-telser nil) + (or (eq (get (car *connection-path) 'controller) 'DTE-20) + (go bad-controller)) + ; Controller is OK. Is %TPMTA set on the dialup line? + ; If not, we can't do 8 bits. + (cond ((not (get (car *connection-path) '%TPMTA)) + (format message-file-list + "~&You must do :TCTYP +%TPMTA on your dialup line~%~ + before running CRTSTY if you want to use 8-bit protocol.~%") + (go set-7-bits))) + ; 8 bits should work. + (go set-8-bits) + crtsty-telser + (setq *source-is-telser t) + (setq *crtsty-flag t) + ; If the TELSER has binary negotiation variables, we assume it + ; will toggle %TPTEL for us. + (and (get *telser-plist 'has-binary-negotiation-variables) + (go crtsty-telser-check-%TPMTA)) + ; It's not new enough to to have those, but it might still be + ; new enough to toggle %TPTEL for us. + (unwind-protect + (progn (format tyo "~&Please wait...~%") + (open-tty-image) + (compute-connection-type)) + (restore-tty)) + (cond ((get (car *connection-path) 'tty-has-%TPTEL) + (format message-file-list + "~&Your TELSER is apparently an old version and not adjusting %TPTEL.~%~ + You must do :TCTYP -%TPTEL manually on your network line before~%~ + running CRTSTY if transfers are to work through CRTSTY.~%~ + You should do :TCTYP +%TPTEL after running CRTSTY to compensate.~%~ + Transfers will not work with current settings.~%"))) + crtsty-telser-check-%TPMTA + (cond ((not (get (car *connection-path) 'tty-has-%TPMTA)) + (format message-file-list + "~&You must do :TCTYP +%TPMTA on your network line~%~ + before running CRTSTY if you want to use 8-bit protocol.~%") + (go set-7-bits))) + ; 8 bits should work. + (go set-8-bits) + set-7-bits + (setq *assume-7-bit-line t) + (format message-file-list + "~&Setting up to use 7-bit protocol.~%") + tip-adjustment-message + (and *source-is-telser + (let ((tip-p (get (assq 'telser *connection-path) + 'tip-port-number))) + (if tip-p + (format message-file-list + "Your TIP connection will be automatically adjusted.~%") + (format message-file-list + "You are not coming from a TIP. Your TELNET will be asked to enter~%~ + binary mode, but LMODEM cannot insure binary mode over your entire~%~ + connection path.~%")))) + (return nil) + set-8-bits + (setq *assume-7-bit-line nil) + (format message-file-list + "~&Setting up for 8-bit protocol.~%") + (go tip-adjustment-message) + (return nil))) + + +;; Micro Arithmetic + +(defun do-CMA (n) + (logand (lognot n) #O 377)) + +(defun do-ADD (x y) + (logand (+ x y) #O 377)) + +(defun do-INC (n) (do-ADD n 1.)) + + +;; Read a Protocol Block from the TTY + +(defvar *max-error-count 10.) + +(defun receive-sector (repeat-p) + "Fills *SECTOR-ARRAY with characters and returns T, + except returns NIL if EOT instead of SOH received. + Possible conditions signalled: + TIMEOUT (state-description), or TIMEOUT () + BAD-HEADER-START (n) + BAD-BLOCK-NUMBER-COMPLEMENT (a b) + SECTOR-REPEAT (n) + SYNC-ERROR (last-received new repeat-flag) + CHECKSUM-ERROR (calculated received). + No recovery (line clearing, etc.) or logging will have + been done if a condition is signalled. The only status + message possibly logged tells what sector number is awaited." + (prog (header secnum cma-secnum checksum line-checksum last-i) + (declare (fixnum header secnum cma-secnum checksum line-checksum last-i)) + get-header + (or repeat-p (setq *sector-number (truncate-to-line-width + (do-INC *sector-number)))) + (setq header (read-line-character *short-timeout)) + (cond ((= header #\soh) 'continue) + ((= header #\nul) (go get-header)) + ((= header #\eot) + (return nil)) + (t (signal 'bad-header-start header))) + ; RCVSOH + (setq secnum (read-line-character *short-timeout t)) + (setq cma-secnum (read-line-character *short-timeout t)) + (cond ((not (= cma-secnum (truncate-to-line-width (do-CMA secnum)))) + (signal 'bad-block-number-complement secnum cma-secnum))) + ; RCVDATA + (cond ((= secnum *sector-number) + (and *log-flag *log-status-messages + (log-status "Ready to receive sector [~O]." + *sector-number)) + 'continue) + ((= (truncate-to-line-width (do-INC secnum)) *sector-number) + (or repeat-p (signal 'sector-repeat *sector-number))) + (t (signal 'sync-error *sector-number secnum repeat-p))) + (setq checksum 0) + (setq last-i 0) + (condition-handlers c + ((timeout () (signal 'timeout (format nil "After ~D. chars of 128. received." + last-i)))) + (loop for i from 0 to 127. + as n fixnum = (read-line-character *short-timeout) + do (setq checksum (do-ADD n checksum)) + (setq last-i i) + (setf (sector-array i) n))) + (setq line-checksum (read-line-character *short-timeout t)) + (or (= line-checksum (truncate-to-line-width checksum)) + (signal 'checksum-error checksum line-checksum)) + (return t))) + +;; Send a Protocol Block + +(defun send-sector (eot-sector-flag) + "Sends a sector and possibly logs a status message. Waits + for acknowledge. May signal NEGATIVE-ACKNOWLEDGE (), + TIMEOUT (), BAD-ACKNOWLEDGE (n), or DATA-TRUNCATION (n)." + (prog (ack checksum) + (cond (eot-sector-flag + (and *log-flag *log-status-messages + (log-status "Sending EOT.")) + (write-line-character #\eot) + (go getack))) + (and *log-flag *log-status-messages + (log-status "Sending sector [~O]." *sector-number)) + (write-line-character #\soh) + (write-line-character *sector-number t) + (write-line-character (do-CMA *sector-number) t) + (loop for i from 0 to 127. + as n fixnum = (sector-array i) + as m fixnum = (truncate-to-line-width n) + when (= i 127.) + do #+ITS (clear-input *image-input) #-ITS nil + do (if (= n m) + 'OK + (and *log-flag *log-error-messages + (log-status "Warning: Character [~O] being ~ + truncated for transmission!" n)) + (if *stop-on-data-truncation + (signal 'data-truncation n))) + (write-line-character m) + (setq checksum (do-ADD checksum m))) + (write-line-character checksum t) + getack + (setq ack (read-line-character *medium-timeout)) + (cond ((= ack #\nak) + (signal 'negative-acknowledge)) + ((= ack #\ack) + (return t)) + (t (signal 'bad-acknowledge ack))))) + +(defun await-initial-nak () + (condition-handlers c ((timeout () (signal 'abort "Timeout on initial NAK"))) + (let ((ack (read-line-character *initial-timeout))) + (if (= ack #\nak) 'OK + (signal 'bad-acknowledge ack))))) + + +(defun file-transaction-skeleton (file-processor target-filename 8-bit-flag + restore-completely) + (let ((aborted nil) + (abort-format "Aborting~:[ on sector [~O]~;~*~]: ~A~%")) + (unwind-protect + (condition-handlers c ((abort (msg) + (setq aborted t) + (and *log-flag + (log-status abort-format + (zerop *sector-number) + *sector-number msg)) + (restore-tty-except-for-superimage-mode) + (format #+ITS tyo #+Multics t "~%>> ~1@{~:}" + abort-format + (zerop *sector-number) + *sector-number msg) + nil)) + (condition-handlers c ((open-error (f options) + (signal 'abort "Can't open file")) + (invalid-file-format (sfa) + (signal 'abort "Invalid COM file format"))) + (funcall file-processor target-filename 8-bit-flag))) + (if (or (not aborted) restore-completely) + (restore-tty) + (restore-tty-except-for-superimage-mode))))) + + +;; Receive a File + +(defun internal-receive-file (target-filename 8-bit-flag) + "Re-opens *DISK-OUTPUT and receives all sectors of a file. + The TTY is completely restored on success, but if an ABORT + happens the TTY is left in superimage mode to prevent random-ctl-char + lossage in DDT. An error message is printed to TYO if an ABORT + happens." + (file-transaction-skeleton #'receive-file-1 target-filename 8-bit-flag + nil)) + +(defun receive-file-1 (target-filename 8-bit-flag) + "Re-opens *DISK-OUTPUT and receives all sectors of a file. + Possible signal of ABORT (reason)." + (prog (nl dir sector-repeat-flag error-count nl1) + (and 8-bit-flag *assume-7-bit-line + (signal 'abort + "COM files cannot be transferred with 7-bit protocol.")) + (setq target-filename (mergef target-filename (filename-defaults))) + (setq nl (namelist target-filename)) + (setq dir (car nl)) + (and #+ITS (or (filep *disk-output)(sfap *disk-output)) + #+Multics (filep *disk-output) + (close *disk-output)) + #+ITS ; I don't know if y-or-n-p exists on Multics or not, and + ; PROBEF is probably different + (cond ((memq '> nl) 'no-question) + ((setq nl1 (probef nl)) + (format t "~&File ~A exists. OK to overwrite it?" + (namestring nl1)) + (if (y-or-n-p) + (and *log-flag *log-error-messages + (log-status "Overwriting old file approved.")) + (signal 'abort "Overwriting disapproved")))) + (setq *sector-number 0) + (if 8-bit-flag + #+ITS (setq *disk-output (create-8-bit-disk-sfa `(,dir _LMOD_ OUTPUT) + '(dsk out))) + #+Multics (signal 'abort "8-bit files not implemented") + (setq *disk-output (signalling-open #+ITS `(,dir _LMOD_ OUTPUT) + #+Multics target-filename + '(dsk out image)))) + (if (not *image-input-from-tty) 'leave-it-alone + (open-tty-image)) + (format tyo "~&READY~%") + (setq *assume-7-bit-disk (not 8-bit-flag)) + (setq *internal-extra-sector-limit -1) + (setq sector-repeat-flag nil) + (setq error-count 0) + (clear-tty-input-line) + (go loop1) + nack-and-retry + (clear-tty-input-line *error-line-clear-timeout) + (write-line-character #\nak) + (setq sector-repeat-flag t) + (setq error-count (1+ error-count)) + (if (> error-count *max-error-count) + (signal 'abort "Error count exceeded")) + #+ITS (if (> error-count 0) (maybe-recheck-TIP-connection)) + (go loop1) + ack-and-continue + (write-line-character #\ack) + (setq sector-repeat-flag nil) + (setq error-count 0) + loop1 + (condition-handlers c + ((timeout (possible-state-description) + (and *log-flag *log-error-messages + (if possible-state-description + (log-status "Timeout on sector [~O]: ~A" *sector-number + possible-state-description) + (log-status "Timeout reading sector [~O]." *sector-number))) + (go nack-and-retry)) + (bad-header-start (n) + (and *log-flag *log-error-messages + (log-status "Header [~O] received for sector [~O] ~ + is neither SOH nor EOT." n *sector-number)) + (go nack-and-retry)) + (bad-block-number-complement (a b) + (and *log-flag *log-error-messages + (log-status "Received block number [~O] and complement [~O] disagree." + a b)) + (go nack-and-retry)) + (sector-repeat (n) + (and *log-flag *log-error-messages + (log-status "ACK evidently garbled; sector [~O] octal being repeated." + n)) + (clear-tty-input-line *error-line-clear-timeout) + (go ack-and-continue)) + (sync-error (last-sector new-sector repeat-flag) + (and *log-flag *log-error-messages + (log-status + "Sync error: last sector [~O], new sector [~O], repeat flag ~A." + last-sector new-sector repeat-flag)) + (clear-tty-input-line *error-line-clear-timeout) + (write-line-character #\nak) + (signal 'abort "Sync error")) + (data-truncation (n) ; status already logged + (signal 'abort "Stopping on data truncation")) + (extra-sector () + (and *log-flag *log-error-messages + (log-status "More than ~D sectors received after logical EOF." + *extra-sector-limit)) + (signal 'abort "Too many sectors after logical EOF")) + (checksum-error (cal rec) + (and *log-flag *log-error-messages + (log-status "Checksum error: calculated [~O], received [~O], on sector [~O]." + cal rec *sector-number)) + (go nack-and-retry))) + (cond ((receive-sector sector-repeat-flag) + (and *log-flag *log-status-messages + (log-status "Received sector [~O]." *sector-number)) + (write-sector) ; may signal DATA-TRUNCATION + (go ack-and-continue)) + (t (and *log-flag *log-status-messages + (log-status "End of transmission.")) + (write-line-character #\ack) + #+ITS (renamef *disk-output target-filename) + (close *disk-output) + (return *disk-output) + ))))) + +;; Send a File + +(defun internal-send-file (source-filename 8-bit-flag) + "Opens the specified file and sends it. The TTY is always + completely restored. An error message is printed to TYO if an ABORT + happens." + (file-transaction-skeleton #'send-file-1 source-filename 8-bit-flag + t)) + +(defun send-file-1 (source-filename 8-bit-flag) + (prog (sector-p error-count) + (setq *sector-number 0) + (and 8-bit-flag *assume-7-bit-line + (signal 'abort "COM files cannot be transferred with 7-bit protocol.")) + (and #+ITS (or (filep *disk-input)(sfap *disk-input)) + #+Multics (filep *disk-input) + (close *disk-input)) + (setq *disk-input-eof nil) + (cond ((not 8-bit-flag) + (setq *disk-input (signalling-open + (mergef source-filename (filename-defaults)) + '(dsk in ascii))) + (setq *assume-7-bit-disk nil)) + (t #+ITS (setq *disk-input (create-8-bit-disk-sfa + (mergef source-filename (filename-defaults)) + 'in)) + #+Multics (signal 'abort "8-bit files not implemented") + (setq *assume-7-bit-disk nil))) + (if (not *image-input-from-tty) 'leave-it-alone + (open-tty-image)) + (eoffn *disk-input 'disk-input-eoffn) + (let ((n (1+ (// (1- (lengthf *disk-input)) + 128.)))) + (format tyo "~&Estimated sector count ~16r hex, ~D decimal, ~O octal.~%" + n n n) + (and *log-flag + (log-status "Estimated sector count ~16r hex, ~D decimal, ~O octal." + n n n))) + (format tyo "~&READY~%") + (setq error-count 0) + wait + (clear-tty-input-line) + (condition-handlers c + ((bad-acknowledge (ack) + (and *log-flag *log-error-messages + (log-status "[~O] received while awaiting initial NAK." + ack)) + (setq error-count (1+ error-count)) + (if (> error-count *max-error-count) + (signal 'abort "Error count exceeded")) + (go wait))) + (await-initial-nak)) + new-sector + (setq sector-p (read-sector)) + (setq error-count -1) + repeat-sector + (setq error-count (1+ error-count)) + (if (> error-count *max-error-count) + (signal 'abort "Error count exceeded")) + #+ITS (if (> error-count 0) (maybe-recheck-TIP-connection)) + (condition-handlers c + ((timeout () + (and *log-flag *log-error-messages + (log-status "Timeout waiting for [ACK] on sector [~O], retransmitting." + *sector-number)) + (go repeat-sector)) + (negative-acknowledge () + (and *log-flag *log-error-messages + (log-status "[NAK] received on sector [~O], retransmitting." + *sector-number)) + (go repeat-sector)) + (data-truncation (n) ; message already logged + (signal 'abort "Stopping on data truncation")) + (bad-acknowledge (ack) + (and *log-flag *log-error-messages + (log-status "Bad acknowledge [~O] received on sector [~O], ~ + retransmitting." + ack *sector-number)) + (go repeat-sector))) + (send-sector (not sector-p)) + (if sector-p + (go new-sector) + (and *log-flag *log-status-messages + (log-status "All sectors transmitted.")) + (close *disk-input) + (return *disk-input) + )))) + + +(defprop raf receive-ascii-file expr) +(defprop rcf receive-com-file expr) +(defprop saf send-ascii-file expr) +(defprop scf send-com-file expr) + +(defun ask-com-file-p () + (loop do (format t "~&Is that an ASCII or COM file? ") + as answer = (read t) + until (memq answer '(a ascii com c binary bin text)) + finally (setq answer (not (memq answer '(a ascii text)))) + (return answer))) + +(defun receive-file (f) + (cond ((ask-com-file-p) + (and *log-flag (log-status "Initiating as COM file transfer.")) + (receive-com-file f)) + (t (and *log-flag (log-status "Initiating as ASCII file transfer.")) + (receive-ascii-file f)))) + +(defun send-file (f) + (cond ((ask-com-file-p) + (and *log-flag (log-status "Initiating as COM file transfer.")) + (send-com-file f)) + (t (and *log-flag (log-status "Initiating as ASCII file transfer.")) + (send-ascii-file f)))) + +(defun receive-ascii-file (filename) + (let ((*pad-char-is-logical-eof t)) + (internal-receive-file filename nil))) + +(defun receive-com-file (filename) + (let ((*pad-char-is-logical-eof nil)) + (internal-receive-file filename t))) + +(defun send-ascii-file (filename) + (let ((*control-c-is-its-logical-eof t)) + (internal-send-file filename nil))) + +(defun send-com-file (filename) + (let ((*control-c-is-its-logical-eof nil)) + (internal-send-file filename t))) + +(defun send-text-file (x) (send-ascii-file x)) +(defun receive-text-file (x) (receive-ascii-file x)) + + +#+Multics (defvar read-*-eval-print) +#+Multics (defvar read-eval-*-print) +#+Multics (defvar -) + +#+Multics (defun lmodem-toplevel () + (loop while t do (setq + - - (read)) + (setq - (funcall read-*-eval-print -)) + (setq * (eval -)) + (setq * (funcall read-eval-*-print *)) + (print *) + (terpri t))) + +(defun run (logp) + #+ITS (snarf-normal-tty-variables) + (setq read-*-eval-print #'(lambda (x) + (and *log-flag (log-status "~S" x)) + (cond ((or (member x '(help (help) ? (?) + H (h) [help])) + #+ITS (and (eq (typep x) 'symbol) + (or (samepnamep x "help") + (samepnamep x "HELP"))) + #+Multics nil) + (setq x '(give-lmodem-help))) + ((eq (typep x) 'symbol) + (if (or (null x)(boundp x)) 'OK + (and *log-flag + (log-status "Unbound variable.")) + (format t + "~%Unbound variable.~%") + (setq x nil))) + (t (if (and (atom (car x)) + (fboundp (car x))) 'OK + (and *log-flag + (log-status + "Undefined function.")) + (format t + "~%Undefined function.~%") + (setq x nil)))) + x)) + (setq read-eval-*-print #'(lambda (x) + (and *log-flag (log-status "--> ~S~%" x)) + x)) + #+ITS (compute-connection-type) + (and logp + (begin-log-file) + *log-flag ;might have got an error opening the file + (format t "~&Opened log file ~A.~%" *log-file)) + #+ITS (set-flags-from-connection-type) + #+Multics (setq *assume-7-bit-line nil) + #+Multics (sstatus toplevel '((lmodem-toplevel))) + t) + +(defun init-log-file () + #+ITS (and (get 'lmodem 'version) + (format *log-file "~&This is LMODEM Version ~A.~%" + (get 'lmodem 'version))) + #+ITS (log-connection-info) + nil) + +#+ITS +(defun log-connection-info () + (if (not *log-flag) nil + (format *log-file "~&Connection path type is ~A.~%" + *connection-path-type) + (and (eq (car *connection-path-type) 'telser) + (format *log-file + "TELSER ~:[does not have~;has~] binary negotiation variables.~%" + (get *telser-plist 'has-binary-negotiation-variables))))) + +#+Multics +(defun give-lmodem-help () + (format t "~&No help available.~%") + nil) + +#+ITS +(defun give-lmodem-help () + (cond ((not (probef "mc:cpm;help lmodem")) + (format tyo "~&Help file unavailable.~%") + (and *log-flag (log-status "Help file unavailable.")) + nil) + ((setq *disk-input (open "mc:cpm;help lmodem" '(dsk in ascii))) + (terpri tyo) + (loop as n fixnum = (tyi *disk-input) until (or (< n 0) (= n #^C)) + do (tyo n tyo)) + (close *disk-input) + t))) + +#+ITS +(defun dump-lmodem-program () + (and *log-flag (format tyo "~&Closed log file ~A.~%" (end-log-file))) + (setq *log-file 'not-initialized) + (format tyo "~&Filename in which to dump: ") + (suspend nil (readline)) + (run t)) + +#+ITS (or (get 'maclisp-system-quit 'lsubr) + (putprop 'maclisp-system-quit (get 'quit 'lsubr) 'lsubr)) +#+ITS (defun quit (&rest args) + (setq errlist `((apply 'maclisp-system-quit ',args))) + (^g)) + +#+Multics (or (get 'maclisp-system-quit 'subr) + (putprop 'maclisp-system-quit (get 'quit 'subr) 'subr)) +#+Multics (defun quit () + (setq errlist '((maclisp-system-quit))) + (^g)) + +(eval-when (load) (sstatus uuolinks)) + + +#+ITS +(defun stat-1 (f com-file-p) + (condition-handlers c + ((open-error (file keywords) + (format t "~&Can't open ~A.~%" (namestring file))) + (invalid-file-format (sfa) + (format t "~&Invalid COM file format."))) + (setq f (mergef f (filename-defaults))) + (phi ((fob (if com-file-p (create-8-bit-disk-sfa f 'in) + (signalling-open f 'in)))) + (format t "~&~DK bytes~%" (1+ (// (1- (lengthf fob)) 1024.)))))) + +#+ITS (defun ascii-stat (f) (stat-1 f nil)) +#+ITS (defun com-stat (f) (stat-1 f t)) +#+ITS (defprop stat-ascii ascii-stat expr) +#+ITS (defprop stat-com com-stat expr) + +(eval-when (eval load) + (run t))