;-*- Mode:LISP; Package:CHAOS -*- ;This file implements EFTP on the Lisp machine, ;with the cooperation of CHSNCP. ;Note, some of these 22.'s are 10.+12., the sum of the Muppet header size ;and the PUP header size. Other 22.'s are 2.*11., the number of non-data bytes ;in a PUP. (DEFVAR PUP-INT-PKT NIL) ;NIL or INT-PKT containing a PUP just received (DEFVAR PUP-INT-PKT-PORT NIL) ;NIL or port expecting a packet (DEFVAR NEXT-LOCAL-PORT 1000) ;Used to generate unique port numbers (DEFVAR MAX-PUP-DATA-BYTES 458.) ;480-22 ;Kludge since the CHSNCP doesn't currently pay any attention to routing information ;broadcast on the net. (ASET 426 ROUTING-TABLE 2) ;Structure of a PUP in a Muppet in an INT-PKT (DEFSTRUCT (PUP :ARRAY (:CONSTRUCTOR NIL)) ((MUPPET-VERSION 0010) (MUPPET-PROTOCOL 1010)) ((MUPPET-FORWARD-COUNT 0010) (MUPPET-MISC-BYTE 1010)) (MUPPET-DEST-HOST) (MUPPET-DEST-PORT) (MUPPET-SOURCE-HOST) (MUPPET-SOURCE-PORT) (MUPPET-PACKET-NUMBER) (MUPPET-DATA-LENGTH) (MUPPET-FRAGMENT-POSITION) (MUPPET-FRAGMENT-LENGTH) (MUPPET-MISC-WORD) (MUPPET-CHECKSUM) (PUP-OVERALL-LENGTH) ((PUP-TYPE 0010) (PUP-TRANSPORT 1010)) (PUP-ID-HIGH) (PUP-ID-LOW) (PUP-DEST-HOST) (PUP-DEST-PORT-HIGH) (PUP-DEST-PORT-LOW) (PUP-SOURCE-HOST) (PUP-SOURCE-PORT-HIGH) (PUP-SOURCE-PORT-LOW) ;Word 22. is the first data word. Pup checksum after the data ) ;Get a PUP buffer which can be filled in then transmitted (DEFUN GET-PUP (DEST-HOST DEST-PORT SOURCE-PORT PUP-TYPE PUP-ID &AUX (INT-PKT (ALLOCATE-INT-PKT))) (FILLARRAY INT-PKT '(0)) (SETF (MUPPET-VERSION INT-PKT) 1) (SETF (MUPPET-PROTOCOL INT-PKT) 3) (SETF (MUPPET-DEST-HOST INT-PKT) DEST-HOST) (SETF (MUPPET-DEST-PORT INT-PKT) (LDB 0020 DEST-PORT)) (SETF (MUPPET-SOURCE-HOST INT-PKT) MY-ADDRESS) (SETF (MUPPET-SOURCE-PORT INT-PKT) SOURCE-PORT) (SETF (MUPPET-PACKET-NUMBER INT-PKT) PUP-ID) (SETF (MUPPET-CHECKSUM INT-PKT) -1) ;None (SETF (PUP-TYPE INT-PKT) PUP-TYPE) (SETF (PUP-ID-HIGH INT-PKT) (LDB 2020 PUP-ID)) (SETF (PUP-ID-LOW INT-PKT) (LDB 0020 PUP-ID)) (SETF (PUP-DEST-HOST INT-PKT) DEST-HOST) (SETF (PUP-DEST-PORT-HIGH INT-PKT) (LDB 2020 DEST-PORT)) (SETF (PUP-DEST-PORT-LOW INT-PKT) (LDB 0020 DEST-PORT)) (SETF (PUP-SOURCE-HOST INT-PKT) MY-ADDRESS) (SETF (PUP-SOURCE-PORT-LOW INT-PKT) SOURCE-PORT) INT-PKT) ;Compute the checksum of a PUP (DEFUN CHECKSUM-PUP (INT-PKT) (DO ((I 12. (1+ I)) (CK 0) (N (LSH (1- (PUP-OVERALL-LENGTH INT-PKT)) -1) (1- N))) ((ZEROP N) (AND (= CK 177777) (SETQ CK 0)) ;Gronk minus zero (RETURN CK I)) ;Return checksum and index in PUP of cksm (SETQ CK (+ CK (AREF INT-PKT I))) ;1's complement add (AND (BIT-TEST 200000 CK) (SETQ CK (LDB 0020 (1+ CK)))) (SETQ CK (DPB CK 0117 (LDB 1701 CK))))) ;16-bit left rotate ;Fire off a PUP previously gotten from GET-PUP (DEFUN TRANSMIT-PUP (INT-PKT N-BYTES) (SETF (MUPPET-DATA-LENGTH INT-PKT) (+ 22. N-BYTES)) (SETF (PUP-OVERALL-LENGTH INT-PKT) (+ 22. N-BYTES)) (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP INT-PKT) (ASET CKSM INT-PKT CKSMX) (ASET (AREF ROUTING-TABLE (LDB 1010 (MUPPET-DEST-HOST INT-PKT))) INT-PKT (1+ CKSMX)) (SETF (INT-PKT-WORD-COUNT INT-PKT) (+ CKSMX 2)) (OR (= (%AREA-NUMBER INT-PKT) CHAOS-BUFFER-AREA) (FERROR NIL "Attempt to transmit non-interrupt packet ~A" INT-PKT)) (WITHOUT-INTERRUPTS ;Ah, modularity, wonderful modularity. (PROG (OLD-TRANSMIT-LIST) (SETQ PKTS-TRANSMITTED (1+ PKTS-TRANSMITTED)) LOOP (SETQ OLD-TRANSMIT-LIST (INT-TRANSMIT-LIST)) (SETF (INT-PKT-THREAD INT-PKT) OLD-TRANSMIT-LIST) (OR (%STORE-CONDITIONAL INT-TRANSMIT-LIST-POINTER OLD-TRANSMIT-LIST INT-PKT) (GO LOOP)) (%CHAOS-WAKEUP))))) ;Internal routine to get back a PUP on a specified port, with timeout ;Returns INT-PKT or NIL. (DEFUN RECEIVE-PUP (PORT &OPTIONAL (TIMEOUT 60.) &AUX (START-TIME (TIME)) PUP) (UNWIND-PROTECT (DO () ((OR PUP-INT-PKT (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)) (WITHOUT-INTERRUPTS (SETQ PUP PUP-INT-PKT PUP-INT-PKT NIL)) (AND PUP (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PUP) (OR (= (AREF PUP CKSMX) 177777) (= (AREF PUP CKSMX) CKSM) (PROGN (FREE-INT-PKT PUP) (SETQ PUP NIL))))) PUP) (SETQ PUP-INT-PKT-PORT PORT) (PROCESS-WAIT "PUP in" #'(LAMBDA (START-TIME TIMEOUT) (OR PUP-INT-PKT (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT))) START-TIME TIMEOUT)) (SETQ PUP-INT-PKT-PORT NIL))) ;Cons a string containing characters taken from a PUP (DEFUN PUP-STRING (PUP &OPTIONAL (FROM 0) (TO (- (PUP-OVERALL-LENGTH PUP) 22.))) (LET ((STR (MAKE-ARRAY NIL 'ART-STRING (MAX (- TO FROM) 0)))) (DO ((I FROM (1+ I)) (J 0 (1+ J)) (WD)) (( I TO)) (SETQ WD (AREF PUP (+ (// I 2) 22.))) (ASET (LDB (IF (ODDP I) 0010 1010) WD) STR J)) STR)) (DEFUN GET-PORT-NUMBER () (WITHOUT-INTERRUPTS (PROG1 NEXT-LOCAL-PORT (SETQ NEXT-LOCAL-PORT (1+ NEXT-LOCAL-PORT)) (AND (> NEXT-LOCAL-PORT 177777) (SETQ NEXT-LOCAL-PORT 1000))))) ;Complain about random PUP we may have received, and free the INT-PKT ;Put a trace breakpoint on this if you are trying to figure out what's going on. (DEFUN RECEIVED-RANDOM-PUP (PUP) (FORMAT ERROR-OUTPUT "~&[Random PUP type ~O received from ~O#~O#~O~:[~;, code ~D. <~O>, ~A~]]~%" (PUP-TYPE PUP) (LDB 1010 (PUP-SOURCE-HOST PUP)) (LDB 0010 (PUP-SOURCE-HOST PUP)) (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP)) (= (PUP-TYPE PUP) 4) ;Error (AREF PUP 32.) ;Standard code (AREF PUP 33.) ;Misc argument to it (PUP-STRING PUP 24.)) ;Human readable text (FREE-INT-PKT PUP) (KBD-CHAR-AVAILABLE)) ;Chance to hit call ;EFTP-write stream. (DEFVAR EFTP-NEXT-PUP-ID) (DEFVAR EFTP-FOREIGN-HOST) (DEFVAR EFTP-FOREIGN-PORT) (DEFVAR EFTP-LOCAL-PORT) (DEFVAR EFTP-BINARY-P) (DEFVAR EFTP-BUFFER) (DEFUN MAKE-EFTP-WRITE-STREAM (EFTP-FOREIGN-HOST &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-FOREIGN-PORT 20)) (LET ((EFTP-NEXT-PUP-ID 0) (EFTP-LOCAL-PORT (GET-PORT-NUMBER)) (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0)))) (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-NEXT-PUP-ID EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER) 'EFTP-WRITE-STREAM))) (DEFUN EFTP-WRITE-STREAM (OP &OPTIONAL ARG1 &REST ARGS) (SELECTQ OP (:WHICH-OPERATIONS (IF EFTP-BINARY-P '(:TYO :STRING-OUT :FORCE-OUTPUT :CLOSE) '(:TYO :STRING-OUT :LINE-OUT :FORCE-OUTPUT :CLOSE))) (:TYO (ARRAY-PUSH EFTP-BUFFER ARG1) (AND (= (ARRAY-ACTIVE-LENGTH EFTP-BUFFER) (ARRAY-LENGTH EFTP-BUFFER)) (EFTP-FORCE-OUTPUT))) (:LINE-OUT (LEXPR-FUNCALL #'EFTP-WRITE-STREAM ':STRING-OUT ARG1 ARGS) (EFTP-WRITE-STREAM ':TYO 15) (EFTP-WRITE-STREAM ':TYO 12)) (:STRING-OUT ;Could be coded more efficiently, but why bother? (LET ((FROM (OR (CAR ARGS) 0)) (TO (OR (CADR ARGS) (ARRAY-ACTIVE-LENGTH ARG1)))) (DO ((I FROM (1+ I)) (CH)) (( I TO)) (SETQ CH (AREF ARG1 I)) (COND (EFTP-BINARY-P) ((= CH #\TAB) (SETQ CH 11)) ((= CH #\CR) (EFTP-WRITE-STREAM ':TYO 15) (SETQ CH 12))) (ARRAY-PUSH EFTP-BUFFER CH) (AND (= (ARRAY-ACTIVE-LENGTH EFTP-BUFFER) (ARRAY-LENGTH EFTP-BUFFER)) (EFTP-FORCE-OUTPUT))))) (:FORCE-OUTPUT (EFTP-FORCE-OUTPUT)) (:CLOSE (EFTP-FORCE-OUTPUT) (DO ((ID (1- (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID)))) (N-RETRANSMISSIONS 1 (1+ N-RETRANSMISSIONS)) (PUP)) (NIL) (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 32 ID)) (TRANSMIT-PUP PUP 0) (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT))) (AND (ZEROP (\ N-RETRANSMISSIONS 10.)) (FORMAT ERROR-OUTPUT "~&[Host not responding to EFTP_End, still trying...]~%")) (KBD-CHAR-AVAILABLE)) ((= (PUP-TYPE PUP) 33) (FORMAT ERROR-OUTPUT "~&EFTP Abort in EFTP_End, code ~D, ~A~%" (AREF PUP 22.) (PUP-STRING PUP 2)) (FREE-INT-PKT PUP) (BREAK EFTP-ABORT)) ((NOT (= (PUP-TYPE PUP) 31)) (RECEIVED-RANDOM-PUP PUP)) ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID)) (FREE-INT-PKT PUP)) ;Ignore random old acks (T (FREE-INT-PKT PUP) (RETURN NIL)))) (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 32 EFTP-NEXT-PUP-ID) 0)) (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-WRITE-STREAM OP ARG1 ARGS)))) (DEFUN EFTP-FORCE-OUTPUT () (AND (NOT (ZEROP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER))) (DO ((ID (1- (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID)))) (N-RETRANSMISSIONS 1 (1+ N-RETRANSMISSIONS)) (PUP)) (NIL) (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 30 ID)) (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2)) (ASET (+ (LSH (AREF EFTP-BUFFER (* I 2)) 8) (AREF EFTP-BUFFER (1+ (* I 2)))) PUP (+ I 22.))) (TRANSMIT-PUP PUP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT))) (AND (ZEROP (\ N-RETRANSMISSIONS 10.)) (FORMAT ERROR-OUTPUT "~&[Host not responding, still trying...]~%")) (KBD-CHAR-AVAILABLE)) ((= (PUP-TYPE PUP) 33) (FORMAT ERROR-OUTPUT "~&EFTP Abort code ~D, ~A~%" (AREF PUP 22.) (PUP-STRING PUP 2)) (FREE-INT-PKT PUP) (BREAK EFTP-ABORT)) ((NOT (= (PUP-TYPE PUP) 31)) (RECEIVED-RANDOM-PUP PUP)) ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID)) (FREE-INT-PKT PUP)) ;Ignore random old acks (T (FREE-INT-PKT PUP) (RETURN NIL))))) ;Bingo! (STORE-ARRAY-LEADER 0 EFTP-BUFFER 0) T) (DEFUN EFTP-BINARY-FILE-TO-ALTO (FILENAME ALTO-ADDRESS) (LET ((IN (GLOBAL:OPEN FILENAME '(:READ :FIXNUM :BYTE-SIZE 8))) (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS T))) (STREAM-COPY-UNTIL-EOF IN OUT) (FUNCALL OUT ':CLOSE) (FUNCALL IN ':CLOSE))) (DEFVAR EFTP-UNRCHF) (DEFUN MAKE-EFTP-READ-STREAM (EFTP-FOREIGN-HOST &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-LOCAL-PORT 20)) (LET ((EFTP-NEXT-PUP-ID 0) (EFTP-FOREIGN-PORT NIL) ;Set later (EFTP-UNRCHF NIL) (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0 0)))) (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-UNRCHF EFTP-NEXT-PUP-ID EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER) 'EFTP-READ-STREAM))) (DEFUN EFTP-READ-STREAM (OP &OPTIONAL ARG1 &REST ARGS) (SELECTQ OP (:WHICH-OPERATIONS '(:TYI :UNTYI)) (:TYI (COND (EFTP-UNRCHF (PROG1 EFTP-UNRCHF (SETQ EFTP-UNRCHF NIL))) ((< (ARRAY-LEADER EFTP-BUFFER 1) (ARRAY-LEADER EFTP-BUFFER 0)) (SETF (ARRAY-LEADER EFTP-BUFFER 1) (1+ (ARRAY-LEADER EFTP-BUFFER 1))) (LET ((CH (AREF EFTP-BUFFER (1- (ARRAY-LEADER EFTP-BUFFER 1))))) (COND ((NOT EFTP-BINARY-P) (COND ((MEMQ CH '(11 14 15)) (SETQ CH (+ CH 200))) ((= CH 12) (SETQ CH (EFTP-READ-STREAM OP ARG1)))))) CH)) ((AND EFTP-FOREIGN-HOST (EFTP-READ-NEXT-PUP)) (EFTP-READ-STREAM OP ARG1)) (T ;Eof (SETQ EFTP-FOREIGN-HOST NIL) ;Flag as eof (AND ARG1 (ERROR ARG1))))) (:UNTYI (SETQ EFTP-UNRCHF ARG1)) (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-READ-STREAM OP ARG1 ARGS)))) (DEFUN EFTP-READ-NEXT-PUP () "Returns NIL at eof, else sets up buffer" ;; EFTP-NEXT-PUP-ID has the number of the packet we are expecting to receive here (AND EFTP-FOREIGN-PORT ;Not first time, acknowledge previous packet (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 31 (1- EFTP-NEXT-PUP-ID)) 0)) (DO ((N-TIMEOUTS 1 (1+ N-TIMEOUTS)) (EOF-SEQUENCE-P NIL) (PUP)) (NIL) ;Loop until receive data (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT))) (COND ((ZEROP (\ N-TIMEOUTS 10.)) (AND EOF-SEQUENCE-P (RETURN NIL)) ;Done with dally timeout (FORMAT ERROR-OUTPUT (IF EFTP-FOREIGN-PORT "~&[Host has stopped sending, still trying...]~%" "~&[Host has not started sending, still trying...]~%")))) (KBD-CHAR-AVAILABLE)) ((NOT (AND (OR (= (PUP-TYPE PUP) 30) (= (PUP-TYPE PUP) 32) (= (PUP-TYPE PUP) 33)) (= (PUP-SOURCE-HOST PUP) EFTP-FOREIGN-HOST) (OR (NULL EFTP-FOREIGN-PORT) (= (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP)) EFTP-FOREIGN-PORT)))) (RECEIVED-RANDOM-PUP PUP)) ((= (PUP-TYPE PUP) 33) (FORMAT ERROR-OUTPUT "~&EFTP Abort~:[~; in eof sequence~], code ~D, ~A~%" EOF-SEQUENCE-P (AREF PUP 22.) (PUP-STRING PUP 2)) (FREE-INT-PKT PUP) (BREAK EFTP-ABORT)) ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) EFTP-NEXT-PUP-ID)) (FREE-INT-PKT PUP) ;Ignore random old data (AND EFTP-FOREIGN-PORT ;Except repeat acknowledgement (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 31 (1- EFTP-NEXT-PUP-ID)) 0))) ((= (PUP-TYPE PUP) 32) ;Eof (FREE-INT-PKT PUP) (AND EOF-SEQUENCE-P (RETURN NIL)) ;Done dallying (SETQ EOF-SEQUENCE-P T) ;Ack the EFTP-END packet (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 31 EFTP-NEXT-PUP-ID) 0) (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID))) (T ;Incoming data (AND (> N-TIMEOUTS 9) (FORMAT ERROR-OUTPUT "~&[Host has commenced transmission]~%")) (AND (NULL EFTP-FOREIGN-PORT) (SETQ EFTP-FOREIGN-PORT (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP)))) (SETF (ARRAY-LEADER EFTP-BUFFER 1) 0) (SETF (ARRAY-LEADER EFTP-BUFFER 0) (- (PUP-OVERALL-LENGTH PUP) 22.)) (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2)) (LET ((WD (AREF PUP (+ I 22.)))) (ASET (LDB 1010 WD) EFTP-BUFFER (* I 2)) (ASET (LDB 0010 WD) EFTP-BUFFER (1+ (* I 2))))) (FREE-INT-PKT PUP) (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID)) (RETURN T))))) (DEFUN EFTP-BINARY-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS) (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE :FIXNUM :BYTE-SIZE 8))) (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS T))) (STREAM-COPY-UNTIL-EOF IN OUT) (FUNCALL OUT ':CLOSE))) (DEFUN EFTP-TEXT-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS) (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE))) (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS))) (STREAM-COPY-UNTIL-EOF IN OUT) (FUNCALL OUT ':CLOSE))) (DEFUN EFTP-TEXT-FILE-TO-ALTO (FILENAME ALTO-ADDRESS) (LET ((IN (GLOBAL:OPEN FILENAME '(:READ))) (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS))) (STREAM-COPY-UNTIL-EOF IN OUT) (FUNCALL IN ':CLOSE) (FUNCALL OUT ':CLOSE)))