--- /dev/null
+<PACKAGE "TWAY">
+
+<ENTRY TS-RJFN TS-MODE TS-BSZ TS-RBUF TS-RBC TS-WJFN TS-WBUF
+ TS-WBC TS-EXTRA TWAY-READ-BYTE TWAY-READ-BUFFER TWAY-WRITE-BUFFER
+ TWAY-WRITE-BYTE TTY-CHANNEL DUMP-WRITE-BUFFER TWAY-BUFOUT>
+
+<NEW-CHANNEL-TYPE TWAY DEFAULT
+ OPEN TWAY-OPEN
+ CLOSE TWAY-CLOSE
+ READ-BYTE TWAY-READ-BYTE
+ FILL-READ-BUFFER TWAY-FILL-READ
+ WRITE-BYTE TWAY-WRITE-BYTE
+ READ-BUFFER TWAY-READ-BUFFER
+ WRITE-BUFFER TWAY-WRITE-BUFFER
+ BUFOUT TWAY-BUFOUT
+ PRINT-DATA TWAY-PRINT-DATA>
+
+<MSETG TS-RJFN %<OFFSET 1 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-MODE %<OFFSET 2 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-BSZ %<OFFSET 3 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-RBUF %<OFFSET 4 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-RBC %<OFFSET 5 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-WJFN %<OFFSET 6 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-WBUF %<OFFSET 7 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-WBC %<OFFSET 8 '<OR TTY-CHANNEL TWAY-BASE>>>
+<MSETG TS-EXTRA %<OFFSET 9 '<OR TTY-CHANNEL TWAY-BASE>>>
+
+;"<NEWSTRUC TWAY-CHANNEL (VECTOR)
+ TS-RJFN FIX
+ TS-MODE FIX
+ TS-BSZ FIX
+ TS-RBUF <OR FALSE STRING UVECTOR>
+ TS-RBC FIX
+ TS-WJFN <OR FIX FALSE>
+ TS-WBUF <OR FALSE STRING UVECTOR>
+ TS-WBC FIX
+ \"REST\"
+ TS-EXTRA ANY>"
+
+<NEWSTRUC TWAY-BASE VECTOR
+ TB-RJFN FIX
+ TB-MODE FIX
+ TB-BSZ FIX
+ TB-RBUF <OR FALSE STRING UVECTOR>
+ TB-RBC FIX
+ TB-WJFN <OR FIX FALSE>
+ TB-WBUF <OR FALSE STRING UVECTOR>
+ TB-WBC FIX>
+
+<SETG BUFFERED <UVECTOR %,/DVDSK %,/DVMTA %,/DVLPT %,/DVNUL %,/DVNET>>
+
+<GDECL (BUFFERED) <UVECTOR [REST FIX]>>
+
+<DEFINE TWAY-OPEN (STYPE OPER NAME MODS
+ "OPTIONAL" (BYTES "ASCII") (OBUF? 1) (IBUF? 1)
+ "AUX" (NEW? <>) MODE RJFN WJFN BSZ (WRITE? <>) (BUF? <>))
+ #DECL ((NAME MODS BYTES) STRING (IBUF? OBUF?) <OR FIX ATOM FALSE>
+ (NEW? BUF?) <OR ATOM FALSE> (MODE BSZ) FIX
+ (RJFN WJFN) <OR FIX FALSE>)
+ <COND (<=? .MODS "READ">
+ <SET MODE %<CHTYPE <ORB ,OF-RD ,OF-EX ,OF-PLN> FIX>>)
+ (<=? .MODS "CREATE">
+ <SET NEW? T>
+ <SET WRITE? T>
+ <SET MODE %<CHTYPE <ORB ,OF-RD ,OF-WR ,OF-EX ,OF-PLN> FIX>>)
+ (<=? .MODS "MODIFY">
+ <SET WRITE? T>
+ <SET MODE %<CHTYPE <ORB ,OF-RD ,OF-WR ,OF-EX ,OF-PLN> FIX>>)
+ (T <ERROR ILLEGAL-MODE .MODS TWAY-OPEN>)>
+ <COND (<=? .BYTES "ASCII"> <SET BSZ 7>)
+ (<=? .BYTES "BINARY"> <SET BSZ 36>)
+ (T <ERROR ILLEGAL-BYTE-SIZE .BYTES TWAY-OPEN>)>
+ <COND (<SET RJFN <GET-JFN .NAME .MODE .BSZ .NEW?>>
+ <COND (<OR <TYPE? .IBUF? FIX> <TYPE? .OBUF? FIX>>
+ <COND (<MEMQ <GET-DEVICE-TYPE .RJFN> ,BUFFERED>
+ <SET BUF? T>)>
+ <COND (<TYPE? .IBUF? FIX> <SET IBUF? .BUF?>)>
+ <COND (<TYPE? .OBUF? FIX> <SET OBUF? .BUF?>)>)>
+ <CHTYPE [.RJFN
+ .MODE
+ .BSZ
+ <COND (.IBUF? <MAKE-BUFFER .BSZ>)>
+ 0
+ <COND (.WRITE? .RJFN)>
+ <COND (<AND .WRITE? .OBUF?> <MAKE-BUFFER .BSZ>)>
+ 0] TWAY-BASE>)>>
+
+<DEFINE MAKE-BUFFER (BSZ)
+ #DECL ((BSZ) FIX)
+ <COND (<==? .BSZ 7>
+ <ISTRING 320>)
+ (<IUVECTOR 64>)>>
+\\f
+
+<DEFINE TWAY-READ-BYTE TWB (CHANNEL OPER "AUX" (DATA <CHANNEL-DATA .CHANNEL>)
+ (IBUF <TS-RBUF .DATA>) VAL)
+ #DECL ((CHANNEL) CHANNEL (DATA) <OR TWAY-BASE TTY-CHANNEL>
+ (IBUF) <OR FALSE STRING UVECTOR>)
+ <COND (.IBUF
+ <COND (<0? <TS-RBC .DATA>>
+ ; "This allows CHANNELs to do funny buffering without
+ re-inventing the wheel."
+ <COND (<NOT <SET VAL <FCHANNEL-OP .CHANNEL FILL-READ-BUFFER>>>
+ <RETURN .VAL .TWB>)>
+ <SET IBUF <TS-RBUF .DATA>>)>
+ <COND (<0? <TS-RBC .DATA>>
+ <>)
+ (T
+ <SET VAL <1 .IBUF>>
+ <TS-RBC .DATA <- <TS-RBC .DATA> 1>>
+ <TS-RBUF .DATA <REST .IBUF>>
+ .VAL)>)
+ (T
+ <COND (<SET VAL <CALL SYSOP BIN <TS-RJFN .DATA> '(RETURN 2)>>
+ <COND (<==? <TS-BSZ .DATA> 7> <CHTYPE .VAL CHARACTER>)
+ (.VAL)>)>)>>
+
+<DEFINE TWAY-FILL-READ (CHANNEL OPER
+ "AUX" (DATA <CHANNEL-DATA .CHANNEL>)
+ (JFN <TS-RJFN .DATA>) (BUF <TOP <TS-RBUF .DATA>>)
+ NB CT)
+ #DECL ((CHANNEL) CHANNEL (DATA) <OR TWAY-BASE TTY-CHANNEL> (JFN) FIX
+ (BUF) <OR STRING UVECTOR> (CT) <OR FIX FALSE>)
+ <COND (<SET NB <CALL SYSOP SIN-JSYS .JFN .BUF
+ <- <SET CT <LENGTH .BUF>>>>>
+ <SET CT <- .CT <LENGTH .NB>>>
+ <TS-RBUF .DATA .BUF>
+ <TS-RBC .DATA .CT>
+ .CT)>>
+
+<DEFINE TWAY-READ-BUFFER (CHANNEL OPER BUF "OPTIONAL" (LEN <LENGTH .BUF>)
+ (CONT 0)
+ "AUX" (DATA <CHANNEL-DATA .CHANNEL>)
+ (IBUF <TS-RBUF .DATA>) BC)
+ #DECL ((CHANNEL) CHANNEL (BUF) <OR STRING UVECTOR> (BC LEN CONT) FIX
+ (DATA) <OR TWAY-BASE TTY-CHANNEL> (IBUF) <OR FALSE STRING UVECTOR>)
+ <SET LEN <MIN .LEN <CALL LENU .BUF>:FIX>>
+ <COND (<NOT .IBUF>
+ <COND (<SET IBUF <CALL SYSOP SIN-JSYS <TS-RJFN .DATA>
+ <REST .BUF .CONT> <- <SET BC <- .LEN .CONT>>>>>
+ <SET BC <- .BC <LENGTH .IBUF>>>
+ <+ .CONT .BC>)>)
+ (T
+ <COND (<N==? <PRIMTYPE .IBUF> <PRIMTYPE .BUF>>
+ <ERROR WRONG-TYPE-BUFFER .BUF TWAY-READ-BUFFER>)>
+ <SET BUF <REST .BUF .CONT>>
+ <SET LEN <- .LEN .CONT>>
+ <REPEAT ((RD .CONT) (TRANS -1))
+ #DECL ((RD) FIX (ONCE?) <OR ATOM FALSE>)
+ <COND (<NOT <0? <SET BC <TS-RBC .DATA>>>>
+ <SET TRANS <MIN .BC .LEN>>
+ <PROG ((CT 0))
+ #DECL ((CT) FIX)
+ <COND (<TYPE? .IBUF STRING>
+ <MAPR <>
+ <FUNCTION (IB B)
+ #DECL ((IB B) STRING)
+ <1 .B <1 .IB>>
+ <COND (<G=? <SET CT <+ .CT 1>> .TRANS>
+ <MAPLEAVE>)>>
+ .IBUF <CHTYPE .BUF STRING>>)
+ (<TYPE? .IBUF UVECTOR>
+ <MAPR <>
+ <FUNCTION (IB B)
+ #DECL ((IB B) UVECTOR)
+ <1 .B <1 .IB>>
+ <COND (<G=? <SET CT <+ .CT 1>> .TRANS>
+ <MAPLEAVE>)>>
+ <CHTYPE .IBUF UVECTOR>
+ <CHTYPE .BUF UVECTOR>>)>>
+ <SET BUF <REST .BUF .TRANS>>
+ <SET RD <+ .TRANS .RD>>
+ <TS-RBUF .DATA <REST .IBUF .TRANS>>
+ <TS-RBC .DATA <- .BC .TRANS>>
+ <SET LEN <- .LEN .TRANS>>)>
+ <COND (<OR <0? .LEN> <0? .TRANS>>
+ <RETURN .RD>)
+ (T
+ <COND (<OR <NOT <FCHANNEL-OP .CHANNEL FILL-READ-BUFFER>>
+ <0? <TS-RBC .DATA>>>
+ <RETURN .RD>)>
+ <SET IBUF <TS-RBUF .DATA>>)>>)>>
+\\f
+<DEFINE TWAY-WRITE-BYTE (CHANNEL OPER BYTE "AUX" (DATA <CHANNEL-DATA .CHANNEL>)
+ (JFN <TS-WJFN .DATA>) (BUF <TS-WBUF .DATA>))
+ #DECL ((CHANNEL) CHANNEL (BYTE) <OR CHARACTER FIX>
+ (DATA) <OR TWAY-BASE TTY-CHANNEL> (JFN) <OR FALSE FIX>)
+ <COND (<NOT .JFN>
+ <ERROR CHANNEL-NOT-OPEN-FOR-WRITING .CHANNEL TWAY-WRITE-BYTE>)>
+ <COND (<NOT .BUF>
+ <CALL SYSOP BOUT .JFN <CHTYPE .BYTE FIX> '(RETURN 2)>)
+ (T
+ <COND (<EMPTY? .BUF>
+ <DUMP-WRITE-BUFFER .DATA>
+ <SET BUF <TS-WBUF .DATA>>)>
+ <1 .BUF <COND (<TYPE? .BUF UVECTOR>
+ <CHTYPE .BYTE FIX>)
+ (<CHTYPE .BYTE CHARACTER>)>>
+ <TS-WBUF .DATA <REST .BUF>>
+ <TS-WBC .DATA <+ <TS-WBC .DATA> 1>>)>
+ .BYTE>
+
+<DEFINE DUMP-WRITE-BUFFER (DATA "AUX" VAL BUF)
+ #DECL ((DATA) <OR TWAY-BASE TTY-CHANNEL>)
+ <COND (<NOT <0? <TS-WBC .DATA>>>
+ <COND (<SET VAL <CALL SYSOP SOUT <TS-WJFN .DATA>
+ <SET BUF <CALL TOPU <TS-WBUF .DATA>>>
+ <- <TS-WBC .DATA>>>>
+ <TS-WBC .DATA 0>)>)>
+ <TS-WBUF .DATA <TOP <TS-WBUF .DATA>>>>
+
+<DEFINE TWAY-BUFOUT (CHANNEL OPER "OPTIONAL" (FORCE? T)
+ "AUX" (DATA <CHANNEL-DATA .CHANNEL>)
+ (JFN <TS-WJFN .DATA>) (BC <TS-WBC .DATA>)
+ (BUF <TS-WBUF .DATA>))
+ #DECL ((CHANNEL) CHANNEL (DATA) <OR TWAY-BASE TTY-CHANNEL> (JFN) <OR FALSE FIX>
+ (BC) FIX (BUF) <OR FALSE UVECTOR STRING> (FORCE?) <OR ATOM FALSE>)
+ <COND (.JFN
+ <COND (<AND .BUF <NOT <0? .BC>>>
+ <DUMP-WRITE-BUFFER .DATA>)>
+ <COND (.FORCE? <CALL SYSOP DOBE .JFN>)>
+ T)>>
+
+<DEFINE TWAY-WRITE-BUFFER (CHANNEL OPER BUF "OPTIONAL" (LEN <CALL LENU .BUF>)
+ "AUX" (DATA <CHANNEL-DATA .CHANNEL>)
+ (JFN <TS-WJFN .DATA>) (OBUF <TS-WBUF .DATA>))
+ #DECL ((CHANNEL) CHANNEL (BUF) <OR STRING BYTES UVECTOR> (JFN) <OR FIX FALSE>
+ (LEN) FIX)
+ <COND (<NOT .JFN>
+ <ERROR CHANNEL-NOT-OPEN-FOR-WRITING .CHANNEL TWAY-WRITE-BUFFER>)>
+ <SET LEN <MIN .LEN <CALL LENU .BUF>:FIX>>
+ <COND (<OR <NOT .OBUF>
+ <N==? <ANDB <CALL TYPE .OBUF> *7*>
+ <ANDB <CALL TYPE .BUF> *7*>>>
+ <COND (.OBUF
+ <DUMP-WRITE-BUFFER .DATA>)>
+ <COND (<G? .LEN 0>
+ <COND (<SET OBUF <CALL SYSOP SOUT .JFN .BUF <- .LEN>>>
+ <- <CALL LENU .BUF>:FIX <CALL LENU .OBUF>:FIX>)>)
+ (0)>)
+ (T
+ <REPEAT ((RD 0) TRANS CT)
+ #DECL ((CT RD TRANS) FIX)
+ <COND (<0? .LEN>
+ <RETURN .RD>)
+ (<EMPTY? .OBUF>
+ <DUMP-WRITE-BUFFER .DATA>
+ <SET OBUF <TS-WBUF .DATA>>)>
+ <SET CT 0>
+ <SET TRANS <MIN <CALL LENU .OBUF>:FIX .LEN>>
+ <COND (<TYPE? .BUF STRING>
+ <MAPR <>
+ <FUNCTION (B OB)
+ #DECL ((B OB) STRING)
+ <1 .OB <1 .B>>
+ <COND (<G=? <SET CT <+ .CT 1>> .TRANS>
+ <MAPLEAVE>)>>
+ .BUF <CHTYPE .OBUF STRING>>)
+ (<MAPR <>
+ <FUNCTION (B OB)
+ #DECL ((B OB) UVECTOR)
+ <1 .OB <1 .B>>
+ <COND (<G=? <SET CT <+ .CT 1>> .TRANS>
+ <MAPLEAVE>)>>
+ <CHTYPE .BUF UVECTOR>
+ <CHTYPE .OBUF UVECTOR>>)>
+ <SET BUF <REST .BUF .TRANS>>
+ <TS-WBUF .DATA <SET OBUF <REST .OBUF .TRANS>>>
+ <TS-WBC .DATA <+ <TS-WBC .DATA> .TRANS>>
+ <SET RD <+ .RD .TRANS>>
+ <SET LEN <- .LEN .TRANS>>>)>>
+\\f
+<DEFINE TWAY-CLOSE (CHANNEL OPER "AUX" (DATA <CHANNEL-DATA .CHANNEL>))
+ #DECL ((CHANNEL) CHANNEL (DATA) <OR TWAY-BASE TTY-CHANNEL>)
+ <COND (<TS-WJFN .DATA>
+ <COND (<TS-WBUF .DATA>
+ <DUMP-WRITE-BUFFER .DATA>)>
+ <CALL SYSOP CLOSF <TS-WJFN .DATA>>)>
+ <COND (<N==? <TS-RJFN .DATA> <TS-WJFN .DATA>>
+ <CALL SYSOP CLOSF <TS-RJFN .DATA>>)>
+ <TS-WJFN .DATA -1>
+ <TS-RJFN .DATA -1>>
+
+<DEFINE TWAY-PRINT-DATA (CHANNEL OPER OUTCHAN
+ "AUX" (DATA <CHANNEL-DATA .CHANNEL>))
+ #DECL ((CHANNEL) CHANNEL (DATA) <OR TWAY-BASE TTY-CHANNEL>)
+ <PRINC "#TWAY-CHANNEL [">
+ <PRINC "RJFN:">
+ <PRINC <TS-RJFN .DATA>>
+ <PRINC " MODE:">
+ <PRIN1 <TS-MODE .DATA>>
+ <PRINC " BSZ:">
+ <PRIN1 <TS-BSZ .DATA>>
+ <COND (<TS-RBUF .DATA>
+ <PRINC " RBUF:">
+ <PRIN1 <TS-RBC .DATA>>
+ <PRINC !\/>
+ <PRIN1 <LENGTH <TOP <TS-RBUF .DATA>>>>)>
+ <COND (<TS-WJFN .DATA>
+ <PRINC " WJFN:">
+ <PRINC <TS-WJFN .DATA>>
+ <COND (<TS-WBUF .DATA>
+ <PRINC " WBUF:">
+ <PRIN1 <TS-WBC .DATA>>
+ <PRINC !\/>
+ <PRIN1 <LENGTH <TOP <TS-WBUF .DATA>>>>)>)>
+ <PRINC !\]>
+ T>
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff