From a94bfe9cf761a6a72a12a98aa41805037620a462 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Thu, 24 Nov 2016 09:10:52 -0800 Subject: [PATCH] Added support for FTP client and server. --- Makefile | 2 +- README.md | 5 +- build/build.tcl | 20 + doc/_info_/ftp.info | 221 ++++ doc/info/ftp.14 | 342 +++++ src/klh/nuuos.205 | 1356 ++++++++++++++++++++ src/klh/out.250 | 2709 ++++++++++++++++++++++++++++++++++++++++ src/ksc/nfnpar.7 | 80 ++ src/ksc/nscan.8 | 117 ++ src/ksc/pagser.49 | 879 +++++++++++++ src/sysnet/ftps.336 | 2873 +++++++++++++++++++++++++++++++++++++++++++ src/sysnet/ftpu.161 | 2816 ++++++++++++++++++++++++++++++++++++++++++ 12 files changed, 11418 insertions(+), 2 deletions(-) create mode 100755 doc/_info_/ftp.info create mode 100755 doc/info/ftp.14 create mode 100755 src/klh/nuuos.205 create mode 100755 src/klh/out.250 create mode 100755 src/ksc/nfnpar.7 create mode 100755 src/ksc/nscan.8 create mode 100755 src/ksc/pagser.49 create mode 100755 src/sysnet/ftps.336 create mode 100755 src/sysnet/ftpu.161 diff --git a/Makefile b/Makefile index b6d733aa..fca7bfb9 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ EMULATOR ?= simh -SRC = system syseng sysen1 sysen2 sysnet kshack dragon channa midas _teco_ emacs rms klh syshst sra mrc +SRC = system syseng sysen1 sysen2 sysnet kshack dragon channa midas _teco_ emacs rms klh syshst sra mrc ksc DOC = info _info_ sysdoc kshack _teco_ emacs emacs1 MINSYS = _ sys sys2 sys3 device emacs _teco_ sysbin RAM = bin/boot/ram.262 diff --git a/README.md b/README.md index cfe1e639..93ef8b14 100644 --- a/README.md +++ b/README.md @@ -62,6 +62,8 @@ from scratch. - TELSER, Telnet/Supdup server - TELNET, Telnet client - SUPDUP, Supdup client + - FTPS, FTP Server + - FTPU, FTP Client 6. A brand new host table is built from the host table source and installed into SYSBIN; HOSTS3 > using H3MAKE. @@ -76,7 +78,8 @@ host table tools, and binary host table are installed. Currently, basic TCP network support is in the build, in addition to both a TELNET/SUPDUP server, and both TELNET and SUPDUP clients. -Other network services will appear in a subsequent release. +Additionally, both an FTP server and client are included. Other network +services will appear in a subsequent release. The KLH10 dskdmp.ini file has an IP address (192.168.1.100) and gateway IP address (192.168.0.45) configured for the ITS system. The IP address diff --git a/build/build.tcl b/build/build.tcl index 23aa8d87..6fe7462c 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -320,6 +320,7 @@ respond "*" ":midas sysbin;telnet_sysnet;telnet\r" expect ":KILL" respond "*" ":link sys;ts telnet,sysbin;telnet bin\r" +respond "*" ":link sys;ts tn,sys;ts telnet\r" # supdup port (95) uses telser respond "*" ":link device;tcp syn137,sysbin;telser bin\r" @@ -333,6 +334,25 @@ type ":vk\r" respond "*" ":link sys1;ts supdup,sysbin;supdup bin\r" +respond "*" ":link syseng;fsdefs 999999,system;fsdefs >\r" + +# these two links are expected by sysnet; ftps > and are present +# in the PI distribution +respond "*" ":link ksc;nuuos 999999,klh;nuuos >\r" +respond "*" ":link ksc;macros 999999,klh;macros >\r" +respond "*" ":link ksc;out 999999,klh; out >\r" + +respond "*" ":midas sysbin;ftps_sysnet;ftps \r" +expect ":KILL" + +respond "*" ":link device;tcp syn025,sysbin;ftps bin\r" +respond "*" ":link device;tcp syn031,sysbin;ftps bin\r" + +respond "*" ":midas sysbin;ftpu_sysnet;ftpu \r" +expect ":KILL" + +respond "*" ":link sys;ts ftp,sysbin;ftpu bin\r" + respond "*" ":link kshack;good ram,.;ram ram\r" respond "*" ":link kshack;ddt bin,.;@ ddt\r" respond "*" $emulator_escape diff --git a/doc/_info_/ftp.info b/doc/_info_/ftp.info new file mode 100755 index 00000000..b22dade1 --- /dev/null +++ b/doc/_info_/ftp.info @@ -0,0 +1,221 @@ +Description of FTP commands, as or 2/5/77 + + +Some Useful FTP Commands: + +CONNECT Connects to a foreign host. Use the name of the host + or its (octal) numeric address. Any pre-existing + connection will be flushed. + FTP prompts with "$$" when it is not connected to + a foreign host, and with "$" when a connection exists. + + Is equivalent to CONN . + +HOSTS Lists the names of hosts which FTP knows + +LOGIN Logs in at foreign host (if needed by that host) + If you get an error message implying that you are not + logged in, this is where to start. Sometimes FTP + will figure out by itself that logging in is what you + have to do; then it will ask for for a user name, + send it, and go ahead with the operation you had + already requested. + +TEN Mode command for pdp10 36 bit binary files. + (May also be used for pdp10 ascii files if you don't + mind extraneous characters at the end of the file) + NOTE: This is the DEFAULT mode when communicating with + another PDP10. You can specify it explicitly, also, + with any computer (although some may not accept it). + It is an abbreviation for TYPE I and BYTE 36 + +TEXT Mode command for Network ASCII data transmission. + This mode is the DEFAULT when communicating with a + machine that is not a PDP10. It is an abbreviation + for TYPE A and BYTE 8. + +GET or RETRIEVE Transfers a file from foreign host to here. + Asks for local name (end with CR) and then foreign name. + +PUT or STORE Transfers a file from here to foreign host. + or SEND Asks for local name (end with CR) and then foreign name. + +APPEND Appends a local file onto a file at the foreign host. + Arguments are local file (not changed by the operation) + followed by the foreign file (which will be created if + it does not exist), as for PUT. + +TRAN = + Transfers at to at . + Two foreign hosts can't be used, though; one of + and must be the local host's name. + Abbreviations are allowed: You can leave out the + name of the local host (omitting the altmode as well), + as in TRAN FOO BAR=MCFOO BAR or TRAN MCFOO BAR=X Y, + and if the two filespecs are identical either one may + be omitted, as in TRAN FOO BAR=MC which is equivalent + to TRAN FOO BAR=MCFOO BAR. + NOTE: "_" is equivalent to "=". To include a "=" or + "_" or a ^Q in a filename in a TRAN command, precede + it with a ^Q (which will be gobbled up as a quoter). + ^Q's followed by other characters (not _, = or ^Q) + will NOT be absorbed by TRAN (so you can use them to + quote at other levels, with hosts that understand it). + +QUIT Closes connection to foreign host, and then exit from FTP + +^C Is the same as QUIT - no CR is needed. + Any command may be terminated with a ^C instead of a + CR, in which case that command will be followed by + a QUIT (unless it encounters an error). + +DISC Closes connection to foreign host. You may then connect + to another host, or QUIT, or ^Z... + +HELP or ? Types a list of commands, with brief descritions. + + +Less useful commands: + +DELETE Deletes the specified file at the foreign host. + +RENAME + + Renames the file at the foreign host to be + called . Separate the two names with a CR. + +DIRECTORY or +LISTF Types out a listing of the foreign host's directory . + Some hosts may also allow you to specify a filename, + in which case info on that file will be given. + +LISTB Types out a brief listing of a foreign directory. + It is like LISTF except that onlty the filenames are + typed - no other info on the files. + +LISTL Types out a listing of the directory at + the local host. + +CWD Sets the foreign default directory to + +DEFAULTS + Sets the local filename defaults to . + Note: the local defaults are sticky; each local + filename's names default to the last filenames + specified for a local file. + + +Rarely Useful Commands: + +STATUS Asks for a status message from the foreign host. + The meaning of is site-dependent. ITS sites + don't implement the command at all. + +QUOTE Sends directly to the foreign host over + the TELNET connection. Used if the foreign host + implements some simple command that FTP doesn't know + about itself. It won't work for commands that do + anything hairy (such as use the data connection at + all) since FTP doesn't expect it do do that. + +SOAK Waits for and describes one reply from the server. + This is never necessary with any of the normal + FTP commands, since they know when to wait for + replies. + +DEBUG Toggles the switch which says whether to print expected + replies from the server (unexpected replies such as + error messages and notices to the user are always + printed). The DEBUG switch also causes reply codes + to be given with all replies, not just error messages. + +PASS Sends a password to a foreign host. Note that after + a LOGIN command, if a password is needed, FTP will + usually be able to figure that out; it will ask you + for the password and send it automatically, so you + need not explicitly give a PASSWORD command. + +ACCT Sends an account number to the foreign host. Note + that if after a LOGIN command an account number is + needed, FTP will usually figure that out and just + ask you for it. So you usually won't need to give + an explicit ACCT command. + +BYE Is like QUIT, but it notifies the foreign host + with a BYE command before closing the connection. + Is this ever useful? ^C is easier. + +ALLOCATE Sends the foreign host the estimated size of a file + you are about to send it (measured in bytes). Most + hosts don't need ALLOCATE commands since they can + allocate file storage dynamically. + +TYPE Says what transfer type to use. Of the many types + specified in the FTP protocol, only A (ASCII) and + I (Image) are implemented on ITS. You usually + would rather use the TEXT or TEN commands, since + they specify the two most useful combinations of + TYPE and BYTE. + +BYTE Says what byte size to use for transfers. The only + byte sizes implemented on ITS for FTP'ing are 8, + 32 and 36. In any case, you should usually use the + TEXT and TEN commands for mode-setting. + + +Giving FTP commands from DDT: + +If you do :FTP and contains an = or a _, +FTP automatically does a TRAN command with +as arguments. After that transfer completes, FTP +kills itself. For example, :FTP FOO BAR=MC will +transfer FOO BAR from MC to the local host, leaving +you back in DDT. + +If the command string from DDT does not contain an = or a _, +it is simply executed as an FTP command. FTP will then read +more commands from the TTY, since one FTP command (unless it +is TRAN) is not usually enough for a whole transaction. + + +Filename Defaulting: + +Local filenames default "stickily", so that each file's device, +sname, and first and second filenames all default to the last +such names specified for a local file. +Giving a null argument for the local file will cause the default +file to be used. +When you specify only one filename, it is the first filename, +and ">" is used as the second. +The initial default directory is your working directory. + +If you wish to include a space, colon, or semicolon in a local +filename (or in a foreign filename if the foreign site is an ITS), +precede it with a ^Q. The same technique is used for including +a = or _ or ^Q anywhere in a pathname, in the TRAN command. + + +Type-in Conventions: + +You can use Rubout to delete one character, ^D, ^G or ^U to +cancel an entire line, and ^L to redisplay the current line +as typed so far. Commands with no arguments should be terminated +with a CR. When giving a command with arguments, you can +separate the command name from the first argument with either +a space or a CR (if you use CR, FTP will tell you what sort +of argument is expected). When a command requires several +arguments, the arguments are separated with CRs. + +You can use a ^C instead of CR to terminate a line. That +causes FTP to return to DDT, killing itself, after the current +command is finished (as long as it does not get an error). +If you plan to disown a FTP while it is transfering, you should +end the last command with a ^C so that the FTP will go away +when it is finished; otherwise it might hang around for hours +until someone notices it and kills it. + +You can use ^N instead of CR to terminate a line. This is not +especially useful when you are typing on the TTY, but it is +useful when passing commands from DDT, since it allows you to +put several lines' worth of input into the one line that DDT lets +you send. diff --git a/doc/info/ftp.14 b/doc/info/ftp.14 new file mode 100755 index 00000000..260fbbe9 --- /dev/null +++ b/doc/info/ftp.14 @@ -0,0 +1,342 @@ +-*-Text-*- + +File: FTP Node: TOP Up: (DIR) Next: BASIC + +Description of FTP commands, as of 2/5/77 + +FTP is a utility program for transferring files over the ARPA network. +The name of the program comes from the name of the protocol used +(File Transfer Protocol). + +* Menu: + +* BASIC:: The basic FTP commands. +* TYPE IN:: FTP's typein conventions. +* LESS:: Some less useful commands. +* DEFAULTS:: How FTP does file name defaulting. +* RARE:: The rarely used commands. +* JCL:: Giving FTP commands from DDT. +* XFILE:: Command files. +* INFERIOR:: Programs can use FTP as a subroutine. + + +File: FTP, Node: BASIC, Previous: TOP, Up: TOP, Next: TYPE IN + +The Most Useful FTP Commands: + Note that unambiguous abbreviations may be used for command and + host names. See the Next node for how to edit your input. + +CONNECT Connects to a foreign host. Use the name of the host + or its (octal) numeric address. A pre-existing + connection will be flushed. + FTP prompts with "$$" when it is not connected to + a foreign host, and with "$" when a connection exists. + + Is equivalent to CONN . + +HOSTS Lists the names of hosts which FTP knows + +LOGIN Logs in at foreign host (if needed by that host) + If you get an error message implying that you are not + logged in, this is where to start. Sometimes FTP + will figure out by itself that logging in is what you + have to do; then it will ask for for a user name, + send it, and go ahead with the operation you had + already requested. + +TEN Mode command for pdp10 36 bit binary files. + (May also be used for pdp10 ascii files if you don't + mind extraneous characters at the end of the file) + NOTE: This is the DEFAULT mode when communicating with + another PDP10. You can specify it explicitly, also, + with any computer (although some may not accept it). + It is an abbreviation for TYPE I and BYTE 36 + +TEXT Mode command for Network ASCII data transmission. + This mode is the DEFAULT when communicating with a + machine that is not a PDP10. It is an abbreviation + for TYPE A and BYTE 8. + +GET or RETRIEVE Transfers a file from foreign host to here. + Asks for local name (end with CR) and then foreign name. + +PUT or STORE Transfers a file from here to foreign host. + or SEND Asks for local name (end with CR) and then foreign name. + +APPEND Appends a local file onto a file at the foreign host. + Arguments are local file (not changed by the operation) + followed by the foreign file (which will be created if + it does not exist), as for PUT. + +TRANSFER = + Transfers at to at . + Two foreign hosts can't be used, though; one of + and must be the local host's name. + Abbreviations are allowed: You can leave out the + name of the local host (omitting the altmode as well), + as in TRAN FOO BAR=MCFOO BAR or TRAN MCFOO BAR=X Y, + and if the two filespecs are identical either one may + be omitted, as in TRAN FOO BAR=MC which is equivalent + to TRAN FOO BAR=MCFOO BAR. + NOTE: "_" is equivalent to "=". To include a "=" or + "_" or a ^Q in a filename in a TRAN command, precede + it with a ^Q (which will be gobbled up as a quote). + ^Q's followed by other characters (not _, = or ^Q) + will NOT be absorbed by TRAN (so you can use them to + quote at other levels, with hosts that understand it). + +QUIT Closes connection to foreign host, and then exit from FTP + +^C Is the same as QUIT - no CR is needed. + Any command may be terminated with a ^C instead of a + CR, in which case that command will be followed by + a QUIT (unless it encounters an error). + +DISC Closes connection to foreign host. You may then connect + to another host, or QUIT, or ^Z... + +HELP or ? Types a list of commands, with brief descriptions. + +File: FTP, Node: TYPE IN, Up: TOP, Previous: BASIC, Next: DEFAULTS + +Type-in Conventions: + +You can use Rubout to delete one character, ^D, ^G or ^U to +cancel an entire line, and ^L to redisplay the current line +as typed so far. Commands with no arguments should be terminated +with a CR. When giving a command with arguments, you can +separate the command name from the first argument with either +a space or a CR (if you use CR, FTP will tell you what sort +of argument is expected). When a command requires several +arguments, the arguments are separated with CRs. Command names may be +abbreviated as long as the abbreviations are unambiguous. + +You can use a ^C instead of CR to terminate a line. That +causes FTP to return to DDT, killing itself, after the current +command is finished (as long as it does not get an error). +If you plan to disown a FTP while it is transferring, you should +end the last command with a ^C so that the FTP will go away +when it is finished; otherwise it might hang around for an hour +until ITS kills it. + +You can use ^N instead of CR to terminate a line. This is not +especially useful when you are typing on the TTY, but it is +useful when passing commands from DDT, since it allows you to +put several lines' worth of input into the one line that DDT lets +you send. + +File: FTP, Node: DEFAULTS, Up: TOP, Previous: TYPE IN, Next: LESS + +Filename Defaulting: + +Local filenames default "stickily", so that each file's device, +sname, and first and second filenames all default to the last +such names specified for a local file. +Giving a null argument for the local file will cause the default +file to be used. +When you specify only one filename, it is the first filename, +and ">" is used as the second. +The initial default directory is your working directory. + +If you wish to include a space, colon, or semicolon in a local +filename (or in a foreign filename if the foreign site is an ITS), +precede it with a ^Q. The same technique is used for including +a = or _ or ^Q anywhere in a pathname, in the TRAN command. + +File: FTP, Node: LESS, Previous: DEFAULTS, Up: TOP, Next: RARE + +Less useful commands: + +DELETE Deletes the specified file at the foreign host. + +RENAME + + Renames the file at the foreign host to be + called . Separate the two names with a CR. + +DIRECTORY or +LISTF Types out a listing of the foreign host's directory . + Some hosts may also allow you to specify a filename, + in which case info on that file will be given. + +LISTB Types out a brief listing of a foreign directory. + It is like LISTF except that only the filenames are + typed - no other info on the files. + +LISTL Types out a listing of the directory at + the local host. + +CWD Sets the foreign default directory to + +DEFAULTS + Sets the local filename defaults to . + Note: the local defaults are sticky; each local + filename's names default to the last filenames + specified for a local file. + +File: FTP, Node: RARE, Previous: LESS, Up: TOP, Next: JCL + +Rarely Useful Commands: + +STATUS Asks for a status message from the foreign host. + The meaning of is site-dependent. ITS sites + don't implement the command at all. + +QUOTE Sends directly to the foreign host over + the TELNET connection. Used if the foreign host + implements some simple command that FTP doesn't know + about itself. It won't work for commands that do + anything hairy (such as use the data connection at + all) since FTP doesn't expect it to do that. + +SOAK Waits for and describes one reply from the server. + This is never necessary with any of the normal + FTP commands, since they know when to wait for + replies. + +DEBUG Toggles the switch which says whether to print expected + replies from the server (unexpected replies such as + error messages and notices to the user are always + printed). The DEBUG switch also causes reply codes + to be given with all replies, not just error messages. + +PASS Sends a password to a foreign host. Note that after + a LOGIN command, if a password is needed, FTP will + usually be able to figure that out; it will ask you + for the password and send it automatically, so you + need not explicitly give a PASSWORD command. + +ACCT Sends an account number to the foreign host. Note + that if after a LOGIN command an account number is + needed, FTP will usually figure that out and just + ask you for it. So you usually won't need to give + an explicit ACCT command. + +ALLOCATE Sends the foreign host the estimated size of a file + you are about to send it (measured in bytes). Most + hosts don't need ALLOCATE commands since they can + allocate file storage dynamically. + +TYPE Says what transfer type to use. Of the many types + specified in the FTP protocol, only A (ASCII) and + I (Image) are implemented on ITS. You usually + would rather use the TEXT or TEN commands, since + they specify the two most useful combinations of + TYPE and BYTE. + +BYTE Says what byte size to use for transfers. The only + byte sizes implemented on ITS for FTP'ing are 8, + 32 and 36. In any case, you should usually use the + TEXT and TEN commands for mode-setting. + +ICPSOCKET + Causes FTP to try to connect to servers using socket + rather than socket 3, the standard FTP server + listen socket. Useful for testing experimental + versions of the server, not actually installed yet. + +SILENT Tells FTP not to type out on the terminal at all. + This remains in effect until FTP tries to read input + from the terminal. It does not affect printing in a + script file. + +PROCEED Tells FTP to continue running without the terminal. + FTP accomplishes this by valretting a ^P command. A + SILENT is done automatically. This command is illegal + when commands are being read from the terminal, unless + TTY input was actually translated to a file. + +DISOWN Tells FTP to continue running disowned. Just like + PROCEED except that the FTP is disowned as well as + ^P'd. + +VALRET Returns to FTP's superior with a .BREAK 16,100000 + (which does not kill the FTP). The FTP can be + proceeded, or it can be given new JCL and restarted. + +File: FTP, Node: JCL, Up: TOP, Previous: RARE, Next: XFILE + +Giving FTP commands from DDT: + +If you do :FTP and contains an = or a _, +FTP automatically does a TRAN command with +as arguments. After that transfer completes, FTP +kills itself. For example, :FTP FOO BAR=MC will +transfer FOO BAR from MC to the local host, leaving +you back in DDT. + +If the command string from DDT does not contain an = or a _, +it is simply executed as an FTP command. FTP will then read +more commands from the TTY, since one FTP command (unless it +is TRAN) is not usually enough for a whole transaction. + + +File: FTP, Node: XFILE, Up: TOP, Previous: JCL, Next: INFERIOR + +Command Files: + +XFILE Tells FTP to open and read commands from it. + Commands in an execute file look just like commands + typed on the TTY. Linefeeds are ignored, so you ought + to use CRLF between lines. Any error (such as a + failure to establish a connection or a failure to find + a file) causes reading from the command file to be + discontinued. + +SCRIPT Tells FTP to open and print init everything + that appears on the TTY. If there is no command file + (commands are still being read from the TTY) then + output continues to go to the TTY as well as the + script file. If there is a command file and a script + file, then nothing is output to the TTY. If you wish + to have an FTP run without your attention, you need to + have both a script file and a command file. + +ESCRIPT Tells FTP to stop using a script file. If there is a + script file open, it is closed. This isn't necessary + if you are doing a QUIT or ^C. + +One reasonable way to operate is to give FTP a SCRIPT command and then +an XFILE command from the TTY, and then ^P the FTP. If the command +file does not do a QUIT then when it is finished you will be told +that "FTP wants the TTY". Alternatively, the command file might +contain a PROCEED command which would do the ^P automatically. + +File: FTP, Node: INFERIOR, Up: Top, Previous: XFILE + +Use of FTP as a Subroutine + + You can invoke FTP as an inferior to transfer some files as long as +you provide it with a source of commands and a place to list its +commands and replies. The command source can be provided either by +translating TTY input to a file, or by giving an XFILE command as JCL. +A file for listing can be provided either by translating TTY output to +a file or by including a SCRIPT command in the JCL. If you are not +interested in looking at the output (you trust that the foreign hosts +will be available, etc) then you can use NUL: as an output sink. The +SILENT command may be helpful in suppressing inconvenient typeout that +might occur before you have both a command file and a script file set +up. Either way, you do not need to give FTP actual ownership of the +TTY. + + If you wish to include all the commands in the JCL string, there is +no need for a command file. There will still be a need for a script +file, however. Multiple commands in JCL are separated either with +CRLF or with ^N. Note, however, that commands that came from the JCL +will not be echoed to the script file, while commands from an XFILE or +a translated TTY will be echoed. + + If you did not translate TTY input (you gave a XFILE or put all the +commands in the JCL) then on any error FTP will execute a .BREAK 16, +which specifies that type-ahead is to be discarded. If you are not +watching the FTP replies, this can be used as an indication that there +was recently an error. + + If you wish to use a single FTP job for several operations, not all +at once, the VALRET command is useful. It makes FTP stop and return +control to its superior with a .BREAK 16,100000, without altering any +of its state variables. The VALRET command should go in the command +stream at the end of the commands for a single run. After the FTP +returns, it can be proceeded (to continue with commands from the same +source) or it can be given some fresh JCL and restarted from its +normal starting address. diff --git a/src/klh/nuuos.205 b/src/klh/nuuos.205 new file mode 100755 index 00000000..9df6a5d6 --- /dev/null +++ b/src/klh/nuuos.205 @@ -0,0 +1,1356 @@ +;;;-*-MIDAS-*- + +;PRINT VERSION NUMBER +.TYO6 .IFNM1 +.TYO 40 +.TYO6 .IFNM2 +PRINTX/ included in this assembly. +/ + +;;;----------------------------------------------------- +;;; Necessary external defs for UUOs +;;; +;;; U1,U2,U3,U4 ; Sequential ACs which UUO rtns clobber with abandon. +;;; P ; PDL AC +;;; L ; LSE pointer AC (optional, only need if ULISTS set) +;;; AUTPSY ; Routine JSR'd to if fatal UUO error occurs. +;;; ; and file containing wonderful "FWRITE" macro etc. + +IFE .OSMIDAS-SIXBIT/ITS/, .INSRT KSC;MACROS > ; Note file contains OS defs. +IFN .OSMIDAS-SIXBIT/ITS/, .INSRT MACROS.MID + +;;;---------------------------------------------------- +;;; Assembly switches (for optional features and hacks). +;;; The only default UUOs are byte-ptr operations. + ; If set... +IFNDEF $$UJSR,$$UJSR==0 ; UUO vector is JSR UUOH +IFNDEF $$UCAL,$$UCAL==0 ; UUO vector is CALL UUOH (PUSHJ P,) +IFNDEF $$UJSP,$$UJSP==0 ; UUO vector is JSP X,UUOH (not yet) +IFE $$UJSR\$$UCAL\$$UJSP,$$UJSR==1 ; Default is JSR. + + ; Set 1 to assemble: +IFNDEF UBONES,UBONES==0 ; Nothing but dispatcher +IFNDEF $$OUUO,$$OUUO==0 ; Old output UUOs for compatibility +IFNDEF UAREAS,UAREAS==0 ; Area hackery +IFNDEF USTRGS,USTRGS==0 ; String hackery (requires UAREAS) +IFNDEF ULISTS,ULISTS==0 ; List hackery ( " " ) +IFNDEF USCALL,USCALL==0 ; Obsolete .CALL execution UUO. +IFNDEF $$UPSR,$$UPSR==0 ; New PAGSER instead of CORSER. + + IFN ULISTS,UAREAS==1 ; List hackery needs area hackery. + IFN USTRGS,UAREAS==1 ; ditto string variable hackery + +IFN $$OUUO,[ ; Stuff for compatibility with old output UUO code + +IFNDEF $$OFLT,$$OFLT== ; Assemble floating + ; point output code (compatibility crock) +IFNDEF $$OERR,$$OERR== ; Assemble ERR output + ; type (on ITS, also need ERRCHN def'd) + +IFNDEF OC, OC=:U2 ; Define Output Channel for standard-out rtns +] ; IFN $$OUUO +IFNDEF $$SAV2,{ ; Should routines save U2 or not? + $$SAV2==0 ; No, unless either $$OUUO or $$OUT is set, + IFN $$OUUO, IFE U2-OC, $$SAV2==1 ; and U2 = OC. + IFDEF $$OUT,IFN $$OUT, IFE U2-OC, $$SAV2==1 +} +DEFINE IFSVU2 +IFN $$SAV2!TERMIN + +;;;;;;;;;;;;;;;;;;;; Storage & External Definitions ;;;;;;;;;;;;;;;;;;;;;;;; + +U40=:40 ; Location of UUO instruction after trapping +UUOBEG==. ; Mark beginning of code for UUO pkg. UUOEND will be last. + +BVAR ; Trap via JSR here when hit some fatal condition. +IF2 IFNDEF AUTPSY, AUTPSY: ; Define labels here if not done externally. +IF2 IFNDEF SYSLOS, SYSLOS: + 0 ; JSR-call, impure. +IFN OS%ITS, .VALUE +.ELSE HALT . + +ILU40: 0 ; Holds illegal UUO if one detected +ILULOC: 0 ; and location it trapped from. + +EVAR + +;;;;;;;;;;;;;;;;;;;;;;;;; UUO Dispatcher ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Two different dispatch methods are coded here; the old, used when +;;; $$UJSR==1, is a traditional JSR. The new, used when +;;; $$UCAL==1, is a PUSHJ. The latter is slightly slower but allows +;;; more flexibility in the UUO routines, and makes output UUO's +;;; a bit faster. A switch $$UJSP also exists for possible future +;;; use of a JSP dispatch; this is mostly to remind hackers that +;;; the UUO dispatch method is not just a binary proposition. + +IFN $$UJSR,BVAR ; UUO dispatcher must be in impure if JSR. + +UUOH: IFN $$UJSR, 0 ; If JSR, need smashable word here. + LDB U1,[330600,,U40] ; Get bottom 6 bits of opcode (0 - 77) + JRST @UUOTAB(U1) ; Dispatch fearlessly - table is full. +IFN $$UJSR, EVAR +UACFLD: $ACFLD,,U40 ; Byte ptr to UUO's AC field (used often) + + ;;; UUOCAL - Define UUO vector instruction + +UUOCAL=: +TMPLOC 41,{UUOCAL} ; This vectors UUO's to handler above. + + ;;; UUOXRT - Define UUO return instruction + ;;; (can't be UUORET, compat screw.) + +UUOXRT=: + + ;;; UUORTL - Define UUO return location for JRST'ing. + +IFN $$UCAL,{DEFINE UUORTL +[POPJ P,]!TERMIN } +IFN $$UJSR,{DEFINE UUORTL +@UUOH!TERMIN } + ; Compatibility kludge. Want to stop using UUORET for UUORTL. + ; When nothing uses UUORET any more, make it = to UUOXRT. +IFN $$UJSR,EQUALS UUORET,UUORTL + + ;;; UUORPC - Define UUO return PC location (for things like AOS'ing). + ;;; Dangerous since easy to forget PDL level is important. +IFN $$UCAL,{DEFINE UUORPC +(P)!TERMIN } +IFN $$UJSR,{DEFINE UUORPC +UUOH!TERMIN } + +;;;;;;;;;;;;;;;;;;;;;;;;; General Dispatch Support ;;;;;;;;;;;;;;;;;;;;;;;; + + ;;; UUO dispatch table, indexed by UUO opcode. Unused entries go to + ;;; illegal-uuo routine. + +UUOTAB: REPEAT 100,SETZ ILUUO + + ; An illegal UUO dispatches here... +ILUUO: EXCH U1,U40 ; Illegal UUO!! Save info for debugging. + MOVEM U1,ILU40 ; Save illegal uuo being xct'd + EXCH U1,U40 ; Restore + EXCH U1,UUORPC ; Get return PC for UUO + MOVEM U1,ILULOC ; Save location+1 of illegal uuo + EXCH U1,UUORPC ; Restore + JSR AUTPSY ; Signal fatal error. + +;;; UUODEF , +;;; Macro to define UUO's; defines as a UUO name which will dispatch +;;; to when executed. + +IF1 .M"%%UCNT==0 +DEFINE UUODEF NAMEL,HANDLR +IRPS NAME,,[NAMEL] +IF1 [.M"%%UCNT==.M"%%UCNT+1 +IFE .M"%%UCNT-40,.M"%%UCNT==50 +IFG .M"%%UCNT-77,.ERR Too many UUO's def'd. +IFG .M"%%UCNT-47,PRINTC /Warning - "!NAME!" will be a SLOW UUO!/ +.M"NAME=.M"%%UCNT_27. +] +TMPLOC , HANDLR +TERMIN TERMIN + +;;; Now define two subclasses of UUOs - those which only use their AC or E +;;; field for arguments, rather than both. +;;; The U.OPER subclass of UUOs (after the similar ITS call named .OPER) +;;; use only their AC field for arguments and are thus indexed by the +;;; (unused) E field. The number of such UUO's is effectively infinite. +;;; The U.CALL subclass of UUOs (after the similar ITS call named .CALL) +;;; use only their E field for arguments and are thus indexed by the +;;; (unused) AC field. Up to 16. sub-UUO's can be defined for each +;;; opcode used this way; currently only U.CALL is so used. +;;; +;;; UUODFE defines a UUO that uses E only. = U.CALL , +;;; UUODFA defines a UUO that uses AC only. = U.OPER +;;; UUODFN defines a UUO that uses neither. = U.OPER + +;;;;;;;;;;;;;;;;;; U.OPER - UUODFA, UUODFN ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +UUODEF U.OPER:,U.OPR ; UUO to handle UUODFA's and UUODFN's, which only use + ; their AC field. These UUO's are thus indexed by E. +U.OPR: HRRZ U3,U40 + CAIGE U3,UOPMAX ; Check index high end, and skip if illegal. + JRST @UOPTAB(U3) + JRST ILUUO ; Sigh... + + ; Dispatch table for U.OPER UUO's. +IFNDEF UOPMAX,UOPMAX==:20. ; Can vary table size at will. +UOPTAB: REPEAT UOPMAX,ILUUO + + ; Macro for UUODFA (defining U.OPER's) +IF1 .M"%%UOPC==-1 +DEFINE UUODFA NAMEL,HANDLR +IRPS NAME,,[NAMEL] +IF1 [.M"%%UOPC==.M"%%UOPC+1 +IFGE .M"%%UOPC-UOPMAX,.ERR Too many U.OPER's, increment UOPMAX! +.M"NAME=U.OPER .M"%%UOPC +] +TMPLOC UOPTAB+.M"NAME,HANDLR +TERMIN TERMIN +EQUALS UUODFN,UUODFA ;UUO's not using E are dispatched in same way. + +;;;;;;;;;;;;;;;;;; U.CALL - UUODFE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;;; U.CALL routine and UUODFE macro +UUODEF U.CALL:,U.CAL ; UUO to handle UUODFE's, which only use E field. + ; These UUO's are thus indexed by AC. +U.CAL: LDB U3,UACFLD ; Get ac field + JRST @UCLTAB(U3) ; Dispatch (safely since table is full) + + ; Dispatch table for U.CALL UUO's. +UCLTAB: REPEAT 20,ILUUO + +IF1 .M"%%UCLC==-1 +DEFINE UUODFE NAMEL,HANDLR +IRPS NAME,,[NAMEL] +IF1 [.M"%%UCLC==.M"%%UCLC+1 +IFGE .M"%%UCLC-20,.ERR Too many U.CALL's! +.M"NAME=U.CALL .M"%%UCLC, +] +TMPLOC UCLTAB+<17&<.M"NAME_-23.>>,HANDLR +TERMIN TERMIN + + ; If only want "bare-bones" (dispatcher), ignore rest of file + ; by halting input here. +IFN UBONES, CONSTANTS ? .INEOF + +SUBTTL Byte Pointers - DBP7, DBP, PTSKIP, PTRDIF, ADJBP + +; Byte pointer hacking uuos. DBP and ADJBP work for any size byte, +; whereas DBP7, PTSKIP, and PTRDIF assume byte size = 7 (ASCII char) + +; Could add DLDB, DDPB to oppose ILDB, IDPB? +; Add general form of PTSKIP, PTRDIF? + +; DBP7 [bp] decrements 7-bit byte ptr at E. + +UUODFE DBP7:,UDBP7 +UDBP7: SKIPGE U1,@U40 ; Get c(E) and check for beginning ptr. + UUOXRT ; It's either 440700,, or -1,, + MDBP7 U1, ; Decrement, using macro. + MOVEM U1,@U40 ; store result + UUOXRT +EQUALS D7BPT,DBP7 ; Remain compatible with old name + + +; DBP [bp] General-purpose byte ptr decrement. Works for +; any size byte. + +UUODFE DBP:,UDBPT +UDBPT: MOVE U1,@U40 ; Get c(E) + LDB U4,[300600,,U1] ; Get byte size + LDB U3,[360600,,U1] ; Get offset within word + ADD U3,U4 ; Move offset back up + CAIL U3,44 ; Still within word? + JRST UDBPT1 ; No. + DPB U3,[360600,,@U40] ; Yes, put new offset back in (directly!) + UUOXRT +UDBPT1: MOVEI U3,44 ; Outside word. get # bits in wd. + IDIV U3,U4 ; Get u3=#bytes in wd.,u4=remainder, i.e.# bits remaining + DPB U4,[360600,,U1] ; at low end. store as new offset. + HRRI U1,-1(U1) ; Get addr-1 pointed to, and store in result. + MOVEM U1,@U40 ; and store result + UUOXRT ; and return + +EQUALS DECBPT,DBP ; Preserve compatibility with old name + +; PTSKIP AC,[byte ptr] Skips (increments) byte ptr in E by +; # of chars specified in AC. Assumes 7-bit bytes. Works for +; both positive and negative skip values. + +UUODEF PTSKIP:,U7SKP +U7SKP: MOVE U1,@U40 ; Get c(E) +IFSVU2,[MOVE U3,U1 + MULI U3,5 + ADD U4,UADBP7(U3) + MOVE U3,U4 ] ; Keeping away from U2 requires extra MOVE +.ELSE [ MOVE U2,U1 ; Make copy in U2 + MULI U2,5 + ADD U3,UADBP7(U2) ] ; Convert to canonical form + LDB U4,UACFLD ; Get AC + ADD U3,(U4) ; Add in desired change + IDIVI U3,5 ; Now change back from canonical + HRRI U1,(U3) ; Store new addr + TLZ U1,770000 ; Mask off old p + SUB U1,U7BPT2(U4) ; Put in new p (with maybe a -1 fix to addr) + MOVEM U1,@U40 ; Store new ptr. + UUOXRT + +U7BPT2: 770000,,1 ; 0 chs left in wd, produce 5 chs in this addr-1 (p=01) + 430000,,0 ; produce p=35 + 520000,,0 ; p=26 + 610000,,0 ; p=17 + 700000,,0 ; p=10 (4 chs in wd) + + +DEFINE MADBP7 BP,CNT +MULI BP,5 +ADD BP+1,UADBP7(BP) +ADD BP+1,CNT +MOVE BP,BP+1 +IDIVI BP,5 +SUB BP,UHADB7(BP+1) +TERMIN + + ; Subtracted from 0,,addr to give appropriate BP pointing at + ; indexed char (ILDB to get it). +UHADB7: -010700,,1 + -350700,,0 + -260700,,0 + -170700,,0 + -100700,,0 + -010700,,0 ; 5th char, may want to index table by UHADB7+1(A) + ; so as to get pointer for LDB, not ILDB. + +; PTRDIF AC,[bp] Pointer difference. Takes two byte ptrs, +; one in c(E) and the other from AC, and returns in AC the char position +; difference (E bp)-(AC bp). Assumes 7-bit bytes. Can return positive +; or negative values. + +UUODEF PTRDIF:,U7PTDF +U7PTDF: MOVE U1,@U40 ; Get c(E), bp to subtract from. + LDB U4,UACFLD ; Get AC +IFSVU2, PUSH P,U2 + MOVE U2,(U4) ; Get c(AC), bp to subtract. + HRRI U1,@U1 ; Put actual addresses in RH, doing + HRRI U2,@U2 ; necessary indexing/indirection! + PUSHJ P,UPDIF7 ; mung them. + MOVEM U2,(U4) ; store result back in ac +IFSVU2, POP P,U2 + UUOXRT + + ; I don't think anything uses this table any more. + ; It gives # chars in a word, indexed by lower 3 bits of P + ; in a 7-bit byte ptr. +U7BPTB: 4 ;10 + 5 ;01 + 0 ? 0 + 0 ;44 + 1 ;35 + 2 ;26 + 3 ;17 + + +DEFINE BP7DIF AC,BP1,BP2 +MOVE AC,BP2 +MULI AC,5 +ADD AC+1,UADBP7(AC) +PUSH P,AC+1 +MOVE AC,BP1 +MULI AC,5 +ADD AC+1,UADBP7(AC) +SUBM AC+1,(P) +POP P,AC +TERMIN + + ; U1-U2 => U2, clobbering U1 and U3. +UPDIF7: MULI U2,5 + TLNE U3,777774 ; if LH originally zero, + ADD U3,UADBP7(U2) ; needn't add anything. + MULI U1,5 + TLNE U2,777774 + ADD U2,UADBP7(U1) + SUB U2,U3 + POPJ P, + + 133500,,0 ; to handle -5 produced by 440700 + repeat 4,0 +UADBP7: -54300,,5 + -104300,,4 + -134300,,3 + -164300,,2 + -214300,,1 + +; IBPN, ADJBP - Software simulation of ADJBP instruction, which is just +; IBP with non-zero AC. +; Following description taken from DEC hardware manual. Integer +; divisions, of course. +; Let A = rem((36-P)/S) +; If S > 36-A set no divide & exit +; If S = 0 set (E) -> (AC) +; If 0 < S <= 36-A: NOTE: Dumb DEC doc claims < instead of <= !!! +; L = (36-P)/S = # bytes to left of P +; B = L + P/S = # bytes to left + # bytes to right = # bytes/word +; Find Q and R, Q*B + R = (AC) + L +; where 1 <= R <= B ; that is, not neg or zero! +; Then: +; Y + Q -> new Y ; must wraparound correctly. +; 36 - R*S - A -> new P +; Put new BP in AC. Only P and Y fields changed, not S, I, X. + +IFN CPU%KL, EQUALS IBPN,ADJBP +IFE CPU%KL,[ ; If assembling specifically for KL, can skip all this. + +UUODEF IBPN:,UIBP ; Define IBPN +IFE CPU%X, EQUALS ADJBP,IBPN ; Redefine ADJBP too if no chance of conflict. + ; (i.e. we are assembling specifically for + ; a non-KL processor) +UIBP: + MOVE U3,@U40 ; Get BP in U3 + + ; First get S + LDB U1,[300600,,U3] ; Get S + JUMPE U1,[LDB U1,UACFLD ; If S = 0 just set (AC) to (E). + MOVEM U3,(U1) + UUOXRT ] + CAILE U1,36. + JRST UIBP9 ; In theory should set "no divide" +IFSVU2, PUSH P,U2 + PUSH P,U3 ; Save BP (a little faster access) + + ; Now get A and test. + LDB U3,[360600,,U3] ; Get P + MOVE U2,U3 ; Save copy + SUBI U3,36. ; Get -(36-P) + IDIVI U3,(U1) ; Get -( Alignment = rem (36-P)/s ) + CAILE U1,36.(U4) ; Compare S <= 36 - A + JRST UIBP8 ; Ugh, err return. + + ; Get L and B + PUSH P,U4 ; Save - rem = A = # unbyted bits to left of P + MOVM U4,U3 ; Save quotient = L = # bytes to left of P + IDIVI U2,(U1) ; Now get P/S + ADDI U2,(U4) ; L + P/S = B bytes per wd. + + LDB U3,UACFLD ; Find AC to use + MOVE U3,(U3) ; Get # bytes to adjust by. Don't optimize if 0 + ; because want canonicalization effect. + ADDI U3,(U4) ; Get (AC) + L + IDIVI U3,(U2) ; Find (AC + L)/B = Q and R + JUMPLE U4,[ADDI U4,(U2) ; If R <= 0 then adjust to 0 < R. + SOJA U3,.+1] ; which means adjusting Q also. + + IMULI U4,(U1) ; Get R*S + POP P,U1 ; Restore -A + SUBI U1,-36.(U4) ; Now have new P = (36 - R*S - A) + + POP P,U2 ; Get byte pointer again + DPB U1,[360600,,U2] ; Deposit new P + ADDI U3,(U2) ; Find new Y = Y + Q + HRRI U2,(U3) ; Set this way to wrap properly. + LDB U4,UACFLD +UIBP5: MOVEM U2,(U4) ; Finally store new pointer! +IFSVU2, POP P,U2 + UUOXRT +UIBP8: +IFSVU2, POP P,U2 +UIBP9: ; In theory should set Trap 1, Ovfl, No Div. + UUOXRT + +] ; IFE CPU%KL + +IFN 0,[ +; Temp routine to test IBP to make sure it works +TSTIBP: PUSHAE P,[A,B,C,D] + MOVSI D,-TSTTLN +TSTI2: MOVN C,TSTLIM ; # times to hack a BP +TSTI3: MOVE A,C + MOVE B,C + IBP A,TSTTBL(D) + IBPN B,TSTTBL(D) + CAME A,B + JRST [ FWRITE TYOC,[[Failed: ],H,TSTTBL(D),[for increment ],N9,C,[ IBP=],H,A,[ IBPN=],H,B,[ +]] + JRST .+1] + CAMGE C,TSTLIM + AOJA C,TSTI3 + AOBJN C,TSTI3 + FWRITE TYOC,[N9,TSTLIM,[ tests of ],H,[TSTTBL(D)],[ completed. +]] + AOBJN D,TSTI2 + FWRITE TYOC,[[Done! +]] + POPAE P,[D,C,B,A] + POPJ P, + +TSTLIM: 50000 +TSTTBL: 440700,,1234 + 120333,,54321 + 444400,,0 + 071000,,100 + 010203,,040506 + 430700,,0 + 111100,,0 +TSTTLN==.-TSTTBL + BLOCK 20 ; for more at runtime +] +;} + +SUBTTL ECALL macro and supporting UCALL UUO; .CALL error dispatch/hanging + + ; This is a crock that should be done away with someday soon + ; by a macro/routine stuck after a failing .CALL. +IFN USCALL,[ +UUODEF .ECALL:,UCALL ;performs special .call error hacking + +DEFINE ECALL LOC,LIST + .ECALL [LOC + IRP ITEM,,[LIST] +IRP ERRCOD,VECTOR,[ITEM] +IFSN ERRCOD,*, ERRCOD,,VECTOR +.ELSE [IRP EC,VC,[VECTOR] + EC,,VC(400000) ? .ISTOP ? TERMIN ] +.ISTOP ? TERMIN +TERMIN + 0] +TERMIN + +BVAR +UCMAXR: 10 ;holds max. no. of times to re-try call (for '*' spec) +UCSLEP: 30.*30. ;holds time to sleep between re-tries (for '*' spec) +UCECOD: 0 ;holds error code from ucall +UCECNT: 0 ;holds a retry count for whatever wants to use it. ecall clears +EVAR ;whenever it wins. + +UCALL: SETOM UCLFLG' ;clear flag to indicate from outside +UCALL1: MOVE U1,@U40 ;get ptr to call + .CALL @U1 ;execute the call + CAIA ;aha, failed...go do our stuff + JRST UCALWN ;won, return straightaway + + HRRZ U2,U40 ;get ptr-1 to errlist + AOJ U2, + .SUSET [.RBCHN,,U1] ;get chan # + MOVE U3,[.STATUS U3] ;set up instr + DPB U1,[$ACFLD,,U3] ;put in chan # + XCT U3 ;and get status word into u3 + LDB U1,[$ERRCD,,U3] ;and isolate error code. + MOVEM U1,UCECOD ;store code + +UCALL2: MOVE U1,(U2) ;get errlist entry + JUMPE U1,UCALSE + HLRZ U3,U1 ;get lh into u3 + ANDI U3,777 ;take 3.9-3.1 as error field + CAME U3,UCECOD ;matches .call error? + AOJA U2,UCALL2 ;no match, keep searching errlist + JUMPL U1,UCALL3 ;ah, match! if 4.9 bit set, use repeat hackery +UCALL7: HRRZM U1,UUORPC + UUOXRT ;else just go to specified neutral place. +UCALL3: AOSE UCLFLG ;set flag and skip if wasn't set already + JRST UCALL4 ;if it was, just repeat + MOVE U3,UCMAXR ;first time...get repeat count + MOVEM U3,UCECNT ;store in countdown reg +UCALL4: SOSGE UCECNT + JRST UCALL7 ;counted out. go to addr specified. + MOVE U3,UCSLEP ;get sleep time + .SLEEP U3, + JRST UCALL1 ;now try again. + +UCALWN: SETZM UCECOD ;clear error code + AOS UUORPC ;to win, skip +UCALSE: SETZM UCECNT ;zero loss count + UUOXRT ;return + +] ;end of ifn uscall + +SUBTTL Old Output UUOs (obsolete) + +IFN $$OUUO\USTRGS\ULISTS,[ + ; USTRGS needs OUT package for init & BCONC. + ; ULISTS needs OUT package for %LTSAO in MAKELN. +IFN OS%ITS,.INSRT KSC;OUT > +IFN OS%TNX,.INSRT OUT.MID +] ;IFN $$OUUO\USTRGS\ULISTS + +IFN $$OUUO\USTRGS,[ + + ;;; UIOINIT - old output initialization. +DEFINE UIOINIT ; Make them work. +IFE $$UCAL,PUSH P,UUORPC ; Get return PC on stack. +LDB OC,UACFLD +TERMIN + +; OUTOPN CH,[,,[]] +; "Opens" a UUO channel for output. Note +; is in AC field!! This allows address to be indexed etc. + +;Formats: +; OUTOPN CH, ;same as type $UCIOT. +; OUTOPN CH,[$UCIOT,,0] ;uses .IOT and SIOT +; OUTOPN CH,[$UCIOT,,[JFN]] ; uses BOUT, SOUT (TNX only) +; OUTOPN CH,[$UCBPT,,[byte ptr]] ;uses idpb starting at ptr +; OUTOPN CH,[$UCXCT,,[instr]] ;XCT's the instr (arg will lie in U1) +; OUTOPN CH,[$UCUAR,,] ;uses byte ptr into specified area +; OUTOPN CH,[SETZ $UCUAR,,] ;as above, but resets area +; OUTOPN CH,[$UCTRN,,[channel #]] ;Translates into another UUO channel. + + ; UUO Channel types. Bits start in AC field, so as not to infringe + ; on indexing/indirect bits! +.M"$UCUAR==<.M"UC$UAR==:0> ; UAR (UUO area) chan type 0 for easy check. +.M"$UCXCT==UC$XCT_5 ; XCT +.M"$UCBPT==UC$BPT_5 ; Byte PTr +.M"$UCIOT==UC$IOT_5 ; .IOT/SIOT (or BOUT/SOUT) +.M"$UCBUF==UC$BUF_5 ; Buffered UC$IOT +.M"$UCTRN==UC$TRN_5 ; Translate into another chan. +.M"$UCNUL==UC$NUL_5 ; Null output sink +.M"$UCSAO==UC$SAO_5 ; SAO - Like UAR for LSE's String-Area. + + UUODEF OUTOPN:,UCHOPN +UCHOPN: UIOINIT ; Get channel # (AC field) + HRRZ U3,U40 ; Get E + CAIN U3, ; In case of OUTOPN CH,0 + TLOA U3,($UCIOT,,) ; provide default. + HLL U3,(U3) ; Get LH stuff from c(E) + LDB U1,[$ACFLD,,U3] ; Get channel type (AC field of c(E)) + ; OC - Channel # + ; U1 - channel type + ; U3 - ,[ ? ? ... ] + PJRST OUT"UOPEN3 + + +; OUTPTV CH,[] For use with UUO channels. +; Returns to c(E) the cnt of chars outputted on channel since +; opened. For channels opened into an area, this is +; the # of chars between start of area and current Write BP. + + UUODEF OUTPTV:,UCHPTV +UCHPTV: LDB OC,UACFLD ; Get channel #. + CALL OUT"UPTV + MOVEM U1,@U40 ; Store result + UUOXRT + +; OLD OUTPUT UUOS. All should avoid clobbering U4 before +; reading args, since FWRITE macro may be using it to set +; up UUO calls. + +UUODEF OUTI:,U7I ; Immediate - E is char +UUODEF OUTZ:,U7Z ; E->ASCIZ string +UUODEF OUTC:,U7C ; c(E) = <# chars>,, +UUODEF OUTPZ:,U7PZ ; c(E) = BP to ASCIZ string +UUODEF OUTPC:,UTPC ; c(E) = <# chars>,,[BP] +UUODEF OUTS:,U7S ; c(E) = <# chars> ? +UUODEF OUT6F:,U6F ; outputs c(E) as 6bit, ignores trailing blanks. + EQUALS .M"OU6F,OUT6F +UUODEF OUT6W:,U6W ; outputs c(E) as 6bit, all 6 chars. + EQUALS .M"OU6W,OUT6W +UUODEF OUT6Q:,U6Q ; outputs c(E) as 6bit, quotes punct chars with ^Q, drops tr blnk + EQUALS .M"OU6Q,OUT6Q +UUODEF OUT10.:,UN10 ; outputs c(E) as decimal value, with point. + EQUALS .M"OUN10,OUT10. +UUODEF OUT10:,UN9 ; like OUN10 but no decimal point. + EQUALS .M"OUN9,OUT10 +UUODEF OUT8:,UN8 ; outputs c(E) as octal value. + EQUALS .M"OUN8,OUT8 +UUODEF OUNRH:,UNRH ; outputs RH of c(E) as 6 octal digits. +UUODFA CRLF:,UCRLF ; outputs CRLF, ignores E. + +U7I: UIOINIT ; Entry pt for OUTI UUO + HRRZ U1,U40 + PJRST OUT"OXC +UCRLF: UIOINIT ; Entry pt for CRLF UUO + PJRST OUT"OXEOL +U7Z: UIOINIT ; Entry pt for OUTZ UUO + MOVE U3,U40 ; get addr of string + PJRST OUT"OXZA +U7PZ: UIOINIT ; Entry pt for OUTPZ UUO + MOVE U3,@U40 + PJRST OUT"OXZ +UTPC: UIOINIT ; Entry pt for OUTPC UUO + MOVE U3,@U40 ; Get ,,[bp] + PJRST OUT"OXPC +U7C: UIOINIT ; Entry pt for OUTC UUO + MOVE U3,@U40 + PJRST OUT"OXTC +U7S: UIOINIT ; Entry pt for OUTS UUO + MOVE U3,U40 ; Get addr to string descriptor + PJRST OUT"OXS + +U6W: UIOINIT ; Entry pt for OUT6W UUO + MOVE U3,@U40 ; Get 6bit wd + PJRST OUT"OX6W +U6F: UIOINIT ; Entry pt for OUT6F UUO + SKIPN U3,@U40 + RET + PJRST OUT"OX6F +U6Q: UIOINIT + MOVE U3,@U40 + PJRST OUT"OX6Q +UN10: UIOINIT ; Entry pt for OUT10. UUO + MOVE U3,@U40 + PJRST OUT"OXN10. + +UN8: SKIPA U1,[8.] ; Entry pt for OUT8 UUO +UN9: MOVEI U1,10. ; Entry pt for OUT10 UUO + UIOINIT + MOVE U3,@U40 + PJRST OUT"OXNTYP +UNRH: UIOINIT ; Entry pt for OUNRH UUO + MOVE U3,@U40 ; Get word + PJRST OUT"OXRH + +IFN $$OFLT,[ + UUODEF OUNFLT:,UNFL10 ; Outputs c(E) as floating decimal + EQUALS .M"OUNFL,OUNFLT +UNFL10: UIOINIT + MOVE U3,@U40 + PJRST OUT"OXNFL + +] ;IFN $$OFLT +IFN UAREAS,[ + UUODEF OUTAR:,U7XA + EQUALS .M"OUTA,OUTAR +; OUTAR CH, Outputs char-mode area on CH. + +U7XA: UIOINIT ; Entry pt for OUTAR UUO + MOVE U1,U40 ; Get ARPT to area. + PJRST OUT"OXAR +] ;IFN UAREAS + +IFN ULISTS,[ +; OUTLS CH,[slp] Outputs string that SLP points to, on channel CH. + + UUODEF OUTLS:,U7LS +U7LS: UIOINIT + MOVE U3,@U40 ; Get SLP. + PJRST OUT"OXLS + +] ;IFN ULISTS + +] ;IFN $$OUUO\USTRGS + +SUBTTL UUO AREAS - Tables & Initialization +IFN UAREAS,[ + ; ARBLK Definitions - words used in an ARBLK. + OFFSET -. ; Define following symbols as if starting at 0. +$AROPN:: ; Non-z when area is active and info valid. 0 when "closed". +$ARLOC:: 0 ; Location of area = addr of first word in area. This must be + ; the FIRST word in the ARBLK, as it is the only item + ; intended to be referenced without using the $ARxxx symbol + ; and is very common. +$ARNOD:: 0 ; PAGSER "node" addr, for use in calls to PAGSER rtns. + ; If the ARBLK is a dynamically allocated one, the + ; LH of this word contains node addr for ARBLK itself. +$ARLEN:: 0 ; Length of area in words. +$ARTOP:: 0 ; Last addr + 1 of area (Loc+Len) for easier reference. +$ARWPT:: 0 ; Write pointer into area. (BP in char mode) +$ARRPT:: 0 ; Read pointer into area. +$ARCHL:: 0 ; - in area (Char mode only). +$ARTYP:: 0 ; Type bits, in LH only. (See below for description) +$ARIMD:: 0 ; Increment Modulus. Additional allocations are modulo this. + +$ADFIM==1000 ; Default $ARIMD; allocate in 1000-wd chunks. +$ARSIZ==.-$ARLOC ; Minimum # words in an ARBLK. + OFFSET 0 ;back to normal. + + ; $ARTYP bits. +%ART==-1,,525240 ; For bit-typeout mode. +%ARTCH==100 ; If 1, character mode. If 0, word mode. +%ARTZM==200 ; Indicates all core allocated should be cleared. +%ARTSS==400 ; Indicates this area is String-Space. +%ARTLH==1000 ; Indicates this area is a LSE Header area. +%ARTLA==2000 ; Indicates this area is a LA (List-Area) +%ARTDY==4000 ; Indicates this ARBLK was dynamically allocated. + +; UARINIT [-<# pgs>,,] Defines space available for area hackery, +; and initializes tables thusly. MUST be called before any +; other area-manipulating UUO's. + +UUODFE UARINIT,UXINIT +UXINIT: MOVE U1,@U40 ; Get arg for CORINI. + PUSHJ P,CORINI ; Initialize core blocks. + SETZM UXPDLP ; Reset uuo-area PDL pointer. + UUOXRT ; Done. + + +SUBTTL UAROPN - Open an area + +; UAROPN AC,[,, ? [,,]] +; Creates an area, using ARPT-indicated +; ARBLK for storage of area variables. contains the +; minimum initial allocation desired, the desired increment +; modulus when expanding ($ADFIM used if =0), and the +; are exactly those defined for $ARTYP. If the given ARPT is +; zero, or E of the call itself is zero, then a unique ARBLK +; will be created dynamically. If AC is specified, the ARPT +; will be returned in it; it is an error to request ARBLK creation +; and not specify an AC! +; --> NOTE: ARPT is accessed indirectly, and the type bits do not +; infringe on the I or @ fields, so all addressing modes work. + +UUODEF UAROPN,UXOPN +UXOPN: HRRZ U3,U40 ;get E +IFSVU2, PUSH P,U2 + CAIN U3,0 + MOVEI U3,[0,,0 ? [$ADFIM]] ;set up default if nothing specified. + MOVEI U4,@(U3) ;get ARPT, allowing indirection & indexing. + JUMPN U4,UXOPN5 ;does caller want an ARBLK created? Jump if not (whew!) + + ; Wants an ARBLK created. Cons one up. + LDB U2,UACFLD ; First check to be sure that + CAIN U2,0 ; an AC field exists! + JSR AUTPSY ; Requested ARBLK creation but no way to return the ARPT! + MOVEI U1,$ARSIZ ; Get block big enuf for ARBLK. + PUSHJ P,PSRGET ; Get from PAGSER! + HLRZ U4,U2 ; Store address of block as new ARPT, + SETZM $ARLOC(U4) ; and indicate free. + HLL U4,(U3) ; Get desired type bits, and set bit + TLO U4,%ARTDY ; indicating ARBLK was dynamically allocated. + HRLZM U2,$ARNOD(U4) ; And save PAGSER node addr in LH + JRST UXOPN6 ; since user isn't ever going to see it! + +UXOPN5: SKIPE $ARLOC(U4) ; Is area in use? + PUSHJ P,UXCLSA ; Foo, close it and free up the core. + HLL U4,(U3) ; Get desired type bits. +UXOPN6: MOVE U1,@1(U3) ; Get desired increment modulus & allocation. + HLRZM U1,$ARIMD(U4) ; Store modulus for further requests. + HRRZS U1 ; And isolate desired initial allocation + CAIG U1,1 + MOVEI U1,2 ; Must be at least 2 words in an area!! + PUSHJ P,PSRGET ; Get block of that much. + ; Returns U1 - <# wds>, U2 - ,, + HRRM U2,$ARNOD(U4) ; Store PAGSER node addr. + HLLZM U4,$ARTYP(U4) ; Store type bits. + HLRZM U2,$ARLOC(U4) ; Store starting addr (also declares open) + MOVEM U1,$ARLEN(U4) ; Store length + ADD U1,$ARLOC(U4) + MOVEM U1,$ARTOP(U4) ; Store lastaddr+1 + CALL UXRST ; Reset the area. +IFN ULISTS,[ + TLNN U4,%ARTLA ; Is area a LA area? + JRST UXOPN8 ; No, skip. + ; Opening a LA area. Initialize its addressing table in HDR. + MOVE U1,L ; Get current HDR loc. + HRLI U1,UHDRDF ; BLT AC - ,, + BLT U1,(L)$LHLTB-1 ; Zap it. + MOVE U2,L ; Get addr of table again. + HRLI U2,-$LHLTB ; AOBJN thru table now. + MOVE U1,$LLLOC(L) ; Increment is loc of LA, since init RH is 0 + ADDM U1,(U2) + AOBJN U2,.-1 ; That's it. +UXOPN8:] + + LDB U3,UACFLD ; Now see if must return the ARPT. + CAIE U3, ; Return immediately if not. + HRRZM U4,(U3) ; Else pass it back. +IFSVU2, POP P,U2 + UUOXRT ; All's done now. + + ; Internal routine to reset area. +UXRST: MOVE U3,$ARLOC(U4) ; Get start addr of area + TLNN U4,%ARTCH ; Char-type area? + JRST UXRST2 + MOVN U1,$ARLEN(U4) ; Find -size available. + IMULI U1,5. ; -<# chars worth of room> + MOVEM U1,$ARCHL(U4) ; Store as countdown # + HRLI U3,440700 ; Form new Write BP. +UXRST2: MOVEM U3,$ARWPT(U4) ; Store Write ptr to area + MOVEM U3,$ARRPT(U4) ; Also set read ptr. + TLNN U4,%ARTZM ; Should we re-zero? + RET ; No, now done. + HRL U3,U3 ; Start addr still in U3... + ADDI U3,1 ; Get start,,start+1 + SETZM -1(U3) ; Zap first loc + MOVE U1,$ARTOP(U4) ; Get lastaddr+1 + BLT U3,-1(U1) ; Now zap whole area. + RET + +SUBTTL UARCLS - Close an area + +; UARCLS Close area, free up its core. + +UUODFE UARCLS,UXCLS +UXCLS: MOVE U4,U40 ; Get ARPT for area desired to close + SKIPE $ARLOC(U4) ; Is it already closed? + PUSHJ P,UXCLSA ; No...well, go close it and free core. + MOVE U1,$ARTYP(U4) ; Get type bits + TLNN U1,%ARTDY ; Was it a dynamic ARBLK? + UUOXRT ; No, all's done. + HLRZ U1,$ARNOD(U4) ; Uh-oh, must free ARBLK also! Get node addr. + PUSHJ P,PSRREL ; There it goes... + UUOXRT + + ; Auxiliary rtn for UAROPN & UARCLS, closes an area & frees its core. + ; ( Takes ARPT in U4) +UXCLSA: PUSH P,U1 +IFN ULISTS,[ + MOVE U1,$ARTYP(U4) + TLNE U1,%ARTLH ; List Header? + JRST [ PUSHAE P,[U4,L] + MOVE L,$ARLOC(U4) + MOVEI U4,$LSAR(L) ; Close SA area. + PUSHJ P,UXCLSA ; Recursively! + MOVEI U4,$LLAR(L) ; And LA area. + PUSHJ P,UXCLSA + POPAE P,[L,U4] + JRST .+1] +] + MOVE U1,$ARNOD(U4) ; Get node addr of area + PUSHJ P,PSRREL ; Release it! + SETZM $ARLOC(U4) ; Indicate area closed. + POP P,U1 + POPJ P, + +SUBTTL UARTYP - Change area type + +; This is a gross crock which should probably be replaced someday. + +; UARTYP [type,,] Changes area to specified type, and +; tries to be clever about converting from wds to chars... +; (Flushes ^C's, ^L's and ^@'s from last word in that case) +; Only bits specified in UXFGTB can be changed with this UUO. + +UUODFE UARTYP,UXTYP +UXTYP: MOVE U3,U40 ;get E-> type,, +IFSVU2, PUSH P,U2 + MOVEI U4,@(U3) ;get ARPT with indirection/indexing enabled. + HLLZ U3,(U3) ;get new bits in U3. + HLL U4,$ARTYP(U4) ;get old type bits in U4. + MOVSI U2,-NARFGS +UXTYP0: HLLZ U1,UXFGTB(U2) ;get a changeable type bit. + TDNN U3,U1 + JRST [ TDNN U4,U1 + JRST UXTYP2 ;both 0 + JRST UXTYP1] ; old 0, new 1. + TDNE U4,U1 + JRST UXTYP2 ;both 1 +UXTYP1: TDC U4,U1 ;change this bit. + MOVE U1,UXFGTB(U2) + PUSHAE P,[U2,U3] + PUSHJ P,(U1) ;go hack it. + POPAE P,[U3,U2] +UXTYP2: AOBJN U2,UXTYP0 + HLLM U4,$ARTYP(U4) ;store new type bits. +IFSVU2, POP P,U2 + UUOXRT ;all bits munged. + + +UXFGTB: %ARTCH,,UXTCH ;table of possible bits, with rtns to process. + %ARTZM,,UXTZM +NARFGS==.-UXFGTB + + ;changing %ARTCH (chars or wds) +UXTCH: TLNE U4,%ARTCH ;Wants to become words? + JRST UXTCH5 ;no, words->chars. ugh! + + ;Changing from chars to words. + MOVE U1,$ARWPT(U4) ;get current write ptr + LDB U3,[360600,,U1] ;isolate the P field of ptr + CAIE U3,44 ;is it pointing to beg of wd? + ADDI U1,1 ;no, use addr+1. + HRRZM U1,$ARWPT(U4) ;then store addr above last char. +UXTCH2: MOVE U1,$ARRPT(U4) + LDB U3,[360600,,U1] + CAIE U3,44 + ADDI U1,1 + HRRZM U1,$ARRPT(U4) + POPJ P, ;done with chars->wds + + ;Changing from words to chars. +UXTCH5: MOVEI U1,440700 ;read ptr is easy, + HRLM U1,$ARRPT(U4) ;just point to first char of word it points to. + HRRZ U1,$ARWPT(U4) ;get current write addr + CAMG U1,$ARLOC(U4) + JRST UXTCH8 ;if points to beg of area, this is all. + MOVEI U2,5 ;cnt of chars to search backwards thru. + HRLI U1,350700 ;form ptr to first after last possible char position + + ;now loop til find true end of area (disregard nulls, ^c's, ^l's) +UXTCH6: MDBPT U1, ;decrement ptr + LDB U3,U1 ;get a char + CAIE U3,0 ;^@? + CAIN U3,^C ;or ^C? + SKIPA ;go to sojg if so + CAIN U3,^L ;or ^L? + SOJG U2,UXTCH6 ;ignore char, loop unless counted out. + CAIG U2,0 +UXTCH8: HRLI U1,440700 ;if word was all padding, point to first char. + MOVEM U1,$ARWPT(U4) ;now store correct write ptr + HRRZ U2,$ARTOP(U4) ;get "ptr" to last char+1 + PUSHJ P,UPDIF7 ;find difference U1-U2 + MOVEM U2,$ARCHL(U4) ;and store that as -<# chars left>. + POPJ P, + + ; %ARTZM bit changed. (To clear, or not to clear..) +UXTZM: TLNN U4,%ARTZM ;changing to zeroifying? + POPJ P, ;no, need do nothing. + MOVE U1,$ARWPT(U4) ;get write ptr + TLNN U4,%ARTCH ;character mode? + JRST UXTZM5 ;no, words. clear out remaining words in area. + LDB U2,[360300,,U1] ;Char mode. Get low 3 bits of P in BP + CAIN U2,4 + JRST UXTZM4 ; P was 44, zap nothing, no increment. + CAIN U2,1 + AOJA U1,UXTZM4 ; P was 01, zap nothing (avoid mem ref!!!)but increment. + MOVE U3,UBPMSK(U2) ;get mask + ANDM U3,(U1) ;clobber nasty little bits we don't want. + ADDI U1,1 +UXTZM4: HRRZS U1 +UXTZM5: MOVE U2,$ARTOP(U4) ;get end+1 addr of area. + CAML U1,U2 ;check, + POPJ P, ;nothing to zero if write ptr points to end. + SETZM (U1) ;clear word at ptr + CAIL U1,-1(U2) ;only a single word to clear? + POPJ P, ;yes. Must check for this because BLT always xfers a wd. + HRLS U1 + ADDI U1,1 ;set up ptr,,ptr+1 + BLT U1,-1(U2) ;and clear rest of area. + POPJ P, + + ; Indexed by low 3 bits of P field, gives mask for chars so far in wd. +UBPMSK: -1,,777400 ;P = 10, 4 chars + -1,,777776 ;P = 01, 5 chars + 0 + 0 + 0 ;P = 44, 0 chars + 774000,,0 ;P = 35, 1 + 777760,,0 ;P = 26, 2 + -1,,077777 ;P = 17, 3 + +SUBTTL UAREXP - Expand area, OUTAR - output area + +; UAREXP AC, Expands indicated area according to +; contents of AC - if c(AC) positive, adds c(AC) words; if +; negative, deletes -c(AC) words. Both operations apply to high end. +; Unlike "auto-expand" in that the area is expanded only by the +; specified amount; the increment modulus is ignored. + +UUODEF UAREXP,UXEXP +UXEXP: MOVE U4,U40 ; Get ARPT for area + LDB U3,UACFLD ; Get ac + SKIPG U1,(U3) ; Get c(AC) and skip if positive (normal) + JRST UXEXP3 ; Ugh, must delete. +IFSVU2, PUSH P,U2 + CALL UABMP ; Expand the area exactly like so. +IFSVU2, POP P,U2 + UUOXRT + + ; Must flush some core from high end of area. Cannot reduce + ; an area to less than 1 word! +UXEXP3: UUOXRT ; Unimplemented at moment! + + +SUBTTL UARPUSH, UARPOP, UARFLS - Area PDL + +; These UUOs implement a PDL mechanism for areas. UXPDLP +; points to a list of blocks, each of which is $ARSIZ+1 words long. +; The first word is a pointer to the next block and the remaining +; words store the ARBLK for some area. When UXPDLP is 0, the +; PDL is empty; else it points to the first ARBLK on the stack. + +LVAR UXPDLP: 0 ; UUO-Area PDL pointer + +; UARPUSH - Push the given ARBLK words on the stack, and "close" +; the actual ARBLK it was copied from. + + UUODFE UARPUSH,UXPUSH +UXPUSH: MOVE U4,U40 ; Get ARPT argument +IFSVU2, PUSH P,U2 + MOVEI U1,$ARSIZ+1 ; Get a block of this many words + PUSHJ P,PSRGET ; From friendly neighborhood allocator + MOVS U2,U2 ; Get ,, + MOVE U1,UXPDLP ; Get current PDL ptr + MOVEM U1,(U2) ; Store it in new entry + MOVEM U2,UXPDLP ; And store new PDL ptr - entry on stack now! + HRLZ U1,U4 ; Source for BLT is ARPT given + HRRI U1,1(U2) ; Destination is rest of new entry block. + BLT U1,$ARSIZ+1-1(U2) ; Copy! + SETZM $ARLOC(U4) ; Now render original ARBLK inactive. +IFSVU2, POP P,U2 + UUOXRT + +; UARPOP - Pop UUO area from stack into specified ARBLK. +; If any active area existed in the ARBLK, it is closed!! + + UUODFE UARPOP,UXPOP +UXPOP: SKIPN U1,UXPDLP ; Anything to pop? + JSR AUTPSY ; Nope, error! + MOVE U4,U40 ; Get ARPT argument + SKIPE $ARLOC(U4) ; Area already open in this ARBLK? + PUSHJ P,UXCLSA ; Close it! + HRLZI U3,1(U1) ; Get source for BLT - addr of PDL ARBLK + HRR U3,U4 ; and destination - new ARBLK + BLT U3,$ARSIZ-1(U4) ; Xfer the ARBLK info back! + MOVE U3,(U1) ; Now take off stack. Get ptr to previous, + MOVEM U3,UXPDLP ; store as new PDL ptr to effect pop, + HLRZ U1,U1 ; get node addr for entry, + PUSHJ P,PSRREL ; and now release the entry's core! +IFN ULISTS,[ + HLL U4,$ARTYP(U4) ; Get type bits for area... + TLNN U4,%ARTLH ; Was it a LSE HDR area? + UUOXRT + MOVE U3,$ARLOC(U4) ; Yes, must reset $LHARP var properly. + HRRZM U4,$LHARP(U3) ; Set it. +] + UUOXRT + +; UARFLS - Flushes the UUO area stack. Closes all areas found on it! + + UUODFN UARFLS,UXFLS +UXFLS: SKIPN U3,UXPDLP ; Check PDL pointer... + UUOXRT ; Nothing to do if nothing pushed! +UXFLS1: MOVEI U4,1(U3) ; Set up ARPT to first thing on stack + SKIPE $ARLOC(U4) ; And, unless already closed, + PUSHJ P,UXCLSA ; Close it! + HLRZ U1,U3 ; Now get node addr for doomed entry, + MOVE U3,(U3) ; Get ptr to next, + PUSHJ P,PSRREL ; and zap entry as foretold... + JUMPN U3,UXFLS1 ; Loop til we've killed last entry, + SETZM UXPDLP ; and clear PDL ptr to start anew. + UUOXRT + +SUBTTL Area shift routine - UABUMP + +; UABUMP - very important routine that does the actual +; expanding of areas which need more room. +; U1 - ARPT for area that needs more room. +; ARUNIT - # words it needs. + +LVAR ARUNIT: 0 ; Arg for UABUMP, contains # words desired to add. + +UABUMP: SKIPGE ARUNIT + JSR AUTPSY ; Error if negative. + PUSHAE P,[U1,U2,U3,U4] + MOVE U4,U1 ; Put ARPT here. + SKIPG U3,$ARIMD(U4) ;get modulus to increment in; + MOVEI U3,$ADFIM ;if none, use default. + SKIPG U1,ARUNIT + MOVEI U1,1 ; Backup to catch zero. + ADDI U1,-1(U3) + IDIVI U1,(U3) + IMULI U1,(U3) ; Make increment MOD <$ARimd> + CALL UABMP0 ; Go do everything. + POPAE P,[U4,U3,U2,U1] + RET + +; UABMP - Basic expand-area routine, no modulus forcing. +; U1 - <# wds to add> ; Must be positive. +; U4 - +; Clobbers U1,U2,U3,U4 !!! + +UABMP: CAIG U1, ; Make sure request is positive. + JSR AUTPSY +UABMP0: HLL U4,$ARTYP(U4) ; Get area type bits for later use. + MOVE U2,$ARNOD(U4) ; PAGSER node addr of area that needs it + PUSHJ P,PSREXP ; Expand the area! + HRRM U2,$ARNOD(U4) ; Save new node addr + HLRZ U2,U2 ; Get blk addr by itself. + CAMN U2,$ARLOC(U4) ; Is area in same place? + JRST UABMP5 ; Yes, needn't worry about anything bumped. + + ; Fooey, area was moved, must figure out difference in addresses, + ; and adjust everything necessary. + PUSHAE P,[U1,U2] ; Save returned size and ptr + MOVE U1,$ARLOC(U4) ; Get old start addr in U1 + MOVEM U2,$ARLOC(U4) ; and store new one. + SUB U2,U1 ; Get difference in locations, new-old + MOVEM U2,UBMPDF' ; Save it for UBMPP use. + ADDM U2,$ARRPT(U4) ; Update R/W pointers + ADDM U2,$ARWPT(U4) + MOVE U2,$ARLEN(U4) ; Now get original size, so as to get + ADD U2,U1 ; last+1 of orig area. U1, U2 now delimit it. + PUSHJ P,UBMPP ; And go bump special stuff if necessary. + POPAE P,[U2,U1] ; Restore size, addr + +UABMP5: ADD U2,U1 ; Find new lastaddr+1 + MOVEM U2,$ARTOP(U4) ; and store for easy ref. + EXCH U1,$ARLEN(U4) ; Store new size, and recover old len in U1 + TLNE U4,%ARTCH + JRST [ MOVE U3,U1 + SUB U3,$ARLEN(U4) ; Get -<# words added> + IMULI U3,5 ; Get -<# chars added> + ADDM U3,$ARCHL(U4) ; Add into count of chars left. + JRST .+1] + TLNN U4,%ARTZM ; Must new core be zeroed? + RET ; Nope, just return. + ADD U1,$ARLOC(U4) ; Get addr new core starts at (loc+old len) + ADDI U1,1 ; plus 1 + MOVE U2,$ARTOP(U4) ; Get lastaddr+1 of new core. + SETZM -1(U1) ; Clear first new word + CAML U1,U2 ;make sure there's a 2nd word. + RET ;no? well, it's possible. BLT would have zapped another. + HRLI U1,-1(U1) ;get ,, + BLT U1,-1(U2) ;clear new core. + RET + +; UBMPP - does special 'bumping' when area in U4 is moved. +;Takes in U1 the original addr, in U2 the original last+1 addr; these delimit the +;original area boundaries. Updates stuff in UBPSTB if addr listed falls within +;range defined by U1 and U2. +; Note possibility of lossage if one tries to check a ILDB/IDPB byte ptr of form +; 010700,,ADDR since while it really refers to something in ADDR+1, it will be +; seen here as belonging to ADDR, and if U1 or U2 contains ADDR+1 then the +; pointer will respectively not get updated, or clobbered by unnecessary +; 'updating'. Solution is to do a temporary IBP on such things if +; they are known to be ILDB/IDPB ptrs. Check for BP-ness is presence of bits in +; 7700,,0 (i.e., S) field. + +UBMPP: PUSH P,U4 ;save ARPT and flags. + MOVSI U4,-OUT"NUSPBP ;Check UCHSTB and any additional locs. +UBMPP1: MOVE U3,OUT"UCHSTB(U4) + TLNE U3,7700 ;use this as a BP check. If anything in S, then + IBP U3 ;it's a BP, and must be IBP'd! (see above comments) + HRRZS U3 ;want RH only + CAML U3,U1 ;not inside if addr less than start + CAML U3,U2 ;not inside if addr GE lastaddr+1. + JRST UBMPP2 ;not inside! + MOVE U3,UBMPDF ;Inside. Get am't to adjust by + ADDM U3,OUT"UCHSTB(U4) ;Do it. +UBMPP2: AOBJN U4,UBMPP1 + POP P,U4 ;restore ARPT and flags. + MOVE U2,UBMPDF +IFN ULISTS,[ + TLNN U4,%ARTLA ;is this area a LA? + JRST UABMP4 ;no... + MOVSI U3,-$LHLTB ;ach, must update LA addressing tables! Get count + HRR U3,L ;get start address of current HDR area where table is. + ADDM U2,(U3) + AOBJN U3,.-1 ;add the (in/de)crement to all table entries. +UABMP4:] +IFN USTRGS,[ + TLNE U4,%ARTSS ;is this area String-Space? + PUSHJ P,USTBMP ;ugh, go adjust all string pointers!! +] + POPJ P, + +] ;at long last, end of IFN UAREAS. + +SUBTTL Strings - USINIT, BCONC, ECONC +IFN USTRGS,[ +; Strings are represented by a 2 descriptor words in the following +;SAIL-type format: +; : ,,<# chars> +; (ILDB gets 1st char) + +; For constant strings, whose descriptors can be stored anywhere, +; should be 0. Variable string descriptors are stored in a table +;beginning at STRNGS and containing NSTRS string variables. +;The macro STRNAM creates an entry in this area at assemble +;time with the label , and will be some unique index +;when the string is not null. Initializing the string hackery with +;a STRINIT UUO has the side effect of setting all variable strings null. +;(NOTE: References to a variable string should be by address of its descriptors, i.e. +; its name, since it is possible for the byte pointer to change +; unexpectedly due to expansion or shifting of the core area containing +; the strings, as well as to GC'ing of the stringspace!!) +;BCONC is used to begin forming a string; output operations on +;channel STRC will then be accumulated into a string which is +;formally stored by ECONC. +; The string variable table must be declared, anytime after +; all STRNAM's have been processed, as +; STRNGS: SBLOCK +; +; NSTRS==<.-STRNGS>/2 + + + +BLKINI SBLOCK ; Initialize SBLOCK as a text-block macro. +DEFINE STRNAM NAME ; Define macro using BLKADD to add strings to string var table +BLKADD SBLOCK,[NAME: 0 ? 0] +TERMIN + +DEFINE STRBLK ; Define macro to be put at end of pgm (after all STRNAM's). +BVAR +STRNGS: SBLOCK + NSTRS==<.-STRNGS>/2 +EVAR +TERMIN + +IFNDEF STRC,STRC==0 ; Standard output channel for forming strings +NULSTR: 0 ? 0 ; Standard null string. +BVAR +STRNAM UCNCST ; String descriptor used during concatenation. +USTIDX: 0 ; AOS'd to produce gensym index for new string. +USTRAR: BLOCK $ARSIZ ; ARBLK descriptor for area holding strings. +EVAR + + ; Routine to initialize string hackery. +UUODFN STRINIT,USINIT +USINIT: +IFE $$UCAL,PUSH P,UUORPC ; Calling UUO's within UUO handler! + UARCLS USTRAR ; Close any previous string area. + UAROPN [%ARTSS+%ARTZM+%ARTCH,,USTRAR ; Open string area + [1000]] ; with 1000 wds initial allocation. + OUT(STRC,OPEN(UC$UAR,USTRAR)) ; Open standard string channel + SETZM USTIDX ; Clear gensym counter for string idx. + SETZM STRNGS ; Zero 1st wd of string var table, and + MOVE U1,[STRNGS,,STRNGS+1] ; propagate to + BLT U1,STRNGS+-1 ; nullify entire string var table. + MOVE U1,USTRAR+$ARWPT ; Get current BP to stringspace + MOVEM U1,UCNCST+1 ; and store to init conc string; also, + SETOM UCNCST ; make 1st desc. wd uneq to any other! + RET ; Return (note return addr always put on PDL) + + +; BCONC starts composing new string, beginning with given one +; (if E zero, null string used.) + +UUODFE BCONC,UBCONC +UBCONC: HRRZ U1,U40 ; Get addr of string to begin with + CAIN U1,0 ; If creating fresh string, + MOVEI U1,NULSTR ; Use null string as initial. + MOVE U4,(U1) ; Get 1st wd of string descriptor + CAMN U4,UCNCST ; Init string same as one last written on top? + UUOXRT ; Yes, nothing to do. + + ; Must copy initial string over again -- first set up new temp string + MOVE U3,USTRAR+$ARWPT ; Get current byte ptr to top + MOVEM U3,UCNCST+1 ; Store as beginning ptr + AOS U3,USTIDX ; Increment and get unique index # + HRLZM U3,UCNCST ; and store as 1st wd of descriptor, cnt=0 + + ; Now copy string over + MOVEI U4,(U4) ; Get char cnt only + JUMPE U4,UBCNC4 ; often is null... + MOVE U3,1(U1) ; Get BP + PUSH P,OC ; Note uses OUT package here! + MOVEI OC,STRC + CALL @OUT"USCOPT(OC) ; Copy string over at top. + POP P,OC +UBCNC4: UUOXRT + + +; ECONC makes describe the string conc'd thus far + +UUODFE ECONC,UECONC +UECONC: MOVE U1,USTRAR+$ARWPT ;get byte ptr to top +IFSVU2, PUSH P,U2 + MOVE U2,UCNCST+1 ;compare with ptr to beginning of string + MOVE U4,U2 ; save ptr for later. + PUSHJ P,UPDIF7 ;get # chars in string in U2 + HLL U2,UCNCST ; Form 1st wd of descriptor + MOVE U3,U40 ;get addr of string var to store in + MOVEM U2,(U3) ;store the 2 descriptor wds. + MOVEM U4,(U3)+1 +IFSVU2, POP P,U2 + UUOXRT + +; string garbage collector; determines if strings should +;actually be GC'd or not, and does dirty work if necessary. + +USTRGC: POPJ P, + PUSHAE P,[U1,U2,U3] + MOVSI U3,-NSTRS + SETZ U2, ;zero cumulative # of chars +USGC2: MOVE U1,STRNGS(U3) ;get 1st descriptor for string + ADDI U2,(U1) ;add in char cnt. + ADDI U3,1 + AOBJN U3,USGC2 + + ;U2 now has # chars actually used in string space... + ;must determine whether or not to munch. + + POPAE P,[U3,U2,U1] ;for time being, don't. + POPJ P, + + ;Stringspace bumped, adjust all byte ptr addrs. UBMPDF contains + ;adjustment to add in. Later, handle case of a String PDL (SP). +USTBMP: PUSHAE P,[U1,U2] + MOVE U1,UBMPDF + MOVSI U2,-NSTRS + ADDM U1,STRNGS+1(U2) ;bump up addr of string's byte ptr + ADDI U2,1 + AOBJN U2,.-2 + POPAE P,[U2,U1] + POPJ P, +] ;end of ifn ustrgs + +IFN UAREAS,[ IFN OS%ITS, .INSRT DSK:KSC;PAGSER > + IFN OS%TNX, .INSRT PAGSER.MID +] +IFN ULISTS,[ IFN OS%ITS, .INSRT DSK:KSC;NLISTS > + IFN OS%TNX, .INSRT NLISTS.MID +] +CONSTANTS ; So UUO stuff doesn't muck up anything else + +UUOEND==. diff --git a/src/klh/out.250 b/src/klh/out.250 new file mode 100755 index 00000000..8128f506 --- /dev/null +++ b/src/klh/out.250 @@ -0,0 +1,2709 @@ +;;; -*- Mode:MIDAS -*- +SUBTTL Switch setup, to-do comments. + +;PRINT VERSION NUMBER +.TYO6 .IFNM1 +.TYO 40 +.TYO6 .IFNM2 +PRINTX/ included in this assembly. +/ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; ;;;;; +;;;;; "OUT" ;;;;; +;;;;; NEW OUTPUT PACKAGE INTERFACE ;;;;; +;;;;; ;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; ;;;;; +;;;;; Documentation in MC:KSC;?OUT > ;;;;; +;;;;; or [SRI-NIC]OUT.DOC ;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; REQUIRES: +;;;;; .INSRT MACROS - KSC;MACROS or MACROS +;;;;; U1,U2,U3,U4 - Sequential ACs +;;;;; P - PDL AC +;;;;; AUTPSY - JSR'd to for fatal errors +;;;;; Certain items will require other defs if they are assembled. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +IFNDEF $$O%1T,$$O%1T==0 ; Initialize once-only flag +IFE $$O%1T-.PASS, .INEOF ; If already seen OUT package this pass, flush. +$$O%1T==.PASS + +IFNDEF $$OUT,$$OUT==1 ; 1 = Using new OUT stuff. Flush flag eventually. +IFNDEF $$DQ,$$DQ==0 ; Not using DQ: device unless we understand it. + + ; Various item class conditional switches +IFNDEF $$OFLT,$$OFLT==0 ; Floating point output +IFNDEF $$OBUF,$$OBUF==0 ; UC$BUF Buffered output (must .INSRT PAGSER) +IFNDEF $$OTIM,$$OTIM==0 ; Time output items (must .INSRT TIMRTS) +IFNDEF $$OHST,$$OHST==0 ; Network Host name/# (on ITS, must .INSRT NETWRK) +IFNDEF $$OERR,$$OERR==0 ; OS Error string output (on ITS must define ERRCHN) +IFNDEF $$OPRF,$$OPRF==0 ; PRINTF routine hack + + ; More conditional switches needed when not using NUUOs. +IFNDEF UAREAS,UAREAS==0 ; Disable "uuo area" stuff +IFNDEF ULISTS,ULISTS==0 ; Likewise "uuo lists" +IFNDEF USTRGS,USTRGS==0 ; ditto "strings" stuff. + + ; Parameters +IFNDEF $$CHMX,$$CHMX==:20 ; Max # of channels user can use. + +comment | +To-do stuff: + +Interpreted O.-instrs vs. inline code + Interpretation: compact but slower. + Inline: faster, but larger. More flexible? + Finally decided to flush all $$ORID code (retaining old copy in case + it ever becomes useful, which seems unlikely) + +Protocol for OC channel AC + Must preserve U2 (esp over UUO's) if == to OC. + Reshuffle 4 UUO ac's, so OC not in middle?(interfers with 2-ac stuff) + STDCH macro to set OC explicitly. + Should OUT save/restore? Yes - can specify alternate chan. + Should STDOUT? + For STDOUT(ch,arg) should preserve? force use of STDCH + to explicitly set. + Can use file of 2-AC instrs for CREFFin to find dependencies. + See whether any dep on U1/U2. If not, make U1 the channel AC? + Problem: UUO's clobber it, so can't simply make it + "default"... only within an OUT or similar. + +Allow use of STDOUT, STDOBP. + Extend STDOUT macro to take chan, byte addr args? + Add STROUT plus ditto? + Pain to save/restore (unless all use OUT call?) + Screw if smashed by sub. User must know how to save/restore OC. + +Put STRMOVE (from FSCOPY) in for string ops, allow direct access. + +Have error macro to replace JSR AUTPSY, so that can specify string. + Something like: + CALL @[OUTERR ? ASCIZ /text/] + +Implement recursive FMT... problem with hacking temp buffer. May + need to allocate extra space, etc. + +Should allow user to specify string rtn for XCT-type channels. + Actually should specify vector holding everything necessary + such as string-mode rtn addr, unit-mode instr, overflow rtn addr, + etc. +| + +subttl .BEGIN OUT - Macro definitions + +.BEGIN OUT ; Start symbol block +.NSTGW ; Lots of hairy defs, make sure no storage assembled. +QMTCH==.QMTCH ; Save value and ensure +.QMTCH==0 ; package assembles with traditional quoting style. + +SLEV==0 ; Stack level at start of OUT macro. +IF1 [ ; Begin moby conditional for macro defs + ; Only assemble if pass 1. + + ;;; Establish stack macro +DEFINE .M"STK ; To use instead of (P). +(P)-OUT"SLEV!TERMIN + +DEFINE DEFMOC NAME,*PRE*,*POST* ; Intermediate useful macro. +DEFINE NAME (CH,A=$,B=$,C=$,D=$,E=$,F=$,G=$,H=$,I=$,J=$,K=$,L=$,M=$,N=$,O=$,Q=$,R=$,S=$,T=$,U=$,V=$,W) +PRE +OUT"$!A +OUT"$!B +OUT"$!C +OUT"$!D +OUT"$!E +OUT"$!F +OUT"$!G +OUT"$!H +OUT"$!I +OUT"$!J +OUT"$!K +OUT"$!L +OUT"$!M +OUT"$!N +OUT"$!O +OUT"$!Q +OUT"$!R +OUT"$!S +OUT"$!T +OUT"$!U +OUT"$!V +.ERR No more than 20 arguments allowed! +.TAG HO +POST +TERMIN +TERMIN + +DEFMOC .M"OUTCOD,| +IFNB [CH]{ PUSH P,OC ? MOVEI OC,CH ? OUT"SLEV==OUT"SLEV+1 } +|,|IFNB [CH]{ POP P,OC ? OUT"SLEV==OUT"SLEV-1 }| + +DEFMOC .M"OUTCAL,| +PUSHJ P,[ +IFNB [CH]{ HRLM OC,(P) ? MOVEI OC,CH } +OUT"SLEV==OUT"SLEV+1 +|,|IFNB [CH]{ HLRZ OC,(P) } +OUT"SLEV==OUT"SLEV-1 +POPJ P,]| + +EXPUNGE DEFMOC + +;;; Establish default for simple "OUT" to use. + +EQUALS .M"OUT,OUTCOD ; For now, default is inline. +;EQUALS .M"OUT,OUTCAL ; Alternative would be default of CALL. + +;;;----------------------------------------------------------------- +;;; Fundamental "OUT" item definitions +;;; These are critical to proper operation of the OUT macro!! + +DEFINE $$ ; Invoked when no arg furnished, to terminate macro. +.GO HO +TERMIN + + ; Define appropriate macro for constant text output. + ; Optimizes 1-char case. +DEFINE $ &TEXT& +IFN <.LENGTH TEXT>-1,{ + MOVE U3,[.LENGTH TEXT,,[ASCII TEXT]] + CALL OUT"OXTC +} +.ELSE { + MOVEI U1,_-29. + STDOUT +} +TERMIN + + ; Continuation of single OUT, in case want to squeeze more items + ; into a single OUT statement. +DEFINE $OUT (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V) +OUTCOD(,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V) +TERMIN + +;;;-------------------------------------------------------- +;;; More standard OUT items +;;; Not so fundamental to macro hackery, +;;; but closely tied to package. + +DEFINE $CH (ARG) ; CH(chan) - Force to a new channel +MOVEI OC,ARG +TERMIN + +DEFINE $OPEN (TYP,ARG,L,BS) ; Open the channel +MOVEI U1,TYP +MOVEI U3,[IFSN [ARG][]{ARG} .ELSE {[0]} + L+0 + BS+0 ] +IFSN [L!BS][] TLO U3, +CALL OUT"UOPEN3 +TERMIN + +DEFINE $PTV (ARG) ; Read channel I/O ptr +CALL OUT"UPTV +MOVEM U1,ARG +TERMIN + +DEFINE $FRC ; Force out buffered stuff on channel +CALL OUT"OXFRC +TERMIN + +DEFINE $RST ; Reset channel +CALL OUT"OXRST +TERMIN + +DEFINE $CLS ; Close channel +CALL OUT"OXCLS +TERMIN + +DEFINE $PUSH ; Push channel on IO PDL +CALL OUT"OXPUSH +TERMIN + +DEFINE $POP ; Pop off PDL into channel +CALL OUT"OXPOP +TERMIN + +DEFINE $POPALL ; Pop entire PDL +CALL OUT"OXPDLR +TERMIN + +DEFINE $CALL (ARG) ; Invoke random routine. +CALL ARG +TERMIN + + + ; Maybe this macro should take an initial arg saying + ; how many additional instrs the field should apply to??? +DEFINE $FMT (A,B,C,D) +OUT"$FMB(B,C,D) +OUT"$!A +OUT"$FME +TERMIN + +DEFINE $FMB (WID,PREC,FILL,NUM=E,) ; Last "," needed to end default val. + HRREI U1,WID +IFB [PREC!FILL]{ CALL OUT"OXFST1 ? .STOP } +IFB [PREC] HRLOI U3,377777 +.ELSE MOV!NUM!I U3,PREC +IFB [FILL]{ CALL OUT"OXFST2 ? .STOP } + MOVEI U4,FILL + CALL OUT"OXFST3 +TERMIN + +DEFINE $FME +CALL OUT"OXFDON +TERMIN + +DEFINE $XCT (A) +A +TERMIN + +;----------------------------------------------------------------- +; Value-printing "OUT" item routines. + + ; General fmt of numerical output items is + ; N(,width,prec,fill) + ; where N = O - Octal + ; D - Decimal + ; X - Hexadecimal + ; F - Floating (at moment really G) + ; E - Floating E fmt (at moment really G) + ; G - Floating F/E fmt (whichever "best") + ; See "FMT" for explanation of width,prec,fill. + +IRP NAM,,[O,D,X,F,E,G]RDX,,[8,10,16,F,E,G] +DEFINE $!NAM (NUM,A,B,C) +IFNB [A!!B!!C] OUT"$FMB(A,B,C,N) +MOVE U3,NUM +CALL OUT"OXN!RDX +IFNB [A!!B!!C] OUT"$FME +TERMIN +TERMIN + +DEFINE $N10 (ARG) ; "N10" - Number, base 10 ; signed decimal value, +MOVE U3,ARG ; with decimal point. +CALL OUT"OXN10 +STDOUT(".) +TERMIN + + + ; Following setup for DEFITM isn't very pretty, but is necessary + ; to produce minimal macro code for each item. If only MIDAS + ; had string variables!!! +DEFINE DEFIT2 ITM,*INSTR*,INTNAM ; Auxiliary for DEFITM below. +IFNB [INTNAM]{ DEFINE $!ITM (ARG) +INSTR +CALL OUT"INTNAM +TERMIN .STOP } +DEFINE $!ITM (ARG) +INSTR +CALL OUT"OX!ITM +TERMIN +TERMIN + +DEFINE DEFITM ITM,INSTR,INTNAM ; Macro for standard item definitions. +IFSE [INSTR][]{ DEFIT2 ITM,"MOVE U3,ARG",INTNAM + .STOP } +IFSE [INSTR][-]{ DEFIT2 ITM,,INTNAM + .STOP } +IFE &17,{ DEFIT2 ITM,"INSTR U3,ARG",INTNAM + .STOP } +DEFIT2 ITM,"INSTR,ARG",INTNAM +TERMIN + + +DEFITM CRLF,- ; CRLF() - obvious +DEFITM EOL,- ; EOL() - same as CRLF +DEFITM TAB,- ; TAB() - output a tab +DEFITM SP,- ; SP() - output a space +DEFITM TLS,,OXLS ; TLS([slp]) - Text, List String. +DEFITM TA,MOVEI U1,OXAR ; TA(arpt) - Text, Area. Outputs whole area. +DEFITM TS,MOVEI,OXS ; TS([,,# ? bp]) - Text, String variable. + +EQUALS $N9,$D +EQUALS $N8,$O +EQUALS $OCT,$O ; "OCT" - OCTal value of word, same as N8. +EQUALS $DEC,$N10 ; "DEC" - DECimal value of word, same as N10. + +DEFITM NFL,,OXNFL ; NFL(aval) - floating number (G fmt) + +DEFITM TZ,MOVEI,OXZA ; TZ(a-asciz) - Outputs asciz string +DEFITM TZ$,HRRZ,OXZA ; TZ$(a-[a-asciz]) like TZ(@A) but avoids + ; further indirection (if LH non-z) + +DEFITM TC,,OXTC ; TC([#,,[asciz]]) Outputs ASCNT string +DEFITM TPZ,,OXZ ; TPZ([bp]) - Outputs BYTEZ string +DEFITM TPC,,OXPC ; TPC([#,,[bp]]) a bit of a kludge. + +DEFITM W,,OXWD ; W(aval) - 36 bit binary word, as-is. +DEFITM WLH,HLRZ,OXWD ; WLH(aval) - left halfword, binary, ditto. +DEFITM WRH,HRRZ,OXWD ; WRH(aval) - right halfword, ... +DEFITM WBA,,OXWBA ; WBA(#,,[ascii]) binary ASCNT (36 bit chars) + +DEFITM RH,HRRZ ; RH(aval) - Right halfword, full (6 digits) +DEFITM LH,HLRZ,OXRH ; LH(aval) - Left halfword, full. +DEFITM HWD ; HWD(aval) - "LH,,RH" +EQUALS $H,$HWD ; H(aval) - same as HWD +DEFITM RHV,HRRZ,OXN8 ; RHV(aval) - RH as octal num, not bit pattern. +DEFITM LHV,HLRZ,OXN8 ; LHV(aval) - LH as octal num, not bit pattern. +DEFITM HV ; HV(aval) - LHV,,RHV +DEFITM RHS,HRRE,OXN8 ; RHS(aval) - RH as signed octal num +DEFITM LHS,HLRE,OXN8 ; LHS(aval) - LH as signed octal num +DEFITM HS,,OXNHS ; HS(aval) - LHS,,RHS + +DEFITM 6F ; 6F(aval) - Outputs as sixbit without trailing sp. +DEFITM 6W ; 6W(aval) - Outputs all 6 sixbit chars +DEFITM 6Q ; 6Q(aval) - like 6F but quotes punct. chars with ^Q + +; Arpanet host output items. Requires HOSTS3 and NETWRK, unless OS%TNX. +; For all 4 items, argument is a host number value (normally HOSTS3 fmt) +DEFITM HN ; HN(aval) - Host # simplifying if possible +DEFITM HND ; HND(aval) - like HN but decimal Internet fmt. +DEFITM HST ; HST(aval) - Host name (becomes HND if no name) + ; HOST(aval,{item}) - Host name; if no name, + ; output alternate item spec instead. +DEFINE $HOST (ARG,ALTITM) + MOVE U3,ARG + CALL OUT"OXHOST +IFB [ALTITM] NOP +.ELSE OUTCAL(,ALTITM) +TERMIN + +;;; Idiosyncratic items + +DEFINE $C (CH) ; C - character (furnish immediate value) +MOVEI U1,CH +STDOUT +TERMIN + +DEFINE $S (CNT,BP) ; S - String([#],[bp]) +MOVE U3,BP +SKIPLE U4,CNT + CALL @OUT"USCOPT(OC) +TERMIN + +DEFINE $SL (SLP,SAR) ; String, List. SAR is optional LSE addr. +MOVE U3,SLP +IFB [SAR] CALL OUT"OXSL ? .STOP +SKIPE U1,SAR ; Feeble robustness. + CALL OUT"OXSLA +TERMIN + + ; Define item names for various chars which would fuck up + ; MIDAS macro parsing if seen in literal string. Other + ; baddies are CRLF and sometimes comma or double-quote. +IRP ITM,,[LABR,RABR,LBRK,RBRK,LBRC,RBRC,LPAR,RPAR]VAL,,[74,76,133,135,173,175,50,51] +DEFINE $!ITM +STDOUT(VAL) +TERMIN +TERMIN + +DEFINE $ERR (ARG) ; "ERR" - System error message. If arg is blank, +IFB [ARG] CALL OUT"OXERRL ; use last err, otherwise arg is error code +.ELSE MOVE U3,ARG ? CALL OUT"OXERR +TERMIN + + +DEFINE $TIM (TYP,ARG) +IFB [ARG]{ ; If no arg, use current time. + IFN OS%ITS, CALL OUT"UTMGTS + IFN OS%TNX, SETO U3, +} .ELSE MOVE U3,ARG + MOVEI U1,OUT"T$!TYP + CALL OUT"OXTXS +TERMIN + ; DEFT - for matching subtype names with routines. + ; Subtypes are defined in the $$OTIM section. +DEFINE DEFT ITM,RTN +IF2 T$!ITM==:RTN +TERMIN + +] ;END MOBY PASS 1 CONDITIONAL + +IF2 [ ; Only assemble if pass 2 + + ; For anything that needs pass2 def? + +] ; END PASS 2 + +.YSTGW ; OK to gen code now. + +;;; Resolve a few awkward defs that are shared with other files +;;; which may or may not be inserted (specifically NUUOS) + +IF2 IFNDEF AUTPSY, AUTPSY: + 0 ? JRST 4,. + +IF1 $$O%BP==0 +IF1 IFNDEF MADBP7,$$O%BP==1 +IFN $$O%BP,[ ; Needs 7-bit ADJBP macro and tables +DEFINE MADBP7 BP,CNT + MULI BP,5 + ADD BP+1,UADBP7(BP) + ADD BP+1,CNT + MOVE BP,BP+1 + IDIVI BP,5 + SUB BP,UHADB7(BP+1) +TERMIN + + ; Subtracted from 0,,addr to give appropriate BP pointing at + ; indexed char (ILDB to get it). +UHADB7: -010700,,1 + -350700,,0 + -260700,,0 + -170700,,0 + -100700,,0 + -010700,,0 ; 5th char, may want to index table by UHADB7+1(A) + ; so as to get pointer for LDB, not ILDB. + + + 133500,,0 ; to handle -5 produced by 440700 + repeat 4,0 +UADBP7: -54300,,5 + -104300,,4 + -134300,,3 + -164300,,2 + -214300,,1 +] ; IFN $$O%BP + +SUBTTL Output package channel definitions + +; $UNCHS - Establish how many channels will be used, and +; set things up so that package-related channel #'s +; will have space reserved for them, altho illegal for +; "user" channels. + +IF1 [ + %%LSV==. ? OFFSET -.+$$CHMX +UFLDC:: 0 ; OUT package field-output channel +IFDEF USTRGS,IFNDEF STRC,.M"STRC:: 0 ; UUO package string area channel +.M"$UNCHS:: ; REAL maximum legal # of channels. + + OFFSET 0 ? LOC %%LSV ; Don't waste space + EXPUNGE %%LSV + + +] ;IF1 + +SUBTTL OUT channel maintenance - basic support + +;;;;;;;;;;;;; Unit Output Inline Macro for OUT Channels ;;;;;;;; + + ; STDOUT outputs single byte in U1 on channel in OC. + ; STDOUT(arg) outputs byte "arg" on channel in OC, clobbers U1. +DEFINE .M"STDOUT (A) +IFSN [A][] MOVEI U1,A +AOSLE @OUT"UCHCNT(OC) + PUSHJ P,OUT"UCHMP +XCT OUT"UCOPT(OC) +TERMIN + ; STDOBP - variant of STDOUT to be used when there is a BP in + ; U3 that may be susceptible to "bumping". +DEFINE .M"STDOBP (A) +IFSN [A][] MOVEI U1,A +AOSLE @OUT"UCHCNT(OC) + PUSHJ P,OUT"UCHMPX +XCT OUT"UCOPT(OC) +TERMIN + +;;;;;;;;;;;;;;;;; Tables for OUT channels ;;;;;;;;;;;;;;;;;;;; + +BVAR +UCOPT: BLOCK $UNCHS ; XCT'd unit-mode instruction +USCOPT: BLOCK $UNCHS ; Addr of string-mode routine +UCHCNT: BLOCK $UNCHS ; Addr of char countdown +UCNTS: BLOCK $UNCHS ; Char countdown if non-area +UCHLIM: BLOCK $UNCHS ; Original count allowed +UCHTYP: BLOCK $UNCHS ; ,, +IFN OS%TNX,UCHJFN: BLOCK $UNCHS ; JFN for channel if any +UCHSTB: BLOCK $UNCHS ; Byte ptr (UC$BPT) or ARPT (UC$UAR) +IFN UAREAS,[ +UBMPSP: 0 ; Holds special ptr for string output UUO's to avoid area-shift + ; clobberage. + ; UCHSTB, and locs immediately following up to NUSPBP, will be + ; adjusted automatically to compensate for any shifts of UUO areas. +NUSPBP==.-UCHSTB ] +EVAR +;----------------------------------------------------------------- + + ; OUT Channel types. + +.M"UC$UAR==0 ; UAR - UUO area output. Channel type 0 for easy check. +.M"UC$XCT==1 ; XCT - Execute given instr for each output char +.M"UC$BPT==2 ; BPT - Byte PTr +.M"UC$IOT==3 ; IOT - .IOT/SIOT (or BOUT/SOUT) +.M"UC$BUF==4 ; BUF - Buffered UC$IOT +.M"UC$TRN==5 ; TRN - Translate into another chan. +.M"UC$NUL==6 ; NUL - Null output sink + .M"UC$NX==7 ;==> # of executable channel types. +.M"UC$SAO==7 ; SAO - Like UAR for LSE's String-Area. + .M"UC$NO==10 ;==> # of OPEN-able channel types. + +UC%FLD==<7_5>,,0 ; Mask for type number (in AC field). +.M"UC%LIM==1000,,0 ; Arg flag meaning byte # limit specified. +.M"UC%BSZ==2000,,0 ; Arg flag meaning bytesize specified. + +UC%DBF==200000 ; UCHTYP flag, means dynamic UC$BUF buffer. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Item OPEN(type,arg,arg2) - Opens an OUT channel. See OUT doc. + + ; If there is any chance that U3 will have I or X bits set at + ; this point, then the following instr should be uncommented. + ; In theory the $OPN macro will never use it. +;UOPEN2: HRRI U3,@U3 ; Set RH to true effective address. + + ; Entry point for $OPN macro invocation. + ; OC - Channel # + ; U1 - channel type + ; U3 - ,[ ? ? ... ] +UOPEN3: CAIL U1,UC$NO ; Check type + JSR AUTPSY ; Unknown type! Bad argument. + +;; Should the following code be implemented?? Would it break +;; any programs, or be grossly inefficient, or what? --KLH 11/11/82 +;; SKIPN UCHTYP(OC) ; Check existing channel type +;; JRST [ PUSHAE P,[U1,U3] ; Ugh, it's still open! +;; CALL OXCLS ; Close up the channel! +;; POPAE P,[U3,U1] +;; JRST .+1] + + MOVEM U1,UCHTYP(OC) ; Store channel type, with zeroed flags. + PJRST @UOPENT(U1) ; Dispatch for further processing. + +UOPENT: UOPNAR ; Area + UOPNX ; XCT + UOPNBP ; BPT + UOPNIO ; IOT + UOPNBF ; BUF + UOPNTR ; Transl. + UOPNNL ; NUL + UOPNSA ; SAO +IFN UC$NO-<.-UOPENT> .ERR UOPENT table loses + + ; Common return point for some types. + ; U1 - unit-mode instr + ; U4 - ,, rtn addrs for string-mode output. +UOPN3: MOVEM U1,UCOPT(OC) ; Store instruction for unit-mode byte output. + TLNE U3,(UC%LIM) ; Was limit explicitly specified? + JRST [ HLRZM U4,USCOPT(OC) ; Yes, use limit-type string routine. + MOVN U4,@1(U3) ; And get specified limit value. + JRST UOPN4] + HRRZM U4,USCOPT(OC) ; No, use no-limit string routine. + MOVSI U4,(SETZ) ; And use max neg # for "limit". +UOPN4: MOVEM U4,UCHLIM(OC) ; Set up limit. + MOVEM U4,UCNTS(OC) ; and count. + MOVEI U1,UCNTS(OC) ; Find addr of count + MOVEM U1,UCHCNT(OC) ; and store that. + RET + +; UC$UAR - Channel type AREA + +UOPNAR: +IFE UAREAS,JSR AUTPSY ; Lose if no area hackery assembled. +.ELSE [ + MOVEI U4,@(U3) ; Get ARPT to area +UOPNA1: MOVEM U4,UCHSTB(OC) ; Store ARPT, instead of a BP + HLL U4,$ARTYP(U4) ; Get type bits. + MOVEI U1,$ARWPT(U4) ; Get addr to write place, + HRLI U1,(IDPB U1,) ; and insert instruction to XCT. + TLNN U4,%ARTCH ; But if area is in binary mode + MOVE U1,[CALL UOL.AW] ; need hairy insn + MOVEM U1,UCOPT(OC) ; Store XCT for unit mode, + MOVEI U1,$ARCHL(U4) + MOVEM U1,UCHCNT(OC) ; and addr to find char countdown in. + MOVEI U1,UOL.AR ; Get addr of string output rtn + TLNN U4,%ARTCH ; But if area is in binary mode + MOVEI U1,UOL.AB ; need different rtn + MOVEM U1,USCOPT(OC) ; and set up. +UOPNA9: CAIGE U3, ; Now, if sign bit was set in flags, + CALL UXRST ; reset the area. + RET + +; UOL.AW - Binary word output routine for UC$ARs. +UOL.AW: MOVE U4,UCHSTB(OC) ; Get ARPT for area + MOVE U3,$ARWPT(U4) ; Get write ptr + MOVEM U1,@U3 ; Store down it + AOS $ARWPT(U4) ; Update ptr + RET + + +; UOL.AR - String output routine for UC$UAR type. +UOL.AR: ADDM U4,@UCHCNT(OC) ; Add into count + SKIPLE @UCHCNT(OC) ; Check it. + PUSHJ P,UCHMPX ; If no room left, go get some. +IFE OC-U2, PUSH P,U2 + MOVE U2,@UCOPT(OC) ; Get BP used by the IDPB (from $ARWPT) + ILDB U1,U3 + IDPB U1,U2 + SOJG U4,.-2 +IFE OC-U2,[ + EXCH U2,(P) ; Now restore BP to area's $ARWPT + POP P,@UCOPT(OC) ] +.ELSE MOVEM U2,@UCOPT(OC) + RET + +; UOL.AB - Binary-mode string output routine for UC$UAR type. +UOL.AB: ADDM U4,@UCHCNT(OC) ; Add into count + SKIPLE @UCHCNT(OC) ; Check it + PUSHJ P,UCHMPX ; If no room left, go get some +IFE OC-U2, PUSH P,U2 + MOVE U2,UCHSTB(OC) ; Get area pointer + ILDB U1,U3 ; Get source word + MOVEM U1,@$ARWPT(U2) ; Write into the area + AOS $ARWPT(U2) ; Increment ptr + SOJG U4,.-3 ; Loop for all output wds +IFE OC-U2, POP P,U2 + RET + +] ; IFN UAREAS + +; UC$XCT - Channel type XCT + +UOPNX: MOVE U4,[UOL.X,,UOS.X] ; Specify string-mode rtns to use + MOVE U1,@(U3) ; Get instr to XCT + JRST UOPN3 + + ; String output, XCT +UOL.X: SKIPG U1,U4 + RET + ADDB U1,@UCHCNT(OC) + JUMPL U1,UOS.X2 + CALL OVFS ; Handle overflow. +UOS.X: ADDM U4,@UCHCNT(OC) +UOS.X2: ILDB U1,U3 + XCT UCOPT(OC) ; for now, really unit-mode. + SOJG U4,.-2 + RET + +; UC$BPT - Channel type BPT (Byte Ptr) + +UOPNBP: MOVE U1,@(U3) ; Get byte ptr + MOVEM U1,UCHSTB(OC) ; And use that as channel state. + MOVE U1,[IDPB U1,UCHSTB] + ADDI U1,(OC) ; Make IDPB point to right BP + MOVE U4,[UOL.BP,,UOS.BP] ; Specify string-mode output rtns. + JRST UOPN3 ; Store instruction & other stuff. + + ; String output, BP +UOL.BP: SKIPG U1,U4 + RET + ADDB U1,@UCHCNT(OC) + JUMPL U1,UOS.B2 + CALL OVFS ; Handle overflow. +UOS.BP: ADDM U4,@UCHCNT(OC) ; Inc. count +UOS.B2: ILDB U1,U3 + IDPB U1,UCHSTB(OC) ; BP lives there. + SOJG U4,.-2 + RET + +; UC$IOT - Channel Type IOT ("Hard" channel) + +UOPNIO: +IFN OS%ITS,[ MOVE U1,[.IOT U1] ; Get unit operation + CAILE OC,17 ; Ch # must fit into AC field. + JSR AUTPSY + DPB OC,[$ACFLD,,U1] ; Store ch # into instr +] +IFN OS%TNX,[ MOVE U1,@(U3) ; Get JFN for channel + MOVEM U1,UCHJFN(OC) ; store + MOVE U1,[CALL U.BOUT] ; Set up instr to xct +] + MOVE U4,[UOL.IO,,UOS.IO] ; Specify string-mode output rtns + JRST UOPN3 + +IFN OS%TNX,[ +U.BOUT: PUSHAE P,[1,2] ; Routine called for UC$IOT byte output + MOVE 1,UCHJFN(OC) + MOVE 2,U1 + BOUT + POPAE P,[2,1] + POPJ P, +] + ;String output, .IOT +UOL.IO: SKIPG U1,U4 + RET + ADDB U1,@UCHCNT(OC) + JUMPL U1,UOS.I2 + CALL OVFS ; Handle overflow. +UOS.IO: ADDM U4,@UCHCNT(OC) ; Bump cnt. +UOS.I2: +IFN OS%ITS,[ SYSCAL SIOT,[OC ? U3 ? U4] ; Trivial! + JSR AUTPSY ; ?!?! +] +IFN OS%TNX,[ PUSHAE P,[1,2,3] + MOVE 1,UCHJFN(OC) ; Set up JFN + MOVE 2,U3 ; bp to string + MOVN 3,U4 ; byte count + SOUT + POPAE P,[3,2,1] +] + RET + +; UC$BUF - Channel type BUF (buffered UC$IOT) +; This code assumes U3 is of form +; ,[ [arg] ? [lim] ? [bytesize]] +; is as for UC$IOT - on TNX, the JFN to use. +; is the size of bytes to use. +; Defaults to 7. +; is the buffer size, IN BYTES, to use. +; Defaults to one page. +; If negative, it is treated as an AOBJN pointer to +; the buffer; LH is # of WORDS. +; If unspecified or zero, the buffer is dynamically allocated. +; Be sure to CLS the channel, or the buffer will +; stay around forever! + +UOPNBF: +IFE $$OBUF,JSR AUTPSY +.ELSE [ MOVE U1,U3 ; Get arg ptr into better place +IFN OS%TNX,[ + MOVE U4,@(U1) ; Get 1st arg (JFN) + MOVEM U4,UCHJFN(OC) ; Store... +] + TLNN U1,(UC%BSZ) ; Was byte-size specified? + JRST [ MOVEI U3,440700 ; No, default to 7-bit. Set up BP LH + HRLZM U3,UCHSTB(OC) + MOVEI U4,5 ; and use this many bytes/wd + JRST UOPNB2] + SKIPLE U4,@2(U1) ; Get byte-size... + CAILE U4,36. ; Make sure it's reasonable. + JSR AUTPSY + MOVEI U3,440000 + DPB U4,[060600,,U3] ; Insert it into S field of BP LH + HRLZM U3,UCHSTB(OC) ; and store LH for later use. + MOVEI U3,36. + IDIV U3,@2(U1) ; Find # bytes per word + MOVE U4,U3 ; Save + + ; Have in U4, now find buffer length. +UOPNB2: TLNN U1,(UC%LIM) ; Byte limit specified? + JRST UOPNBD ; Nope, use default. + SKIPGE U3,@1(U1) ; If is AOBJN, it specifies # words. + JRST [ HLRO U3,U3 ; Get -<# wds> + MOVN U3,U3 + JRST UOPNB3] ; Go set up stuff. + JUMPE U3,UOPNBD ; If zero, use default of one page. + PUSH P,U3 ; Save # bytes + IDIVI U3,(U4) ; Find # words to use + CAIE U4, ; If any remainder, + ADDI U3,1 ; round up to next # of words. + POP P,U4 ; Restore # bytes (want to use exact # given). + JRST UOPNB4 + +UOPNBD: MOVEI U3,PG$SIZ +UOPNB3: IMULI U4,(U3) ; Find # bytes to use in buffer. +UOPNB4: MOVNM U4,UCHLIM(OC) ; Save -<# bytes> as limit. + MOVNM U4,UCNTS(OC) ; and set up actual countdown. + + ; Now have buffer length in U3 as # words. See if must allocate. + TLNE U1,(UC%LIM) ; Check again for existence. + SKIPL U1,@1(U1) ; Clobber arg ptr, skip if AOBJN given. + CAIA + JRST UOPNB5 ; Needn't allocate! U1 RH has buf addr! +IFE U2-OC,PUSH P,OC + MOVEI U1,(U3) ; Ask for this many wds. +IFDEF CORGET,CALL CORGET ; Get buffer space, return addr in U2 +.ELSE JSR AUTPSY ? IF2 .ERR PAGSER package must be inserted for UC$BUF!! + MOVEI U1,(U2) +IFE U2-OC,POP P,OC ; Need hair when U2 == OC. + MOVSI U4,UC%DBF ; Must set "dynamic buffer" flag + IORM U4,UCHTYP(OC) ; so we remember to de-allocate later. + +UOPNB5: ADDI U3,(U1) ; Find last addr + 1 + HRLM U1,UCHLIM(OC) ; Save start addr of buffer + HRRM U1,UCHSTB(OC) ; and set up initial BP addr. + HRLI U1,(U1) + ADDI U1,1 ; Set up src,,src+1 for BLT zap. + SETZM -1(U1) + CAILE U3,(U1) ; Handle screw case of 1-wd buffer. + BLT U1,-1(U3) ; Clean out the buffer. + + MOVEI U4,UCNTS(OC) + MOVEM U4,UCHCNT(OC) ; Set addr of countdown + MOVEI U4,UOL.BF ; Set string-mode rtn addr. + MOVEM U4,USCOPT(OC) ; Set it. + MOVEI U1,UCHSTB(OC) + HRLI U1,(IDPB U1,) ; Cons up unit-mode instr + MOVEM U1,UCOPT(OC) ; Set. + RET ; Done... + + +UOL.BF: SKIPG U1,U4 ; Get temp in U1 + RET ; making sure something to write. + ADDB U1,@UCHCNT(OC) ; Add into count + JUMPGE U1,UOLBF1 ; Jump if buffer would be filled up. + ILDB U1,U3 ; Nope, just copy light-heartedly. + IDPB U1,UCHSTB(OC) + SOJG U4,.-2 + RET + + ; "Overflow". Note that unlike usual case, we come here even + ; when count is zero, in order to optimize bulk I/O. + ; The idea behind this optimization is that if buffer is + ; empty and byte sizes for request/output are same, we + ; can output directly and skip the copy overhead! + ; This is also done if stuff is already in the buffer but + ; the new stuff is large enough to force two system calls anyway. + ; Only possible problem is if something depends on size of + ; string output for each sys call, eg if one wants to do PMAP + ; type stuff. If that ever becomes desirable, a new output type + ; or flag can be created. + +UOLBF1: PUSH P,U3 + HRRO U3,UCHLIM(OC) ; Get original limit (fill out LH) + SUB U1,U4 ; Get original countdown, -<# left> + CAMG U1,U3 ; Countdown increased from original? + JRST UOLBF2 ; No, making huge request of virgin buffer - Optimize! + MOVM U3,U3 ; Get positive buffer length + SUB U3,U1 ; Add # bytes of room left in buffer + CAMGE U3,U4 ; Will we need more than one sys call? + JRST UOLBF4 ; No, jump to copy & output. + +UOLBF2: PUSH P,U1 ; Save -<# left> + LDB U1,[$SFLD,,-1(P)] ; Get S field of source BP + LDB U3,[$SFLD,,UCHSTB(OC)] ; Ditto for buffer BP + CAIE U1,(U3) ; If same, way's clear! + JRST UOLBF3 ; Nope, must convert via copy. +IFN OS%ITS,[ +;;; Following code prevents the disoptimization of doing non-word-aligned +;;; SIOTs which are very slow in ITS + CAIE U1,7 ; Only if byte size is 7 + JRST UOLB2A + PUSH P,U2 + MOVN U1,(P) ; Space available in buffer + IDIVI U1,5 + JUMPN U2,UOLB2B ; Mustn't SIOT + MOVE U1,U4 ; Amount to be output + IDIVI U1,5 + JUMPN U2,UOLB2B + POP P,U2 ; Okay, go ahead +UOLB2A: +;;; End of antidisoptimization code +] ;IFN OS%ITS + EXCH U4,(P) ; Save output cnt on PDL, get back -<# left> + HRRO U3,UCHLIM(OC) ; Get - for quick check... + MOVEM U3,UCNTS(OC) ; and reset limit in case no force-out. + CAMGE U3,U4 ; Anything at all in buffer? + CALL UFRCBI ; Yes, force it out using U4 for UCNTS. + POPAE P,[U4,U3] ; Then restore original source BP and cnt + CALRET UOS.I2 ; and go output directly via UC$IOT rtn! + +IFN OS%ITS,[ +UOLB2B: POP P,U2 ; This could be smarter! +] +UOLBF3: POP P,U1 ; Restore -<# left> +UOLBF4: EXCH U4,(P) ; Save output cnt, get back BP + MOVE U3,U4 ; Put BP in usual place + JUMPGE U1,UOLBF6 ; If buffer already full, skip copy. + ADDM U1,(P) ; Update saved output cnt. + MOVM U4,U1 ; and get cnt of chars to copy. + ILDB U1,U3 ; Twiddle + IDPB U1,UCHSTB(OC) ; twaddle + SOJG U4,.-2 +UOLBF6: PUSH P,U3 ; Save source BP + CALL UFRCBA ; Buffer always full here; output All. + POP P,U3 ; Now restore source BP + POP P,U4 ; and updated count + JRST UOL.BF ; and start over... + +; UFRCBF - Force out buffer. Clobbers U1,U3,U4. +; Alternate entry points UFRCBI - takes -<#left> countdown in U4 (Immediate) +; UFRCBA - sets -<#left> countdown to 0 (All of buffer) + +UFRCBA: TDZA U4,U4 +UFRCBF: MOVE U4,UCNTS(OC) ; Get -<# left> +UFRCBI: CAILE U4, ; Make sure something didn't trash buffer! + JSR AUTPSY ; Ugh, buffer overflowed?!?! + CALL UBFRST ; Reset buffer cnt/ptr, get -len in U1. + SUB U4,U1 ; -<# left> - - = # to output. + JUMPG U4,UOS.I2 ; Output buffer as per UC$IOT type. + RET + +; UBFRST - Called to reset buffer channel. +; Doesn't clobber U4, and leaves - in U1. +; UFRCBF depends on this. + +UBFRST: MOVE U1,UCHLIM(OC) ; Get ,,<-len> + HLRZ U3,U1 + HLL U3,UCHSTB(OC) ; Cons up new BP to start of buffer + TLZ U3,770000 + TLO U3,440000 ; Force P to 1st byte in word. + MOVEM U3,UCHSTB(OC) ; and set up new ptr. + TLO U1,-1 ; Make length a kosher neg. num. + MOVEM U1,UCNTS(OC) ; Store to re-initialize countdown. + RET + +] ;IFN $$OBUF + +; UC$TRN - Channel type TRANSL (translate to another UUO chan) +; Ignores any count specified. +; Main hair is setting things up so unit-mode AOS and XCT +; will work; for everything else including string-mode, the +; mapping is straightforward. + +UOPNTR: MOVE U4,@(U3) ; Get channel to translate to. + CAIL U4,$UNCHS ; Make sure it's reasonable! + JSR AUTPSY + MOVE U1,[XCT UCOPT] + ADDI U1,(U4) ; Do a XCT UCOPT+chan + MOVEM U1,UCOPT(OC) + MOVE U1,[@UCHCNT] ; Assemble an indirect into + ADDI U1,(U4) ; the target channel's countdown. + MOVEM U1,UCHCNT(OC) + MOVE U1,UCHSTB(U4) ; Just copy UCHSTB + MOVEM U1,UCHSTB(OC) + MOVEM U4,UCNTS(OC) ; and hide true channel # in unused count slot. + MOVEI U3,UOS.TR + MOVEM U3,USCOPT(OC) + RET + + ;String output, Translate. +UOS.TR: PUSH P,OC + MOVE OC,UCNTS(OC) ; Find right channel # to use. + CALL @USCOPT(OC) ; and go hack. + POP P,OC + RET + +; UC$NUL - Null output sink + +UOPNNL: MOVE U4,[UOS.NL,,UOS.NL] ; Specify string-mode rtns to use + MOVE U1,[NOP] ; Get instr to XCT + TLZ U3,(UC%LIM) ; Ignore any specified limit. + JRST UOPN3 + +UOS.NL: ADDM U4,@UCHCNT(OC) ; Might as well keep track of count. + RET ; But that's it. + + +; UCHMP - called when byte count on channel runs out during unit-mode +; output; see the STDOUT macro for context. Only other place this +; routine is called is from UAR-type string output. +; OC - channel #, +; @UCHCNT(OC) contains positive # of chars "over-run". +; for output to areas, this is # of chars needed. +; UCHMPX - variant in which +; U3 contains a BP that must be preserved across area bumps. + +UCHMPX: +IFN UAREAS,[ + MOVEM U3,UBMPSP ; Save U3 in holy place, + PUSHJ P,UCHMP ; so that its input ptr is bumped correctly if nec. + MOVE U3,UBMPSP ; Restore from sanctuary. + POPJ P, +] + +UCHMP: PUSHAE P,[U1,OC,U3,U4] +UCHMP0: MOVE U1,UCHTYP(OC) ; Get channel type + JRST @OVFTAB(U1) ; Dispatch to appropriate handler +OVFTAB: OVFLAR ; UAR + OVFLX ; XCT + OVFLBP ; BPT + OVFLIO ; IOT + OVFLBF ; BUF + OVFLTR ; TRAN + OVFLNL ; NUL +IFN .-, .ERR OVFTAB Loses + + ; TRAN type overflow. +OVFLTR: MOVE OC,UCNTS(OC) ; Translate, get real chan # + JRST UCHMP0 ; and try again. + + ; BUF type overflow. +OVFLBF: +IFE $$OBUF,JSR AUTPSY +.ELSE [ + SOS @UCHCNT(OC) ; Restore #-left to zero. + CALL UFRCBF ; Force out buffer + AOS @UCHCNT(OC) ; Allow for char wanting output + JRST UCHMP9 ; And return normally. +] + + ; NUL, XCT, IOT, and BPT type overflow. +OVFLNL: +OVFLX: +OVFLIO: +OVFLBP: MOVE U1,UCHLIM(OC) ; Get limit for channel + CAME U1,[SETZ] ; If using maximum, no limit. + JRST OVFLIM ; uh-oh, actually limiting... go handle. + MOVEM U1,UCNTS(OC) ; No limit, just reset count. + JRST UCHMP9 ; Return and output char. + + ; UAR type overflow +OVFLAR: +IFE UAREAS,JSR AUTPSY +IFN UAREAS,[ + MOVE U1,UCHSTB(OC) ; Get ARPT for area + SKIPG U3,$ARCHL(U1) ; In char mode get # chars needed + JSR AUTPSY ; Ugh?? Called when not supposed to? +IFN USTRGS,[ + CAIN U1,USTRAR ; Is this the string output area? + PUSHJ P,USTRGC ; Ugh, yes. Go see about GC'ing. + JRST OVFAR2 ; Didn't GC, proceed normally and expand + SKIPL $ARCHL(U1) ; If still need room after possible GC, + JRST OVFAR2 ; go expand normally. + ADDB U3,$ARCHL(U1) ; GC'd! Add to cnt of chars now available + JUMPL U1,UCHMP9 ; and exit if have enough now +OVFAR2:] ; else drop thru to normal expansion. + HLL U4,$ARTYP(U1) ; Get area type bits + TLNN U4,%ARTCH ; If binary mode + JRST OVFAR5 ; can write into whole thing + ADDI U3,4 ; Char mode - need to convert len to wds + IDIVI U3,5 ; Round up to # wds needed (clobbers U4) + MOVEM U3,ARUNIT ; Insert # as arg to UABUMP + PUSHJ P,UABUMP ; Go bumpit - adjusts $ARCHL. + SKIPLE $ARCHL(U1) ; Check to be SURE. + JSR AUTPSY ; Foo, didn't update or didn't get enough. + JRST UCHMP9 + +OVFAR5: MOVE U4,$ARWPT(U1) ; Current write ptr. + ADD U4,U3 ; New stuff would put us here. + CAMGE U4,$ARTOP(U1) ; If this would fit + JRST UCHMP9 ; no need to bump the area. + MOVEM U3,ARUNIT ; Else insert # as arg to UABUMP. + PUSHJ P,UABUMP ; Go bumpit. + JRST UCHMP9 + +] ;IFN UAREAS + +OVFLIM: SOS @UCHCNT(OC) ; Restore original count +UCHMP8: AOS -4(P) ; Abnormal return - DON'T output char!! +UCHMP9: ; Normal return - output char. + POPAE P,[U4,U3,OC,U1] + POPJ P, + +; OVFS - General-purpose overflow handler for string-mode routines. +; Only invoked for channels which are definitely being limited; +; it allows output only up to the limit specified. +; See BPT, IOT, etc. routines for context. +; This is a bit inefficient, could be improved by turning +; unit/string mode ops into NOPs. +; OC - channel # +; U1 - # chars overflowed +; U3 - source BP +; U4 - source cnt +; (P) - place to return for no-limit output +; -1(P) - place to return for no output at all. + +OVFS: SUB U1,U4 ; Find original count of -<# left> + MOVEM U1,@UCHCNT(OC) ; Store back + MOVN U4,U1 ; Smash source cnt to max allowable + CAIG U4, ; If result is non-null then skip to output + POP P,U1 ; Else flush 1st return, take 2nd for no output + RET + +; Old doc +; OUTPTV CH,[] For use with UUO channels. +; Returns to c(E) the cnt of chars outputted on channel since +; opened. For channels opened into an area, this is +; the # of chars between start of area and current Write BP. +; End of Old doc + +UPTV: MOVE U1,UCHTYP(OC) ; Get channel type. + PJRST @UPTTAB(U1) +UPTTAB: UPTAR ; Area + UPTX ; XCT + UPTBP ; BPT + UPTIO ; IOT + UPTBF ; BUF + UPTTR ; Transl. + UPTNL ; NUL +IFN UC$NX-<.-UPTTAB> .ERR UPTTAB table loses + +UPTAR: +IFE UAREAS, JSR AUTPSY +.ELSE [ MOVE U4,UCHSTB(OC) ; Get ARPT + MOVE U1,$ARWPT(U4) ; Get write ptr into area +IFE OC-U2,PUSH P,U2 + HRRZ U2,$ARLOC(U4) ; and "ptr" to start. + CALL UPDIF7 ; Find diff between the 2 ptrs + MOVE U1,U2 +IFE OC-U2,POP P,U2 + RET +] + +UPTIO: UPTX: UPTNL: ; These types share similar code. +UPTBP: SKIPA U1,UCHLIM(OC) ; Find beginning count. +UPTBF: HRRO U1,UCHLIM(OC) ; BUF type has cruft in the LH. + SUB U1,@UCHCNT(OC) ; <-max> - <-max + cnt> = -cnt + MOVM U1,U1 + RET + +UPTTR: PUSH P,OC + MOVE OC,UCNTS(OC) ; Get true channel # + CALL UPTV + POP P,OC + RET + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Other maintenance routines + +; OUTINI - Initialize output package. + +OUTINI: PUSH P,OC + PUSH P,[$UNCHS] ; Keep cnt on PDL cuz ACs clobbered. +OUTIN2: SOSGE OC,(P) + JRST OUTIN3 + CALL OXCLS ; Close channel + JRST OUTIN2 +OUTIN3: + ; Set up for field-output channel. + OUTCOD(,CH(UFLDC),OPEN(UC$BPT,[440700,,UFBUF],[$LUBUF])) + SUB P,[1,,1] + POP P,OC + RET + +OIFRC: +OXFRC: +IFN $$OBUF,[ + HRRZ U1,UCHTYP(OC) ; Get channel type + CAIN U1,UC$BUF ; If type BUF, + CALRET UFRCBF ; Go force it out, +] + RET ; else just return. + + ; Reset channel. Only meaningful for UAR and BUF. +OIRST: +OXRST: HRRZ U1,UCHTYP(OC) ; Get channel type +IFN $$OBUF,[ + CAIN U1,UC$BUF + CALRET UBFRST ; Do special buffer reset if BUF. +] +IFN UAREAS,[ + CAIN U1,UC$UAR + JRST [ MOVE U4,UCHSTB(OC) ; Get ARPT to area + HLL U4,$ARTYP(U4) ; and set up type bits + PJRST UXRST] ; and go reset area. +] + RET + +OICLS: +OXCLS: HRRZ U1,UCHTYP(OC) ; Get channel type + CALL @OXCLST(U1) ; Do whatever needed for specific type +OXCLS7: MOVEI U1,UCNTS(OC) + MOVEM U1,UCHCNT(OC) ; Set safe address for count (not zero!!!) + MOVE U1,[CALL OBADCH] + MOVEM U1,UCOPT(OC) ; Store unit-mode instruction + MOVEM U1,USCOPT(OC) ; and string-mode rtn addr. + SETZM UCHTYP(OC) ; Make channel type "closed" (actually UAR, +IF2 IFNDEF APOPJ,APOPJ: + RET ; but what to do? Set -1?) + +OXCLST: APOPJ ; Area + APOPJ ; XCT + APOPJ ; BPT + OCCLS ; IOT + OXCLS3 ; BUF + APOPJ ; Transl. + APOPJ ; NUL + APOPJ ; SAO +IFN UC$NO-<.-OXCLST> .ERR OXCLST table loses + +OXCLS3: +IFE $$OBUF, JSR AUTPSY +IFN $$OBUF,[ ; Buffered output close. + CALL UFRCBF ; Buffered, must force out vestiges. + MOVE U3,UCHTYP(OC) ; Now get flags in LH + HLRZ U1,UCHLIM(OC) ; and buffer addr in U1 + TLNE U3,UC%DBF ; Dynamically allocated buffer? + CALL CORREL ; Yup, must release it! + ; Now drop thru to call OCCLS and proceed. +] + +OCCLS: +IFN OS%ITS,{SYSCAL CLOSE,[OC] ? JSR AUTPSY } +IFN OS%TNX,{ + PUSH P,1 + HRRZ 1,UCHJFN(OC) + CLOSF + ERJMP .+1 + POP P,1 +} + RET + +OBADCH: JSR AUTPSY ; Output attempted on closed channel. + RET + +; IO Channel "PDL" - PUSH, POP, POPALL + +IFN UAREAS,[ +.SCALAR IOPDLP ; Address of ARBLK for IOPDL area. +.SCALAR IOPCNT ; # of channels pushed. + +OXPUSH: ; Save channel vars + SKIPN U4,IOPDLP ; Get address of ARBLK + JRST [ UAROPN U4,[0 ? [200]] ; Must create, so make one. + HRRZM U4,IOPDLP + SETZM IOPCNT + JRST .+1] + AOS IOPCNT + HRRZ U1,$ARWPT(U4) ; Get write ptr, + HRRZ U3,$ARTOP(U4) ; and 1st non-ex addr, + CAIL U1,-$OCFRM(U3) ; and ensure enough room. + JRST [ MOVEI U4,$OCFRM + UAREXP U4,@IOPDLP ; Expand the area. + MOVE U4,IOPDLP ; Restore ARPT + HRRZ U1,$ARWPT ; Restore write ptr. + JRST .+1] + ADD U1,[1,,-1] ; Avoid PDLOV interrupt overhead and get ptr. +%%OCNT==. + IRP LOC,,[UCOPT,USCOPT,UCHCNT,UCNTS,UCHLIM,UCHTYP,UCHSTB] + PUSH U1,LOC(OC) + TERMIN +IFN OS%TNX,PUSH U1,UCHJFN(OC) +$OCFRM==:<.-%%OCNT> ; Get # wds per frame. + ADDI U1,1 + HRRZM U1,$ARWPT(U4) ; Store new write ptr. + + HRRZ U1,UCHTYP(OC) + CAIE U1,UC$IOT + CAIN U1,UC$BUF + CAIA + CALRET OXCLS7 +IFN OS%ITS,[ + MOVE U1,[.IOPUSH] + DPB OC,[$ACFLD,,U1] + XCT U1 +] + CALRET OXCLS7 ; Softwarily close channel. + + + CALL OXPOP +OXPDLR: SKIPLE IOPCNT + JRST .-2 + UARCLS @IOPDLP + SETZM IOPDLP + RET + +OXPOP: SOSGE IOPCNT + JSR AUTPSY + CALL OXCLS ; Close channel currently in slot. + ; Restore channel vars. + SKIPN U4,IOPDLP + JSR AUTPSY ; Attempt to pop empty stack... + MOVE U1,$ARWPT(U4) + SUB U1,[1,,1] +IFN OS%TNX,POP U1,UCHJFN(OC) + IRP LOC,,[UCHSTB,UCHTYP,UCHLIM,UCNTS,UCHCNT,USCOPT,UCOPT] + POP U1,LOC(OC) + TERMIN + ADDI U1,1 + HRRZM U1,$ARWPT(U4) + + ; Fix up channel vars in case popped into different channel. + HRRZ U3,UCHTYP(OC) + JRST @.+1(U3) +%%OTMP==. + OXPUAR + OXPXCT + OXPBPT + OXPIOT + OXPBUF + OXPTRN + OXPNUL +IFN <.-%%OTMP>-UC$NX, .ERR UXPOP table loses + +OXPBUF: +OXPIOT: +IFN OS%ITS,[ + DPB OC,[$ACFLD,,UCOPT(OC)] ; Set up new chan for unit-mode .IOT + MOVE U1,[.IOPOP] + DPB OC,[$ACFLD,,U1] + XCT U1 ; Pop back hardware channel. +] + CAIE U3,UC$BUF + JRST OXPNUL +OXPBPT: MOVEI U1,UCHSTB(OC) + HRRM U1,UCOPT(OC) +OXPXCT: +OXPNUL: MOVEI U1,UCNTS(OC) + MOVEM U1,UCHCNT(OC) +OXPUAR: +OXPTRN: + RET + +] ; IFN UAREAS + +SUBTTL OUT - Formatting routines + +OXFLD: JSP U4,@U3 ; Call routine + JRST OXFST1 ; Return vectors according to # params. + JRST OXFST2 + JRST OXFST3 + +BVAR +UFFLG: 0 ; If -1, format params in effect. +UFWID: 0 ; If non-z, specifies a field width. +UFPREC: 0 ; Specifies "precision" for strings & floating output +UFFILL: -1 ; Fill char, defaults to neg (meaning blank). +UFSCNT: 0 ; Saved channel char cnt +UFSCHN: 0 ; Saved channel # +EVAR + +OXFST1: HRLOI U3,377777 ; Specify width only. Set prec to max. +OXFST2: SETO U4, ; Specify width & prec only. Set fill char to blank. +OXFST3: MOVEM U4,UFFILL ; Set fill + MOVEM U3,UFPREC ; Set prec + MOVEM U1,UFWID ; Set width + SETOM UFFLG ; Say hacking format parameters. + + ; Set up channel for temporary buffer storage + MOVEM OC,UFSCHN ; Save current channel, and + MOVEI OC,UFLDC ; substitute "field" channel. + SKIPN UCOPT(OC) ; Make sure something there... + OUTCAL(,OPEN(UC$BPT,0,[$LUBUF])) ; If not, open it with limit. + MOVE U1,[440700,,UFBUF] + MOVEM U1,UCHSTB(OC) ; Reset write-pointer + SKIPL U1,UFPREC ; Use desired limit. If negative, + CAILE U1,$LUBUF ; or too large, + MOVEI U1,$LUBUF ; use maximum. + MOVNM U1,UCNTS(OC) ; Reset byte countdown to limit. + MOVNM U1,UCHLIM(OC) ; And save limit being used. + RET + + + ; Finalize formatting... called when output done. +OXFDON: SETZM UFFLG ; Turn off formatting. + CAIE OC,UFLDC ; Make sure channel is correct one. + JSR AUTPSY ; Got zapped in meantime!!?? + MOVE U1,UCNTS(OC) ; Get resulting byte countdown + SUB U1,UCHLIM(OC) ; <-max + cnt> - <-max> = <# chars written> + MOVE OC,UFSCHN ; Now can restore previous channel. + SKIPL U3,UFWID ; What sort of justification? + JRST OXFRD ; Right justifying. + + ; Left justifying, so output buffer, then fill. + ADD U3,U1 ; <# chars written> + - + PUSH P,U3 ; Save -<# pads> + SKIPG U4,U1 ; Set up <# chars> for output + JRST OXFDL3 ; Nothing to output? + MOVE U3,[440700,,UFBUF] + CALL @USCOPT(OC) ; Output buffered stuff to real channel. +OXFDL3: POP P,U4 ; Restore -<# pads> + JUMPGE U4,[RET] ; If no fill needed, return. + MOVM U4,U4 ; Get <# pads> + SKIPGE U1,UFFILL ; If strange fill char, + CAIL U4,$LBSTR ; or filling more than is reasonable, + JRST OXFDF ; jump to handle special case. + MOVE U3,[440700,,UBLSTR] ; Normal case will efficiently + PJRST @USCOPT(OC) ; output string of padding blanks and return. + + ; Finalize right-justified string... +OXFRD: PUSH P,U1 ; Save <# chars written> + SUB U1,U3 ; Find -<# pads to prepend> + JUMPGE U1,OXFDR4 ; Jump if none; can simply output stuff. + SKIPGE UFFILL ; If strange fill char, + CAMGE U1,[-$LBSTR] ; or too much padding, + JRST OXFDR3 ; do it hard way. + MOVE U3,[440700,,UFBUF] + MADBP7 U3,U1 ; Adjust BP in U3 by cnt in U1 + POP P,U4 + SUB U4,U1 ; <# writ> - <- # pad> = total to write out + PJRST @USCOPT(OC) ; Output string of blanks AND data together!! + +OXFDR3: MOVM U4,U1 ; Move <# pads> to right place + CALL OXFDF ; Output fill chars one at a time. +OXFDR4: POP P,U4 ; Restore # chars written originally + MOVE U3,[440700,,UFBUF] ; Point at field buffer + JUMPG U4,@USCOPT(OC) ; Output and return. + RET + +OXFDF: SKIPGE U1,UFFILL ; If fill char negative, + MOVEI U1,40 ; means regular blank. +OXRPTC: STDOUT ; Repeatedly output byte... + SOJG U4,OXRPTC + RET + +BVAR +$LBSTR==5*30. ; # blanks in filler buffer +UBLSTR: .BYTE 7 + REPEAT $LBSTR,40 + .BYTE ; Note buffers contiguous!! + + $LUBUF==$LBSTR ; # chars avail in field-adjusting buffer +UFBUF: BLOCK <$LUBUF+4>/5 +EVAR + +SUBTTL OUT - Basic output routines + +; Item C(char) - Output byte + +OXC: STDOUT ; Direct entry pt (if needed) + RET + + +; Items EOL,CRLF,TAB,SP - Output specific chars + +OXCRLF: +OXEOL: STDOUT(^M) + STDOUT(^J) + RET +OXTAB: SKIPA U1,[^I] ; For convenience. +OXSP: MOVEI U1,40 ; Ditto + STDOUT + RET + +; Item TZ([asciz]) - Output ASCIZ string + +OXZA: HRLI U3,440700 ; form byte ptr + JRST OXZ ; Jump into loop + +; Item PZ([bp]) - Output BYTEZ string + +OXZ1: STDOBP ; Output byte (BP in U3 in case count out) +OXZ: ILDB U1,U3 ; Get input byte + JUMPN U1,OXZ1 ; Loop til hit zero byte. + RET + +; Item PC([#,,[bp]) - Crock kept for compatibility + +OXPC: HLRZ U4,U3 ; Direct entry - get cnt + MOVE U3,(U3) ; Get the bp + JUMPN U4,@USCOPT(OC) ; Dispatch + RET + +; Item TC([#,,[asciz]]) - Output ASCNT string + +OXTC: HLRZ U4,U3 ; Get cnt + HRLI U3,440700 ; Form BP in U3 + JUMPG U4,@USCOPT(OC) ; Dispatch + RET + +; Item TS([,,# ? bp]) - Output byte string var + +OXS: HRRZ U4,(U3) ; Get byte cnt + MOVE U3,1(U3) ; Get byte ptr + JUMPG U4,@USCOPT(OC) ; Jump into output rtn + RET ; Return if null string. + +SUBTTL OUT - Sixbit output + +; Item 6W(aval) - Output val as 6 SIXBIT chars + +OX6W: MOVE U4,[440600,,U3] +OX6W1: ILDB U1,U4 ; Get 6bit char + ADDI U1,40 ; Convert to ASCII + STDOUT ; Output + TLNE U4,770000 ; BP counted out yet? + JRST OX6W1 + RET + +; Item 6F(aval) - Output val as SIXBIT with no trailing spaces + +OX6F: SETZ U4, ; Direct calling sequence SKIPE U3,ARG ? CALL OX6F + ROTC U3,6 + STDOUT(40(U4)) + JUMPN U3,OX6F + RET + +; Item 6Q(aval) - Output val as SIXBIT like 6F, but quotes punctuation with ^Q + +OX6Q: SETZ U4, + ROTC U3,6 ; Get next character in 6bit + CAIN U4,'- ; If other than letter, number, or hyphen + JRST OX6Q3 ; will need a ^Q to quote it. + CAIL U4,'0 + CAILE U4,'Z + JRST OX6Q2 + CAILE U4,'9 + CAIL U4,'A + JRST OX6Q3 +OX6Q2: STDOUT(^Q) +OX6Q3: STDOUT(40(U4)) + JUMPN U3,OX6Q + RET + +SUBTTL OUT - Numerical output + +; Item O(aval) - Octal +; Item D(aval) - Decimal +; Item X(aval) - Hexadecimal + +OXN10.: MOVEI U1,10. + CALL OXNTYP + STDOUT(".) + RET + +OXNTY5: MOVM U3,U3 ; Negative, print minus sign. + MOVE U4,U1 ; Save radix + STDOUT("-) + MOVE U1,U4 ; Restore radix + JRST OXNTY1 + + ; Direct call entry points to numerical typeout rtn. +OXN16: MOVEI U1,16. ? JRST OXNTYP +OXN8: SKIPA U1,[8.] +OXN10: MOVEI U1,10. + +OXNTYP: JUMPL U3,OXNTY5 ; Go print minus sign. +OXNTY1: IDIVI U3,(U1) + JUMPE U3,OXNTY2 + HRLM U4,(P) ; save digit on stack. + PUSHJ P,OXNTY1 + HLRZ U4,(P) +OXNTY2: CAILE U4,9. + SKIPA U1,-10.(U4)+["A ? "B ? "C ? "D ? "E ? "F] ; For hex output + MOVEI U1,"0(U4) ;put char in u1 + STDOUT + POPJ P, + +SUBTTL OUT - Halfword output + +; First, experimental Item W(aval) - outputs a single 36 bit word. +; WLH(aval) and WRH(aval), ditto for halfwords. +; The user could call STDOUT directly, but this way he can +; include it from an OUT macro call too. + +OXWD: MOVE U1,U3 ; Fetch arg. + STDOUT ; Output it. + RET ; What could be simpler? + + +; Item RH(aval) - Output RH of arg as 6 octal digits +; Item LH(aval) - ditto for LH +; Item HWD(aval) - LH,,RH + +OXHWD: PUSH P,U3 + CALL OXLH + POP P,U3 + STDOUT(54) ; Comma + STDOUT(54) + CALRET OXRH + +; Item HV(aval) - Output val as LHV,,RHV (positive octal values) +; Item HS(aval) - Output val as LHS,,RHS (signed octal values) + +OXHV: PUSH P,U3 + HLRZ U3,U3 + CALL OXN8 + POP P,U3 + STDOUT(54) + STDOUT(54) + HRRZ U3,U3 + CALRET OXN8 + +OXHS: PUSH P,U3 + HLRE U3,U3 + CALL OXN8 + POP P,U3 + STDOUT(54) + STDOUT(54) + HRRE U3,U3 + CALRET OXN8 + +OXLH: HLRZ U3,U3 ; Somewhat useless since can just setup arg to + ; call OXRH directly, but for completeness... + +OXRH: MOVE U4,[220300,,U3] ; Set up BP, 6 bytes of 3 bits. +OXRH1: ILDB U1,U4 + STDOUT("0(U1)) ; Convert & output + TLNE U4,770000 ; BP counted out yet? + JRST OXRH1 + RET + + +; Item WBA (output Ackermans?) a cross between W and TC. +; WBA([#,,[asciz]]) - Output ascnt string in binary + +OXWBA: HLRZ U4,U3 ; Get cnt + HRLI U3,440700 ; Form BP in U3 + JUMPG U4,@USCOPT(OC) ; Dispatch + RET + + + + +SUBTTL OUT - Floating-point output +IFN $$OFLT,[ + +.SCALAR OFLTFS ; Indicates type of output. - E, + F, 0 G. +FLT%FE==400000,,0 +FLT%FF==200000,,0 + +IFNDEF E,E=:D+1 +IFGE E-U1, .ERR ACs will lose for floating output! + +OXNE: SKIPA U1,[OUT"FLT%FE] ; E format, m.nnnnnE+ee +OXNF: MOVEI U1,OUT"FLT%FF ; F format, mmm.nn + PJRST OXNFL + +OXNG: SETZ U1, ; G format; F if within range, else E. Maximum prec. + +OXNFL: PUSHAE P,[A,B,C,D,E,OFLTFS] + MOVEM U1,OFLTFS ; Set flags to use + PUSHJ P,UNFO + POPAE P,[OFLTFS,E,D,C,B,A] + RET + +; This routine adapted from that in MACLISP. + +UNFO: SKIPL A,U3 + JRST UFP1 + STDOUT("-) + MOVN A,U3 +UFP1: SKIPLE OFLTFS ; If want F-format, + JRST UFP1F ; Go straight to it. + SETZB B,D ; For E-fmt, B holds add'l signif bin digits + CAMGE A,[.01] ; and D is exponent sign indicator + JRST UFP4 ; D=0 => negative exponent [x < 1.0e-2] + CAML A,[1.0^8] + AOJA D,UFP4F ; D=1 => positive exponent [x > 1.0e+8 - 1] + SKIPGE OFLTFS ; Made it, can use F fmt, but is E required? + JRST [ CAMGE A,[1.0] ; Yes, test to get exponent sign. + JRST UFP4 ; Neg exp + AOJA D,UFP4F] ; Pos exp + + ; "F" format. "G" comes here for 1.0e-2 <= x < 1.0e8 +UFP1F: CAMGE A,[1.0] ; First find -<# digits to right of point.> + JRST [ MOVNI E,10. + CAML A,[.1] ; .1 <= x < 1.0 + JRST UFP3 + SOJA E,UFP3] ; .01 <= x < .1 + PUSHJ P,UFPL10 ; <# digits to left of .>+1 will now be in E + SUBI E,9. ; Get -<# digits to right.> +UFP3: SETZB B,C + ASHC A,-27. ; Split exponent part off + ASHC B,-243(A) ; Split number into integral and fract part + + MOVE U3,B ; Output integer part + PUSHJ P,OXN10 + STDOUT(".) + + MOVE B,C ; Move fract part + MOVM D,E ; D now holds # digits to print to right of . + MOVSI E,200000 ; Compute position of last significant bits + ASH E,-243+1+<43-27.>(A) + SKIPE U4,UFFLG ; Format params in effect? + MOVN U4,UFPREC ; Yes, get precision (# columns to right of .) +UFP3A: MOVE A,B + MULI A,10. + IMULI E,10. + CAMGE B,E + JRST UFPX0 + MOVN C,E + TLZ C,400000 + CAMLE B,C + AOJA A,UFPX0 ; Last sig digit, but round upwards + ; Note only truncate when U4 was positive to start with. + SOJE U4,[TLNE B,200000 ; If forcing last digit, round upwards. + CAIL A,9. ; Round. This is a KLUDGE check since + JRST UFPX0 ; can't carry the roundup further (digits + AOJA A,UFPX0] ; already output). Oh well. + STDOUT("0(A)) + CAIN D,2 ; On ninth output digit, use only half a digit + ASH E,-1 ; for end-of-precision test + SOJG D,UFP3A + JUMPG U4,UFPX1 + POPJ P, ; Last significant digit, so stop + +UFPX0: STDOUT("0(A)) + SOJG U4,UFPX1 ; Skip if precision not done yet. + RET +UFPX1: MOVEI U1,40 ; Need to pad out. Default filler is space, + SKIPGE OFLTFS ; but if doing E fmt, + MOVEI U1,"0 ; then pad with zeros instead. + CALRET OXRPTC ; Go pad out. + + +; ----------- Here for "E" format ------------------- + +UFP4: JUMPN A,UFP4F ; Floating point "E" format + STDOUT("0) + STDOUT(".) + STDOUT("0) + SKIPE U4,UFFLG + MOVN U4,UFPREC ; If formating, get precision. + SOJG U4,UFPX1 ; If must space out, do so. + POPJ P, + +UFP4F: MOVEI E,1 + JUMPE D,UFP4E ; Jump out if negative exponent. +UFP4E0: FDVL A,UFP10.0 ; Double-prec div by 10.0 until + FDVRI A+1,(10.0) ; quotient is < 10.0 + FADL A,A+1 + CAML A,UFP10.0 + AOJA E,UFP4E0 + JRST UFP4B + +UFP4E: FMPRI A+1,(10.0) + MOVEM A+1,A+2 ; Double-precision mul by 10.0 until + FMPL A,UFP10.0 ; product is >= 1.0 + UFA A+1,A+2 ; Keeping count in E + FADL A,A+2 + CAMGE A,UFP1.0 + AOJA E,UFP4E + +UFP4B: PUSH P,E ; Save exponent + PUSH P,(D)["- ? "+] ; Save sign of exponent + SETZ B, + MOVNI E,8. + MOVSI U4,(FLT%FE) ; Indicate hacking E format. + IORM U4,OFLTFS + PUSHJ P,UFP3 ; Num has been normalized for 1.0 <= x < 10.0 + + STDOUT("E) + POP P,U1 ; Restore sign char + STDOUT ; Output it. + POP P,U3 ; Restore exponent value + CAIL U3,100. ; Shouldn't be possible to exceed, but... + PJRST OXN10 ; hack more than 2 digits in exponent. + IDIVI U3,10. + STDOUT("0(U3)) ; Always use 2 digits in output. + STDOUT("0(U4)) + POPJ P, + +UFPL10: MOVEI E,8 + CAMGE A,UFP1.0-1(E) + SOJG E,.-1 + POPJ P, + +UFP1.0: REPEAT 8,1.0^.RPCNT +UFP10.0=UFP1.0+1 + +] ;end IFN $$OFLT + +SUBTTL C-style PRINTF routine + +IFN $$OPRF,[ +; PRINTF for the OUT package. This code was mostly done for the hell +; of it -- it is considerably less efficient than simply using the OUT +; macro directly! + +; The following description is taken almost verbatim from "The C Programming +; Language" by Kernighan and Ritchie, 1978, p. 145-146. +; The PRINTF control string is composed of ordinary chars (which are output +; as-is) and conversion specifications. Each conversion spec is introduced +; by the char "%" and ended by a conversion char. Between the % and the +; conversion char there may be: +; A minus sign, which specifies left adjustment of the converted arg +; in its field. +; A digit string specifying a minimum field width. The converted +; number will be printed in a field at least this wide, and +; wider if necessary. If the converted arg has fewer chars +; than the field width it will be padded on the left (or +; right, if the left adjustment indicator has been given) to +; make up the field width. The padding char is blank normally +; and zero if the field width was specified with a leading zero +; (this zero does not imply an octal field width). +; A period, which separates the field width from the next digit string. +; A digit string (the precision), which specifies the maximum number +; of chars to be printed from a string, or the number of digits +; to be printed to the right of the decimal point of a FLOAT +; or DOUBLE. +; A length modifier "l" which indicates that the corresponding data +; item is a LONG rather than an INT. + +; The conversion chars and their meanings are: +; d - The arg is converted to decimal notation. +; o - The arg is converted to unsigned octal notation (without a leading +; zero). +; x - The arg is converted to unsigned hexadecimal notation (without a +; leading 0x). +; u - The arg is converted to unsigned decimal notation. +; c - The arg is taken to be a single char. +; s - The arg is a string; chars from the string are printed until a +; null char is reached or until the number of chars indicated +; by the precision specification is exhausted. +; e - The arg is taken to be a FLOAT or DOUBLE and converted to decimal +; notation of the form [-]m.nnnnE[-+]xx where the length of the +; string of n's is specified by the precision. The default +; precision is 6. +; f - The arg is taken to be a FLOAT or DOUBLE and converted to decimal +; notation of the form [-]mmm.nnnn where the length of the string +; of n's is specified by the precision. The default precision is +; 6. Note that the precision does not determine the # of +; significant digits printed in F format. +; g - Use %e or %f, whichever is shorter; non-significant zeros are not +; printed. + +; If the char after the % is not a conversion char, that char is printed; +; thus % may be printed by %%. + +DEFINE PRINTF (CH,&STR&,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P) + IFNB [CH]{ PUSH P,OC ? MOVEI OC,CH } + MOVEI U1,[ASCIZ STR] + MOVEI U3,[A ? B ? C ? D ? E ? F ? G ? H ? I ? J ? K ? L ? M ? N ? O ? P] + CALL OXPNTF + IFNB [CH]{ POP P,OC } +TERMIN + +OXPNTF: HRLI U1,440700 + PUSH P,U1 + TLO U3,(@) ; Turn on the indirect bit in arg pointer + PUSH P,U3 + JRST OXPT10 + +OXPT05: STDOUT +OXPT10: ILDB U1,-1(P) ; Get char from string + CAIN U1,"% + JRST OXPT20 ; Special escape char, hack it. + JUMPN U1,OXPT05 +OXPT90: SUB P,[2,,2] ; End of string, done! + RET +OXPT15: AOS (P) ; Done with one arg, point to next. + JRST OXPT10 + + ; Handle special escape within string! + ; Need the following vars: + ; Minus-sign flag + ; Padding-char value (blank or 0) + ; Field-width value + ; Precision value + ; Possible argtype indicator (L, indirect, immediate etc) +OXPT20: SETZB U3,U4 ; Clear minus,,pad and field width + ILDB U1,-1(P) ; Get next char (indicating type) + CAIN U1,"- ; Minus sign? + JRST [ TLO U3,(SETZ) ; Use negative field + ILDB U1,-1(P) ; and get another char. + JRST .+1] + CAIE U1,"0 ; First digit a 0? + HRRI U3,40 ; No, so use blank for pad-char. +OXPT22: CAIL U1,"0 + CAILE U1,"9 + JRST OXPT25 ; Jump when done with field-width arg + IMULI U4,10. + ADDI U4,-"0(U1) + ILDB U1,-1(P) + JRST OXPT22 + +OXPT25: TLZE U3,(SETZ) ; If minus was given, + MOVNS U4 ; make field width negative. + PUSH P,U3 ; Save fill char value + SETZ U3, ; Clear val of prec field + CAIE U1,". + JRST OXPT30 ; No precision field +OXPT26: ILDB U1,-2(P) ; Get next char (note stack index changed) + CAIL U1,"0 + CAILE U1,"9 + JRST OXPT30 ; Jump when done with precision arg + IMULI U3,10. + ADDI U3,-"0(U1) + JRST OXPT26 + + ; (P)/ pad char + ; U4/ field width (0 if none) + ; U3/ precision (0 if none) + ; U1/ break char (either the modifier or the conversion char) +OXPT30: CAIE U1,"l ; For now, ignore all arg modifiers. + CAIN U1,"L + JRST [ILDB U1,-2(P) + JRST .+1] + + ; Now have conversion char in U1. Make uppercase. + JUMPE U1,[POP P,U1 ? JRST OXPT90] ; Fail here if string gone. + CAIL U1,"a + CAILE U1,"z + CAIA + TRO U1,40 + CAIN U3, + JUMPE U4,[SETZM (P) ; Jump if no field specs whatsoever. + JRST OXPT40] + ; Hacking field formatting! + CAIE U1,"S ; Unless type is S, + MOVNS U3 ; Ensure precision (if any) is negative! + EXCH U1,U4 ; Get field width in U1, + EXCH U4,(P) ; pad char in U4, and conversion char in (P) + CAIN U1, ; If no width given, + HRLOI U1,377777 ; Use maximum. + CAIN U3, ; If no prec given, + MOVNI U3,6 ; Likewise specify max (for numbers, default 6) + CALL OXFST3 ; Set up field output stuff! + SETO U1, + EXCH U1,(P) ; Say we're formatting! + + ; (P)/ non-zero if formatting + ; U1/ conversion char +OXPT40: CAIN U1,"C ; C - Output char value + JRST [ MOVE U1,@-1(P) + JRST OXPT69] + CAIN U1,"S ; S - Output an ASCIZ string. + JRST [ MOVE U3,@-1(P) + TLCE U3,-1 ; If all zeros, skip + TLCN U3,-1 ; If all ones, don't skip + HRLI U3,44070 ; If LH is 0 or -1, substitute this. + CALL OXZ ; Output zero-terminated byte string + JRST OXPT70] + CAIN U1,"D ; D - Output decimal value + JRST [ MOVE U3,@-1(P) + CALL OXN10 + JRST OXPT70] + CAIN U1,"O ; O - Output octal value + JRST [ MOVE U3,@-1(P) + CALL OXN8 + JRST OXPT70] + CAIN U1,"X ; X - Output hexadecimal value + JRST [ MOVE U3,@-1(P) + CALL OXN16 + JRST OXPT70] + CAIN U1,"U ; U - Output unsigned decimal value + JRST [ SKIPL U3,@-1(P) + JRST [ CALL OXN10 + JRST OXPT70] + LSHC U3,-35. + LSH U4,-1. ; Get low 35 bits in U4, high bit in U3 + DIVI U3,10. ; Get quotient in U3, rem in U4 + PUSH P,U4 + CALL OXN10 ; Output all but last decimal digit + POP P,U3 ; Restore last digit value + ADDI U3,"0 ; Make ASCII + JRST OXPT69] ; Output and done. + + CAIN U1,"E ; E - Output floating point + JRST [ MOVE U3,@-1(P) + CALL OXNE + JRST OXPT70] + CAIN U1,"F ; F - Output floating point + JRST [ MOVE U3,@-1(P) + CALL OXNF + JRST OXPT70] + CAIN U1,"G ; G - Output floating point + JRST [ MOVE U3,@-1(P) + CALL OXNG + JRST OXPT70] + + ; No match, illegal type spec... just output it! + SOS -1(P) ; Decrement count to nullify later increment. +OXPT69: STDOUT ; Output char + +OXPT70: POP P,U1 ; Pop format indicator off stack. + JUMPE U1,OXPT15 ; Back to normal loop! + CALL OXFDON ; We were formatting, wrap up. + JRST OXPT15 +] ;IFN $$OPRF + +SUBTTL Various special item output + +IFN UAREAS,[ + +OXAR: SKIPN $AROPN(U1) ; Make sure it's open. + RET ; Just return if it isn't. + MOVE U3,$ARWPT(U1) ; Get write pointer (end of used area) + SUB U3,$ARLOC(U1) ; Make relative to beg + MULI U3,5 ; do bp hack + ADD U4,UADBP7(U3) ; Get # chars. + MOVE U3,$ARLOC(U1) ; Now cons up a BP to start. + HRLI U3,440700 + JUMPG U4,@USCOPT(OC) ; Finally dispatch to string output, + RET ; unless nothing to output. +] ;IFN UAREAS + +IFN ULISTS,[ + +; Item TLS(slp) - Output string that SLP points to + +OXLS: +OXSL: ; Preferred label. +IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet. +.ELSE MOVE U3,LISTAR(U3)+1 ; Get its SPT. + HLRZ U4,U3 ; Get count. + ADD U3,$LSLOC(L) ; Make address absolute + HRLI U3,440700 ; and turn into a BP. + JUMPG U4,@USCOPT(OC) ; Jump into output loop if anything there. + RET ; Else no-op. + + ; List-String relative to specific LSE. + ; U1 - addr of LSE + ; U3 - SLP to SLN within that LSE. +OXSLA: EXCH L,U1 ; For addressing purposes... +IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet. +.ELSE MOVE U3,LISTAR(U3)+1 ; Get the SPT. + ADD U3,$LSLOC(L) ; Make address absolute. + MOVE L,U1 ; Restore original L. + HLRZ U4,U3 ; Get count, + HRLI U3,440700 ; make BP, + JUMPG U4,@USCOPT(OC) ; and off to output it. + RET + +] ;IFN ULISTS + +; UC$SAO output type - replaces old SAOBEG UUO. +; Initializes for standard UUO output into SA area; argument is +; a LSE pointer, e.g. OPEN(UC$SAO,$ARLOC+MSGAR) or OUTOPN CH,[$UCSAO,,L]. +; The %LTSAO type bit in MAKELN will form a string LN of accumulated +; output. + +UOPNSA: +IFE ULISTS, JSR AUTPSY +.ELSE [ SKIPN U4,@(U3) ; Get pointer to LSE + MOVE U4,L ; If none specified, use current LSE. + MOVE U1,$LSFRE(U4) + ADD U1,$LSLOC(U4) ; Get abs start addr + HRLI U1,440700 ; Form BP + MOVEM U1,$LSWPT(U4) ; and set up new write ptr for area. + MOVEI U1,(U1) + SUB U1,$LSTOP(U4) ; Get -<# wds left> + IMULI U1,5 + MOVEM U1,$LSCHL(U4) ; Store as $ARCHL for SA. + + MOVEI U4,$LSAR(U4) ; Finally get pointer to string-area ARPT. + MOVEI U1,UC$UAR ; Replace channel type with normal area. + MOVEM U1,UCHTYP(OC) + PJRST UOPNA1 ; Dispatch to complete normal area-open. + +] ;IFN ULISTS + +SUBTTL ERR item output +IFN $$OERR,[ + +; Code for ERR output type. +; Arg is error #. +; If arg -1, use "last error". + +; Include crocks for compatibility with old kludge. +ERRMOA: SKIPA U3,A +ERRMO: SETO U3, + PUSH P,OC + MOVEI OC,(B) + CALL OXERR + POP P,OC + RET + +; Item ERR(val) - Output system error string for given error # +; If no val or -1 specified, use last syscal error. + +OXERRL: MOVE U3,[-1] ; Entry pt to use last error +OXERR: +IFN OS%ITS,[ + MOVEI U4,4 ; Assume # specified, + CAIGE U3, ; But if want "last error", + MOVEI U4,1 ; ask system for that. +IFNDEF ERRCHN,.ERR ERRCHN must be defined for $$OERR to work. + SYSCAL OPEN,[CIMM ERRCHN + [SIXBIT/ERR/] ? U4 ? U3 ] + JRST [ MOVEI U3,[ASCIZ "?? Can't get error msg from ERR device ??"] + PJRST OXZA] +OXERR2: .IOT ERRCHN,U1 + CAIGE U1,40 + JRST [ .CLOSE ERRCHN, + RET ] + STDOUT + JRST OXERR2 +] ;END IFN ITS + +IFN OS%TNX,[ + PUSHAE P,[1,2,3] + MOVEI 2,(U3) + HRLI 2,.FHSLF ; 2 = ,, + MOVSI 3,-UERBFL ; 3 = -<# chs>,, + HRROI 1,UERBUF ; 1 = -1,, + ERSTR ; Get error string + ERJMP [MOVEI U3,[ASCIZ //] + JRST OXERR5] + JRST [ MOVEI U3,[ASCIZ //] + JRST OXERR5] + SETZ 3, + IDPB 3,1 + MOVEI U3,UERBUF +OXERR5: POPAE P,[3,2,1] + PJRST OXZA + +UERBFL==140. ; Max # chars in err msg +.VECTOR UERBUF(/5) +] ;END IFN TNX + +];end IFN $$OERR + +SUBTTL Host name/number output + + +; NOTE: this code now assumes addresses are in HOSTS3 format! + +; Item HN(aval) - Output host num in octal (single #) +; Item HND(aval) - Output host num in decimal (Internet fmt) + +OXHN: CALRET OXN8 ; Simply output in octal + +OXHND: PUSH P,U3 +IF1, BLOCK 3 +IF2 [ IFDEF NETWRK"CVH3NA, EXCH A,(P) ? CALL NETWRK"CVH3NA ? EXCH A,(P) + .ELSE JRST .+3 ? JRST 4,. ? JRST 4,. +] + TLNE U3,(17_32.) ; Internet address? + JRST [ LDB U3,[.BP <17_32.>, (P)] ; No, so exhibit high 4 bits. + CALL OXN8 ; Note octal! + STDOUT(":) + JRST .+1] +REPEAT 4,[ + IFN .RPCNT, STDOUT(".) + LDB U3,[.BP <377_<8.*<3-.RPCNT>>>, (P)] + CALL OXN10 +] + POP P,U3 + RET + +IFN $$OHST,[ + +; Item HST(aval) - Output host name for given address (else number) + + LSQBR==:133 ; "[" character + RSQBR==:135 ; "]" character + +OXHST: + ; Special hack for COMSAT only... host number 0 means self. +IFN OS%ITS,IFE .FNAM1-, CAIN U3, ? MOVE U3,OWNHST + CALL OXHOST ; Output host name if possible + SKIPA ; Not possible + RET ; Won + STDOUT(LSQBR) ; Do it as "[a.b.c.d]" format + CALL OXHND ; since this is supposed to be a hostname. + STDOUT(RSQBR) + RET + +; Item HOST(aval,{altitm}) - Output host name and skip, else no skip +; so that alternate item is output instead. + +OXHOST: +IFN OS%ITS,[ + PUSHAE P,[A,B,D] ;clobbered by HSTSRC routine + MOVE B,U3 + ;; Make A point to ASCIZ name. + +IFE $$DQ,{ ; Not doing DQ: device hackery + +IF2, IFNDEF NETWRK"HSTSRC,.FATAL Missing NETWRK but $$OHST is on! + + CALL NETWRK"HSTSRC + JRST OXHST4 ; Lookup failed, take nonskip return. +} +.ELSE { ; Are doing DQ: hacking + +IF2, IFNDEF RESOLV"HSTSRC,.FATAL Missing RESOLV but $$OHST and $$DQ are on! + + MOVE A,[440700,,HSTBUF] ;A has dest, B has host address. + CALL RESOLV"HSTSRC + JRST OXHST4 + MOVE A,[440700,,HSTBUF] +} ; Done with DQ: hacking + + MOVEI U3,(A) + CALL OXZA + AOS -3(P) ; Won, so skip on return. +OXHST4: POPAE P,[D,B,A] + RET + +.VECTOR HSTBUF(24.) ;Buffer to hold host name string from RESOLV. + +] ;IFN ITS + + + +IFN OS%TNX,[ +UHSTBL==20. ; Allow hostname up to 99. chars long + PUSHAE P,[1,2,3,4] + MOVEI 1,.GTHNS ; Number to Name + HRROI 2,1(P) ; Dest string ptr + ADD P,[UHSTBL,,UHSTBL] ; Make room on PDL + MOVE 3,U3 + GTHST + JRST OXHST6 ; Lost, take nonskip return. + MOVEI U3,-(P) + CALL OXZA + AOS -<4+UHSTBL>(P) ; Won, take skip return. +OXHST6: SUB P,[UHSTBL,,UHSTBL] + POPAE P,[4,3,2,1] + RET + +] ;IFN TNX +] ;IFN $$OHST + + + + + +SUBTTL Time Output + +IFN $$OTIM,[ +; Requires that DATIME package be .INSRT'd someplace; +; The external defs needed from it include: +; (ITS) TIMADY - rtn to cvt sys-int timeword to abs (used for finding DOW) +; (ITS) TIMGET - rtn to get current sys-int time, with DST bit set. +; (ITS) TMONTB - table of month names + + ; Sub-types for "TIM" output item. Up to 4 letters significant. + ; YOU try to think of better names for F1, F2, etc!! +DEFT HMS,OXTMTS ; HMS - Time as "hh:mm:ss". (old WC) +DEFT MDY,OXTMD ; MDY - Date as "mm/dd/yy" +DEFT YMD,OXTYMD ; YMD - Date as "yymmdd" +DEFT MDYT,OXTMDT ; MDYT - Datime as "mm/dd/yy hh:mm:ss" (old WA) +DEFT TNX,OXTTNX ; TNX - Datime as "dd-Mon-yy hh:mm:ss" (TNX default) +DEFT MONTH,OXTLMN ; MONTH - Month as "Month" +DEFT MON,OXTMON ; MON - Month as "Mon" +DEFT MONU,OXTMN ; MONU - Month as "MON" +DEFT DOW,OXTLDW ; DOW - Day of week as "Fooday" +DEFT DOW3,OXTDW ; DOW3 - Day of week as "Foo" +DEFT F1,OXTME ; F1 - Datime as "dd MON yy hhmm ZON" (old WB) +DEFT F2,OXTMX ; F2 - Datime as "dd Month yyyy hh:mm ZON" (old WD) +DEFT F3,OXTMF3 ; F3 - Datime as "dd MON yy hhmm-ZON" +DEFT RFC1,OXTRF1 ; RFC1 - Datime as RFC822 "dd Mon yy hh:mm:ss ZON" +DEFT RFC2,OXTRF2 ; RFC2 - Datime as RFC822 (RFC1) but with short DOW. + + +; OUT invocations +; with TIM() use the sequence +; (arg in U3) +; MOVEI U1,OXTnam +; CALL OXTXS +; with TIMA() use sequence like TIM() but CALL OXTXA. +; with TIMB() use the sequence +; (arg in UTMAC) +; CALL OXTnam + +IFNDEF $LTIMB,[ + ; Define time-block here if not already def'd elsewhere + TM.YR==:0 + TM.MON==:1 + TM.DAY==:2 + TM.HR==:3 + TM.MIN==:4 + TM.SEC==:5 + TM.ZON==:6 ; ,, + TM.DOW==:7 ; 0 = Monday, 6 = Sunday +$LTIMB==:10 +] + +IFN U2-OC, UTMAC==:U2 ; Normal case +.ELSE UTMAC==:U4 ; Screw case + +; OXTXS - Execute time-routine using System-internal time. +; OC/ +; U1/ +; U3/ + +OXTXS: +IFE U2-OC, PUSH P,OC + MOVEI U2,1(P) ; Get pointer to timeblock + ADD P,[$LTIMB,,$LTIMB] ; Make room for timeblock + CALL OXTCSB ; Insert values in timeblock +IFE U2-OC, MOVEI U4,(U2) ? MOVE OC,-$LTIMB(P) + CALL (U1) ; Process stuff +IFN U2-OC, SUB P,[$LTIMB,,$LTIMB] +.ELSE SUB P,[$LTIMB+1,,$LTIMB+1] + RET + +; OXTCSB - Convert System-internal timeword to timeblock. +; U2/ +; U3/ +; Smashes U3, U4 only + +OXTCSB: +IFN OS%ITS,[ + LDB U4,[DATIME"TM$YR,,U3] + ADDI U4,1900. + MOVEM U4,TM.YR(U2) + LDB U4,[DATIME"TM$MON,,U3] + MOVEM U4,TM.MON(U2) + LDB U4,[DATIME"TM$DAY,,U3] + MOVEM U4,TM.DAY(U2) + SKIPN U4,UTZLV ; Get local timezone + JRST [ CALL UTZGET ; Get if not initialized + JRST .-1] ; Repeat after init. + TRNE U3,1 ; DST bit set? + TLOA U4,-1 ; Yes, set LH to -1 + TLZ U4,-1 ; No, ensure LH clear + MOVEM U4,TM.ZON(U2) + MOVEI U3,(U3) + LSH U3,-1 + IDIVI U3,60.*60. + MOVEM U3,TM.HR(U2) + MOVEI U3,(U4) + IDIVI U3,60. + MOVEM U3,TM.MIN(U2) + MOVEM U4,TM.SEC(U2) + SETOM TM.DOW(U2) ; Punt DOW value for now, rarely use it. + RET +] +IFN OS%TNX,[ + PUSHAE P,[1,2,3,4] + MOVE 2,U3 + SETZ 4, + ODCNV + ERJMP [SETZB 2,3 ; 20X only (10X generates .ICILI) + SETZ 4, + JRST .+1] + HLRZM 2,TM.YR(U2) ; Store year # + ADDI 2,1 + HRRZM 2,TM.MON(U2) ; Store month # (1 based) + HLRZM 3,TM.DAY(U2) + AOS TM.DAY(U2) ; Day # (1 based) + HRRZM 3,TM.DOW(U2) ; Store day-of-week (0=Monday) + MOVEI 1,(4) + IDIVI 1,60.*60. + IDIVI 2,60. + MOVEM 1,TM.HR(U2) + MOVEM 2,TM.MIN(U2) + MOVEM 3,TM.SEC(U2) + LDB 1,[.BP ,4] ; Get timezone + TLNE 4,(IC%ADS) ; If DST was applied + TLO 1,-1 ; then put -1 in LH + MOVEM 1,TM.ZON(U2) + POPAE P,[4,3,2,1] + RET +] + +; All of the following output routines assume that UTMAC points +; to a timeblock structure. + + ; Date as MM/DD/YY +OXTMD: MOVE U3,TM.MON(UTMAC) + CALL OXTD2 + STDOUT("/) + MOVE U3,TM.DAY(UTMAC) + CALL OXTD2 + STDOUT("/) +OXTYR2: MOVE U3,TM.YR(UTMAC) ; Year as 2-digit number. + SUBI U3,1900. + CALRET OXTD2 + + ; Date as YYMMDD +OXTYMD: MOVE U3,TM.YR(UTMAC) ; Year as 2-digit number. + SUBI U3,1900. + CALL OXTD2 + MOVE U3,TM.MON(UTMAC) ; Month. + CALL OXTD2 + MOVE U3,TM.DAY(UTMAC) ; Day. + CALRET OXTD2 + + ; Date/time as DD-Mon-YY HH:MM:SS (TNX default format) +OXTTNX: CALL OXTDAY + STDOUT("-) + CALL OXTMON ; Output month + STDOUT("-) + CALL OXTYR2 + STDOUT(40) + CALRET OXTMTS ; Then do time. + + ; Date/time as MM/DD/YY HH:MM:SS +OXTMDT: CALL OXTMD ; Date + STDOUT(40) + ; Fall through for time + + ; Time as HH:MM:SS +OXTMTS: MOVE U3,TM.HR(UTMAC) + CALL OXTD2 ; Output hours + STDOUT(":) + MOVE U3,TM.MIN(UTMAC) + CALL OXTD2 ; Output minutes + STDOUT(":) + MOVE U3,TM.SEC(UTMAC) + CALRET OXTD2 ; Output secs and done. + + + ; Date/time as " 7 AUG 1976 0831 EDT" (constant length) + +OXTME: CALL OXTMFX + CALRET OXTMZB ; Print time-zone & return + +OXTMF3: CALL OXTMFX + CALRET OXTMZD + +OXTMFX: CALL OXTDAY ; Output day, 2 columns + STDOUT(40) + CALL OXTMN ; Output 3-letter month + STDOUT(40) ; Space out + CALL OXTYR ; Output 4-digit year + STDOUT(40) + MOVE U3,TM.HR(UTMAC) + CALL OXTD2 ; Output hrs + MOVE U3,TM.MIN(UTMAC) + CALRET OXTD2 ; Output mins + +;;; RFC822 standard mail timestamps: RFC1 and RFC2. + +OXTRF2: CALL OXTDW ; Output short day of week. + STDOUT(54) + STDOUT(40) ; Space out. +OXTRF1: CALL OXTDAY + STDOUT(40) + CALL OXTMON ; Output 3-letter month + STDOUT(40) ; Space out + MOVE U3,TM.YR(UTMAC) ; Year as 2-digit number. + SUBI U3,1900. + CALL OXTD2 + STDOUT(40) + MOVE U3,TM.HR(UTMAC) + CALL OXTD2 ; Output hrs + STDOUT(":) + MOVE U3,TM.MIN(UTMAC) + CALL OXTD2 ; Output mins + STDOUT(":) + MOVE U3,TM.SEC(UTMAC) + CALL OXTD2 ; Output secs + CALRET OXTMZB ; Go do timezone + + ; Date/time as "7 August 1976 08:31 EDT" + +OXTMX: CALL OXTDAV ; Output day, one or two columns + STDOUT(40) + CALL OXTLMN ; Output "long" month name + STDOUT(40) + CALL OXTYR ; Output 4-digit year + STDOUT(40) + MOVE U3,TM.HR(UTMAC) + CALL OXTD2 ; Output hrs + STDOUT(":) + MOVE U3,TM.MIN(UTMAC) + CALL OXTD2 ; Output mins + ; Fall through to output timezone & return. + + ; Output local timezone (time-word val indicates whether DST) +OXTMZD: STDOUT("-) ; Entry pt for prefix dash + JRST OXTMZ +OXTMZB: STDOUT(40) ; Entry pt for prefix blank +OXTMZ: SKIPN U3,UTZLSS ; Get pointer to local timezone + JRST [ CALL UTZGET ; Not there yet? Set it up. + JRST .-1] + SKIPGE TM.ZON(UTMAC) ; Daylight savings on? + MOVE U3,UTZLDS ; Yes, use DST version instead. + CALRET OXZA ; Output ASCIZ. + + ; Day of the month in two columns. +OXTDAY: MOVE U3,TM.DAY(UTMAC) ; Get day + CAIL U3,10. ; If number will have two digits, + CALRET OXTD2 ; dispatch to routine for that. + STDOUT(40) ; Else output a space + STDOUT("0(U3)) ; and the digit. + RET + + ; Day of the month in one or two columns (Variable format). +OXTDAV: MOVE U3,TM.DAY(UTMAC) ; Get day + CAIL U3,10. ; If two digits, + CALRET OXTD2 ; dispatch to better routine. + STDOUT("0(U3)) + RET + + ; For both versions of month output, use ASCIZ + ; rather than ASCNT since former guarantees U2 + ; will be preserved. +OXTLMN: MOVE U3,TM.MON(UTMAC) ; Get month + MOVE U3,UTBMON(U3) ; Get ascnt ptr to string for it + CALRET OXZA ; Output ASCIZ string + +OXTMN: MOVE U3,TM.MON(UTMAC) ; Get month + MOVE U3,UTBMO3(U3) ; Get ascnt ptr to string for it + CALRET OXZA ; Output asciz (only 3 chars) + + ; Output month as "Mon" +OXTMON: MOVE U3,TM.MON(UTMAC) ; Get month + MOVE U3,UTBMON(U3) ; Get ascnt ptr to long-form name + HRLI U3,440700 ; Set up BP then output 1st 3 chars. + REPEAT 3,ILDB U1,U3 ? STDOUT + RET + +; Day-Of-Week output + +OXTDW: SKIPA U1,[UTBDO3(U3)] ; Use short-form table. +OXTLDW: MOVE U1,[UTBDOW(U3)] ; Use long-form table. + SKIPGE U3,TM.DOW(UTMAC) ; All's well if have valid DOW value + CALL UTMGDW ; Sigh, must get it (into U3) + MOVE U3,@U1 ; Get appropriate string, table idx'd by U3 + CALRET OXZA ; Output as asciz to avoid U4 clobberage. + +OXTYR: MOVE U3,TM.YR(UTMAC) ; Get year + ; Fall through to output 4 digits. + + ; Internal routines to output 4 or 2 digits of num in U3. +OXTD4: +IFE UTMAC-U4, PUSH P,U4 + IDIVI U3,100. ; Output 4 digits + PUSH P,U4 + CALL OXTD2 + POP P,U3 ; Fall thru to OXTD2 again +IFE UTMAC-U4, CAIA + +OXTD2: +IFE UTMAC-U4, PUSH P,U4 + IDIVI U3,10. ; Output 2 digits + STDOUT("0(U3)) + STDOUT("0(U4)) +IFE UTMAC-U4, POP P,U4 + RET + + + ; Get system internal time in U3 +UTMGTS: +IFN OS%ITS,[ + PUSH P,A + CALL DATIME"TIMGET + CAMN A,[-1] + JSR AUTPSY + MOVE U3,A + POP P,A +] +IFN OS%TNX,[ + PUSH P,1 + GTAD + MOVE U3,1 + POP P,1 +] + RET + +; UTMGDW - Given ptr to time-block in UTMAC, return +; DOW value in U3 (0=Monday). Clobbers U4 (unless == UTMAC) + +UTMGDW: +IFN OS%TNX, MOVEI U3,7 ; TNX shouldn't ever have to ask +IFN OS%ITS,[ + CALL UTCBDA ; Get absolute # days + IFE UTMAC-U4,PUSH P,U4 + IDIVI U3,7 + MOVEI U3,(U4) + IFE UTMAC-U4,POP P,U4 +] ;OS%ITS + RET + +; UTCBDA - Time Convert, Block to Day Absolute +; UTMAC/ ptr to time-block +; Returns +; U3/ absolute # days since Jan 1, 1900 +; Clobbers U4 (unless == UTMAC) +IFN OS%ITS,[ +UTCBDA: IFN UTMAC-U2,PUSH P,U2 ? MOVE U2,UTMAC ; Ensure ptr in U2 + PUSH P,U1 + MOVE U3,TM.DAY(U2) ; Get day # + MOVE U1,TM.MON(U2) ; Get month # + ADD U3,DATIME"TMONTB(U1); Add days thus far in year + MOVE U4,TM.YR(U2) ; Get year + SUBI U4,1900. ; Make simplifying assumption + TRNE U4,3 ; Specified year a leap year? + JRST .+3 ; No, can skip month check + CAIL U1,3 ; Leap year -- is it after Feb? + ADDI U3,1 ; Yes, add extra day + MOVEI U1,-1(U4) ; Adjust, and + LSH U1,-2 ; Get # of leapyears since 1900, excl this yr + IMULI U4,365. ; # years times 365 + ADDI U4,(U1) ; plus # prior leapyears (extra days) + ADDI U3,-1(U4) ; plus days so far this yr (-1 because day # + POP P,U1 ; was 1-based) + IFE UTMAC-U4, MOVE UTMAC,U2 ? POP P,U2 + RET +] ;IFN OS%ITS + +; Time-zone hacks + + ; For all three params below, LH=-1 when set (thus 0 val means + ; var isn't initialized). Actual var is in RH. +.SCALAR UTZLV ; Local timezone value +.SCALAR UTZLSS ; Local STD timezone string (addr of ASCIZ) +.SCALAR UTZLDS ; Local DST timezone string (addr of ASCIZ) + +; UTZGET - Set up the above three parameters. + +UTZGET: PUSH P,U1 + +IFN OS%ITS,MOVEI U1,5 ; All ITS systems are in EST +IFN OS%TNX,[ + PUSHAE P,[2,3,4] + SETO 2, + SETZ 4, + ODCNV + LDB U1,[.BP IC%TMZ, 4] + POPAE P,[4,3,2] +] + HRROM U1,UTZLV ; Store local time-zone value + MOVE U1,UTBZON(U1) ; Get ASCIZ strings for zone + HLROM U1,UTZLSS ; Store STD string + HRROM U1,UTZLDS ; Store DST string + POP P,U1 + RET + +DEFINE TZONE STD,DST + [ASCIZ /STD/],,[ASCIZ /DST/] +TERMIN + +UTBZON: TZONE GMT,GMT ; 0 How to ask for British Summer Time?? + TZONE ; 1 + TZONE ; 2 + TZONE ; 3 (NST = Newfoundland is -0330) + TZONE AST,ADT ; 4 Atlantic + TZONE EST,EDT ; 5 Eastern + TZONE CST,CDT ; 6 Central + TZONE MST,MDT ; 7 Mountain + TZONE PST,PDT ; 8 Pacific + TZONE YST,YDT ; 9 Yukon + TZONE HST,HDT ; 10 Alaska-Hawaii + TZONE BST,BDT ; 11 Bering + REPEAT 24.-11.,TZONE ; 12-24 unspecified + +; Various tables + + ; Table for printing month, indexed by 1-12. +UTBMON: 0 + IRP M,,[January,February,March,April,May,June,July,August,September,October,November,December] + .LENGTH "M",,[ASCIZ "M"] + TERMIN + + ; Table for printing month, indexed by 1-12. +UTBMO3: 0 + IRP M,,[JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC] + 3,,[ASCIZ /M/] ; All strings length 3. + TERMIN + + + ; Tables for printing day-of-week, indexed by 0-6. + ; Note TNX internal convention has 0 = Monday. + ; Note also that Jan 1, 1900 (abs day 0) = Monday. + ; Fooday included so masking low 3 bits of DOW value will always win. +UTBDOW: IRP D,,[Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday,Fooday] + .LENGTH /D/,,[ASCIZ /D/] + TERMIN + +UTBDO3: IRP D,,[Mon,Tue,Wed,Thu,Fri,Sat,Sun,Foo] + 3,,[ASCIZ /D/] ; All strings of length 3. + TERMIN + +] ;IFN $$OTIM + +SUBTTL .END OUT - Additional comments + +.QMTCH==QMTCH ; Now can restore user's parsing mode. +.END ; End the OUT symbols block. +.INEOF ; Stop parsing here. + +COMMENT | + +Table of OUT channel variables: + +UCHTYP UCOPT USCOPT UCHCNT UCNTS UCHSTB UCHJFN UCHLIM + +UC$UAR idpb u1,$arwpt uol.ar $archl - - - +UC$XCT uo*.x count - - +UC$BPT idpb u1,uchstb uo*.bp count - +UC$IOT .iot u1 / bout uo*.io count - +UC$BUF idpb u1,uchstb uol.bf count ,, +UC$TRN xct ucopt+x uos.tr - - +UC$NUL nop uos.nl count - - + +Note: UO*.X corresponds to either UOL.X or UOS.X depending on whether the +channel was opened with a count limit (UOL) or not (UOS). + +UCOPT ; XCT'd unit-mode instruction (always) +USCOPT ; Addr of string-mode routine (always) +UCHCNT ; Addr of char countdown (always) +UCNTS ; Char countdown (except UAR, TRN) +UCHLIM ; Original count (except UAR, TRN, BUF) +UCHTYP ; ,, +UCHJFN ; JFN for channel if any (only TNX IOT, BUF) +UCHSTB ; Byte ptr (UC$BPT) or ARPT (UC$UAR) + +List of type-dependent OUT functions: + +OPEN UOPENT(typ) + Unit Output UCOPT(ch) + String Output USCOPT(ch) + Overflow OVFTAB(typ) +CLS OXCLST(typ) +PTV UPTTAB(typ) +FRC OXFRCT(typ) Doesn't exist but should +RST OXRSTT(typ) " +PUSH,POP OXPOPT(typ) " + +| \ No newline at end of file diff --git a/src/ksc/nfnpar.7 b/src/ksc/nfnpar.7 new file mode 100755 index 00000000..020b8e74 --- /dev/null +++ b/src/ksc/nfnpar.7 @@ -0,0 +1,80 @@ +if1 ifndef %%scan,.insrt ksc;nscan > +if2 ife %%scan,.insrt ksc;nscan > + +fnpard: +fnpart=fnpard+1 +.begin fnpar ; filename parser. addr of string in 1 + ; returns dev/sname/fn1/fn2 in accs 1,2,3,4 + + tdca b,b ;FNPARD entry point = DDT type + seto b, ;FNPART entry point = TECO type + movem b,fmode' ;set type + movem a,finstr' ;save addr of input string + setzm fdev' ;clear accumulated vars + setz b, ;fdir + setzb c,d ;fn1,fn2 +fnpr20: push p,[brkchr'] + push p,[fstr] + push p,[fbrktb] + push p,finstr + pushj p,scanrt + move a,brkchr + cain a,40 + jrst [pushj p,fcvstr ? pushj p,ffnput ? jrst fnpr20] + cain a,"; + jrst [pushj p,fcvstr ? move b,a ? jrst fnpr20] + cain a,": + jrst [pushj p,fcvstr ? movem a,fdev ? jrst fnpr20] + pushj p,fcvstr ;handle EOF or foreign char + pushj p,ffnput + move a,fdev + popj p, + +ffnput: jumpe a,[popj p,] ;nothing to deposit + skipn fmode ;DDT or TECO style? + jrst [jumpe c,[move c,a ? popj p,] ;DDT + move d,a ? popj p,] + jumpe d,[move d,a ? popj p,] ;TECO + move c,d + move d,a + popj p, + + + ;break table +fbrktb: cain a,^Q + jrst scbrqt + cain a,": + jrst scbrsk + cain a,"; + jrst scbrsk + cain a,40 + jrst scbrsk + cain a,^M + jrst scbrsk + cain a,^J + jrst scbrsk + jrst (b) + +.scalar fstr(2) + +;convert string (ptr in fstr) to sixbit wd in a +fcvstr: pushae p,[b,c,d] + setz a, + move c,[440600,,a] + hrrz d,fstr ;get cnt + +fcvst5: sojl d,fcvst9 + ildb b,fstr+1 + cain b,^Q ; if quoter, + jrst fcvst5 ; don't deposit it. + cail b,"a + caile b,"z + caia ;not lowercase + subi b,40 ;cvt to uppercase + subi b,40 ;cvt to 6bit + idpb b,c ;deposit + tlne c,770000 + jrst fcvst5 ;if sixbit word not exhausted, get more chars +fcvst9: popae p,[d,c,b] + popj p, +.end fnpar \ No newline at end of file diff --git a/src/ksc/nscan.8 b/src/ksc/nscan.8 new file mode 100755 index 00000000..154f12d8 --- /dev/null +++ b/src/ksc/nscan.8 @@ -0,0 +1,117 @@ +IF1 %%SCAN==0 ;so files .insrt'ing can do right thing; should +IF2 %%SCAN==1 ;have their .INSRT as follows: + ; if1 ifndef %%scan, .insrt ksc;nscan > + ; if2 ife %%scan, .insrt ksc;nscan > + +ifndef pushae,[ +DEFINE PUSHAE AC,LIST +IRP LOC,,[LIST] +PUSH AC,LOC +TERMIN +TERMIN + +DEFINE POPAE AC,LIST +IRP LOC,,[LIST] +POP AC,LOC +TERMIN +TERMIN +] +DEFINE SCAN ?INPUT,BRKTBL,RESULT,BRKCHR +PUSH P,[BRKCHR] +PUSH P,[RESULT] +PUSH P,[BRKTBL] +PUSH P,[INPUT] +PUSHJ P,SCANRT +TERMIN + +%BRKAD==1 ;break char flag for appending to result +SCBRAD: TLO A,%BRKAD + JRST 2(B) ;return to right place in SCANRT +%BRKSK==2 ;break char flag for skip of break char +SCBRSK: TLO A,%BRKSK + JRST 2(B) +%BRKLV==4 ;break char flag for leaving on front of input +SCBRLV: TLO A,%BRKLV + JRST 2(B) +%BRKQT==10 ;break char flag for gobbling following char +SCBRQT: TLO A,%BRKQT + JRST 2(B) + +SCANRT: +.begin scnblk +define arg1 +(p)-5!termin +define arg2 +arg1-1!termin +define arg3 +arg2-1!termin +define arg4 +arg3-1!termin + + PUSHAE P,[A,B,C,D] + MOVE D,ARG1 ;get addr of input string + MOVE C,1(D) ;get BP + HRRZ D,(D) ;get char cnt + JUMPE D,[MOVE A,[-1,,3] ;none left? Then EOS, no result string. + MOVEM A,@ARG4 ;store -1,,3 as "break char" + SETZM @ARG3 ;and clear 1st descriptor wd of result string (count) + JRST SCNR90] ;and return. + +SCNR20: ILDB A,C ;get char from input string + JSP B,@ARG2 ;execute break table. + SOJG D,SCNR20 ;no break, continue + JRST SCNR70 ;again none left, EOS. + + ;break char found! decipher flag(s) and return + TLNE A,%BRKQT ; quote next + JRST SCNR45 + TLNE A,%BRKSK + JRST SCNR50 ;skip break char. + TLNE A,%BRKAD + JRST SCNR55 ;go append break char to result + TLNE A,%BRKLV + JRST SCNR60 ;leave break char on front of input. + JRST SCNR20 ;no flags found?! continue. + + ; quote next char +SCNR45: SOJLE D,SCNR70 ; jump if none left. + ILDB A,C ; get it, ignore it. + SOJG D,SCNR20 ; get next. + JRST SCNR70 + + ;skip break char - goes on neither result nor input. +SCNR50: SOS @ARG1 ;D is subtracted from this for result cnt, so ensure brkchar + ;isn't included within result. + + ;append break char to result string +SCNR55: SUBI D,1 ;D becomes new input cnt, so ensure brkchr isn't included. + JRST SCNR80 ;and return thusly. + + ;retain break char on front of input string +SCNR60: ADD C,[70000,,0] ;must decrement bp to point back at brkchar. + CAIG C, + SUB C,[430000,,1] ;(reset if go off wd edge) + JRST SCNR80 + + ;EOS found and non-null result string. +SCNR70: MOVE A,[-1,,3] ;"break char". + MOVEM A,@ARG4 + JRST .+2 + + ;return result and update input as determined by count in D. + ;if control came directly here, result string would contain everything up to + ;break char, and input string cnt would include brk char but bp would point + ;immediately after it. +SCNR80: HRRZM A,@ARG4 ;store break char + MOVE A,ARG1 ;get addr of input string again. + MOVE B,(A) ;get 1st wd of descriptor before clobbering. + HRRM D,(A) ;store updated input string count. + SUB B,D ;get descriptor with proper result string cnt + EXCH C,1(A) ;exchange bp's to update input and get bp for result. + MOVE A,ARG3 ;get addr of result string now + MOVEM B,(A) ;store 1st descriptor wd + MOVEM C,1(A) ;and 2nd (bp). +SCNR90: POPAE P,[D,C,B,A] + SUB P,[5,,5] ;flush args and return addr + JRST @5(P) ;and return. +.end scnblk \ No newline at end of file diff --git a/src/ksc/pagser.49 b/src/ksc/pagser.49 new file mode 100755 index 00000000..fbfe2520 --- /dev/null +++ b/src/ksc/pagser.49 @@ -0,0 +1,879 @@ +; -*- Mode: MIDAS -*- +.BEGIN PAGSER ; New page/core manager. + +IFNDEF $$PDBG,$$PDBG==0 ; 1 - include debugging printout routines +IFNDEF $$PPGS,$$PPGS==0 ; 1 - include GETPAG + +comment | + + PAGSER is a storage allocation management package. It will +allocate, expand, and release areas of memory in units of either pages +or words. All the core which PAGSER knows about is divided into +"blocks" which are either "active" (in use by the program) or +"unactive" (free, available for allocation requests). At +initialization, PAGSER will control a single large "unactive" block; +all future allocate requests will be satisfied from this primal block. + Because PAGSER's data structures are themselves allocated +dynamically, there is no space problem for them. Because they are +localized and distinct from the areas they refer to, page faults +are minimized and allocation can be done with respect to the theoretical +address space only, without implying that anything actually exists +within a block. This is useful for programs which need to dynamically +hack their page map. + + In PAGSER's data structures, each block (active or not) is +described by a single node, which is $PNSIZ words long and +has the following format: + +$PNPTR 0: ,, ; Corelist pointers +$PNSPP 1: ,, ; Spacelist pointers (0 if active) +$PNFLG 2: ,, ; Consistency check. +$PNBLK 3: <# wds>,, ; Size & location of block. + +There are three lists composed of these nodes: the Corelist, Spacelist, +and Freelist. + +The FREELIST is simply a list of all unused nodes, which describe +no blocks at all. When a node is required (e.g. when a new block is +created, and needs a new node to describe it) one is procured from +this list. Freelist nodes use the RH of the first word to point +to the next free node; zero implies no more. + +The CORELIST holds ALL nodes which represent a block, in an order +corresponding EXACTLY to their sequence in memory. points at +the node for the block preceding this one in core, and +similarly points at the node for the block immediately succeeding this +one in core. The Corelist is used to determine the state of blocks +preceding and succeeding a particular block, and always completely +describes the state of the entire section of memory entrusted to +PAGSER. + +The SPACELIST is an efficiency hack. The and +pointers are used to string together all UNACTIVE blocks, so that when +an allocation request is made, no time is wasted checking active +blocks. An "active" block is one for which the Spacelist pointer word +($PNSPP) is zero. The current algorithm for constructing and searching +the Spacelist favors the most recently freed blocks. + +About $PNBLK, note that <# wds>,, specify the location and +length of the core block that the node represents. There need not +necessarily be any actual core there, especially for the LAST block +on the Corelist ( zero). The code tries to keep unmapped +all pages in the last block, if it is unactive. + +$PNFLG is primarily used for verifying that a "node address", +as furnished to some PAGSER routines by the user program, +actually does refer to an active PAGSER node. This helps to quickly +catch any bugs that give invalid arguments to the core routines, +which otherwise might be extremely hard to uncover. It isn't +foolproof, but is much better than nothing. +| + + ; Indices into a node. + OFFSET -. +$PNPTR:: 0 ; ,, for Corelist +$PNSPP:: 0 ; ,, for Spacelist +$PNBLK:: 0 ; <# wds>,, +$PNFLG:: 0 ; ,, ; RH not really used now. +; $PNPGS:: 0 ; <# pages included> +$PNSIZ:: ; Size of a node. + OFFSET 0 + +$PVLID==:<(SIXBIT /PSR/)> ; ID value used in LH of $PNFLG. + ; Note only used for active nodes. + + ; Other random parameters +IFNDEF $PMAKN,$PMAKN==:40 ; # nodes to create each time need more. +IFNDEF $PTRIV,$PTRIV==:10 ; # words OK to waste when satisfying request. + + ; Page size parameters +IFNDEF PG$BTS,{ IFN OS%TNX, PG$BTS==:9. + IFN OS%ITS, PG$BTS==:10. +} +PG$SIZ==:1_PG$BTS +PG$MSK==:PG$SIZ-1 + + +;;; PSRERR is an error macro which can be skipped over. +;;; The user may define this for us, otherwise it is a .VALUE. +;;; PSRERR is called with the PAGSER error code. + +IFNDEF PSRERR,[ + +DEFINE PSRERR CODE + .VALUE [CODE] +TERMIN +];IFNDEF PSRERR + +;;; Preliminary list of error codes. + +ERBAD==0 ;Internal error +ERARG==1 ;Bad argument +EROOM==2 ;Not enough room + +;;; User may also supply the similar macro CORLUZ, +;;; which is called when a CORBLK fails. + + + +subttl Initialization - PSRINI + +.SCALAR SPCLST ; Ptr to Spacelist +.SCALAR CORLST ; Ptr to Corelist +.SCALAR FRELST ; Ptr to Freelist, 0 when none left. +.SCALAR FRESAV ; Ptr to saved node, used when getting block for more. +.SCALAR FFPAGE ; # of first free page + +.VECTOR INILST($PNSIZ) ; Initial list node, set up pointing at free core. +.VECTOR INIFSV($PNSIZ) ; Initial scratch node for FRESAV to point at. + + +; PSRINI - Initialize PAGSER routines +; U1 - -<# pages>,,<1st page #> defines area available for hacking. + +.M"PSRINI: +.M"CORINI: + PUSH P,U1 + JUMPGE U1,.+3 ; If already positive skip convert hack. + TLC U1,-1 + ADD U1,[1,,] ; Make count positive + TRNE U1,-1 ; Make sure page # isn't 0. + TLNN U1,-1 ; Likewise make sure # pages isn't 0. + PSRERR ERARG ; Ugh, zero component! + HRRZM U1,FFPAGE + LSH U1,PG$BTS ; Get in terms of words + MOVEM U1,$PNBLK+INILST ; Initialize count of first, unactive, node. + MOVSI U1,SPCLST-$PNSPP + MOVEM U1,$PNSPP+INILST ; and initialize spacelist pointer + MOVSI U1,CORLST-$PNPTR + MOVEM U1,$PNPTR+INILST ; and corelist pointer + + MOVEI U1,INILST ; Initialize + MOVEM U1,SPCLST ; Spacelist, and + MOVEM U1,CORLST ; Corelist, and + SETZM FRELST ; Freelist. + MOVEI U1,INIFSV + MOVEM U1,FRESAV ; Point to extra node... + SETZM INIFSV ; Clear it out. + MOVE U1,[INIFSV,,INIFSV+1] + BLT U1,INIFSV+$PNSIZ-1 + + POP P,U1 + POPJ P, + + +;;; PSRP - See if enough space available. +;;; U1 - # words needed +;;; Skips if enough space is available, does not skip if not enough. + +.M"PSRP: ;Bash UUO ACs with abandon! + SKIPN U2,SPCLST ;Get spacelist. + JRST PSRP9 ; If missing take failure return. +PSRP2: HLRZ U4,$PNBLK(U2) ;Get core spec. + CAILE U1,(U4) ;Loop until we find one big enough. + JRST [ HRRZ U2,$PNSPP(U2) + JUMPN U2,PSRP2 + JRST PSRP9 ] ; If no more left, failure return. + AOS (P) ;On success, skip return. +PSRP9: RET + + + +subttl PSRGET - Get a block + +; PSRGET - Get core. +; U1 - # words needed +; Returns +; U1 - actual # words available in block +; U2 - ,, ; COREXP - 0,, + +.M"CORGET: + PUSHJ P,PSRGET + HLRZ U2,U2 ; Return block addr only. + POPJ P, + +.M"PSRGET: + PUSH P,U3 + PUSH P,U4 + SKIPN U2,SPCLST + PSRERR ERBAD ; No spacelist??? +PSRGT2: HLRZ U4,$PNBLK(U2) ; Get core spec + CAIG U1,(U4) + JRST PSRGT4 ; Found block big enough... + HRRZ U2,$PNSPP(U2) ; Nope, get next + JUMPN U2,PSRGT2 + PSRERR EROOM ; Failed to find big enough block?! + + ; Found block big enuf. See if want to split or swallow whole. +PSRGT4: CAILE U4,$PTRIV(U1) ; Excess greater than some trivial value? + JRST [ PUSHJ P,PSRADJ ; Yes, split block... + JRST PSRGT8] + + ; Here when block needn't be split up. Must remove from spacelist. + MOVEI U3,(U2) +IFN OS%ITS,{ ; If on ITS, + MOVE U4,$PNPTR(U3) ; and gobbling very last block, + TRNN U4,-1 ; we're bypassing PSRADJ + PUSHJ P,PSRCOR ; so must make sure core exists for it. +} + PUSHJ P,PSRACT ; Remove from spacelist. + + ; All done with split or whatever, U1 still has size and U2 + ; address of node for block we want. +PSRGT8: HLRZ U1,$PNBLK(U2) ; Update U1 to actual size + HRL U2,$PNBLK(U2) ; and U2 to ,,. + POP P,U4 + POP P,U3 + POPJ P, + + +subttl GETPAG - Get pages. + +ifn $$ppgs,{ + +; GETPGN - Variant of GETPAG that returns negative rather than positive +; count in LH, AOBJN style. + +.M"PAGGTN:PUSHJ P,PSRPGT + TLC U1,-1 + ADD U1,[1,,] + POPJ P, + +; GETPAG - Get block of pages. +; U1 - # of pages desired +; Returns +; U1 - <# pages>,,<1st page #> + +.M"GETPAG: +.M"PSRPGT: + PUSH P,U2 + PUSH P,U3 + PUSH P,U4 + + LSH U1,PG$BTS ; Get # words + SKIPN U2,SPCLST + PSRERR ERBAD ; No spacelist?? +PSRPG2: HLRZ U4,$PNBLK(U2) + CAIG U1,(U4) + JRST PSRPG4 +PSRPG3: HRRZ U2,$PNPTR(U2) + JUMPN U2,PSRPG2 + PSRERR EROOM ; Couldn't find enough pages!! + +PSRPG4: MOVE U3,$PNBLK(U2) ; Get address core block starts at + ANDI U3,PG$MSK ; Find # words past page boundary it starts at + CAIE U3, + SUBI U3,PG$SIZ ; Get -<# words to next boundary> + ADD U4,U3 ; Thus get # wds in block past first boundary + CAIGE U4,(U1) ; Compare (U4 may be neg), have enuf words? + JRST PSRPG3 ; Nope, keep searching. + + MOVMS U3 + CAILE U3,$PTRIV + JRST [ PUSH P,U1 + PUSH P,U4 + MOVM U1,U3 + PUSHJ P,PSRADJ ; Split off low end. + EXCH U2,U3 ; Get low-end node in U3, and + PUSHJ P,PSRMKU ; put it on spacelist. + POP P,U4 + POP P,U1 + JRST .+1] + + CAILE U4,$PTRIV(U1) ; Need to split things up at high end? + JRST [ PUSHJ P,PSRADJ ; Get block of right size. + JRST PSRPG8] +;IFN OS%ITS,{ ; If on ITS, +; MOVE U4,$PNPTR(U3) ; and gobbling very last block, +; TRNN U4,-1 ; we're bypassing PSRADJ +; PUSHJ P,PSRCOR ; so must make sure core exists for it. +;} +PSRPG8: TRNE U1,PG$MSK + PSRERR ERARG ; Just a check... + LSH U1,<18.-PG$BTS> ; Before shifting # pages out into LH. + HRRZ U3,$PNBLK(U2) + ADDI U3,PG$SIZ-1 + LSH U3,-PG$BTS + HRRI U1,(U3) ; Now have <# pages>,, + + POP P,U4 + POP P,U3 + POP P,U2 + POPJ P, + +} ; end ifn $$ppgs + +subttl PSREXP - Expand block + +; PSREXP - Expand core block. +; U1 - # wds to increase by +; U2 - node of block to increase ; COREXP - addr of block +; Returns +; U1 - new # wds total in block +; U2 - ,, ; COREXP - 0,, + +comment | +There are 4 cases possible, listed in order of optimality: + 1) Enough room in unactive successor. + Merge and perhaps split. + 2) Enough room in unactive predecessor. + Must copy up and perhaps split. + 3) Enough room if both predecessor and successor combined. + Must copy up, then merge with following, then perhaps split. + 4) No free blocks on either side, or not enough room. + Must find completely new block and copy into it. Old + block must be released. +| + +.M"COREXP: + PUSHJ P,PSREQV ; Chg blk addr to node addr for compatibility + PUSHJ P,PSREXP + HLRZ U2,U2 ; Return block addr only. + POPJ P, + +.M"PSREXP: + PUSH P,U3 + PUSH P,U4 + + ; Verify that node is kosher. + HLRZ U3,$PNFLG(U2) ; Get ID-check value from where it should be + CAIE U3,$PVLID ; and make sure it's what it should be... + PSRERR ERBAD ; Yuckity yuck! + + ; See if enough room in successor. + MOVE U3,$PNPTR(U2) ; Get ptr to successor + TRNE U3,-1 ; Not there? + SKIPN $PNSPP(U3) ; or Active? + JRST [HLRZS U3 ; Yes, can't hack succ, check pred. + CAIN U3,CORLST-$PNPTR + JRST PSRXP7 ; Not there? + SKIPN $PNSPP(U3) + JRST PSRXP7 ; Can't hack pred either, need new block. + HLRZ U4,$PNBLK(U3) + SUBI U4,(U1) + JUMPL U4,PSRXP7 ; If not enough words, also can't hack. + JRST PSRXP2] ; Can, go hack predecessor. + HLRZ U4,$PNBLK(U3) ; Check successor - get # words in it. + SUBI U4,(U1) ; Find diff. + JUMPGE U4,[HLRZ U4,$PNBLK(U2) + ADDI U1,(U4) + JRST PSRXP4] ; Jump if successful. + + HLRZS U3 ; Fooey, but see if predecessor can save day. + CAIE U3,CORLST-$PNPTR ; No predecessor? + SKIPN $PNSPP(U3) ; or not available? + JRST PSRXP7 ; Ugh, must find whole new block. + HLRZ U3,$PNBLK(U3) ; Get # words + ADDI U4,(U3) + JUMPL U4,PSRXP7 ; Again, jump if must get new block. + + ; Here, can win by combining pred & succ blocks. +PSRXP2: HLRZ U3,$PNPTR(U2) ; Get ptr to pred. + PUSHJ P,PSRACT ; Make U3 block active. + EXCH U2,U3 + PUSHJ P,PSRCPY ; Copy into U2 from U3. + HLLZ U4,$PNBLK(U3) ; Get count of old block + ADDM U4,$PNBLK(U2) ; Add into pred block. + HLRZS U4 ; While still have count, + ADDI U1,(U4) ; Find total # words required + PUSHJ P,PSRFRX ; Put U3 block on Freelist. + + HLRZ U4,$PNBLK(U2) ; Find how much room we have now. + CAIG U1,(U4) + JRST PSRXP6 ; Aha, got enough. + + ; Here, can win by adding successor block. +PSRXP4: HRRZ U3,$PNPTR(U2) ; Get succ + JUMPE U3,PSRXP7 + PUSHJ P,PSRMRG ; Merge successor in with U2 block. + + ; Here have block all together, see if want to split some off. +PSRXP6: HLRZ U4,$PNBLK(U2) ; Find total # words we have + CAIGE U4,(U1) + PSRERR EROOM ; somehow didn't get enough??? + CAIG U4,$PTRIV(U1) ; More than a trivial amount? + JRST PSRXP8 ; No, return. + PUSHJ P,PSRADJ ; Split them up... + PUSHJ P,PSRMKU ; Put split-off block in U3 on spacelist. + JRST PSRXP8 + + + ; Here, must find a whole new block. +PSRXP7: HLRZ U4,$PNBLK(U2) + ADDI U1,(U4) ; Find # words total we need. + MOVE U3,U2 ; Save U2 + PUSHJ P,PSRGET ; Get a block of right size (node ptr in U2) + PUSHJ P,PSRCPY ; Copy U3 into U2. + MOVEI U1,(U3) + PUSHJ P,PSRREL ; Free up old core. + +PSRXP8: HLRZ U1,$PNBLK(U2) ; Return U1 - <# words> + HRL U2,$PNBLK(U2) ; Return U2 - ,, + POP P,U4 + POP P,U3 + POPJ P, + +subttl PSRREL - Release Block + +; PSRREL - Release core block. +; U1 - addr of node to release. (CORREL - addr of block) + +.M"CORREL: + PUSH P,U2 + MOVEI U2,(U1) + PUSHJ P,PSREQV ; Temp hack - change block addr to node addr + JRST PSRRL1 + +.M"PSRREL: + PUSH P,U2 + MOVEI U2,(U1) +PSRRL1: PUSH P,U3 + PUSH P,U4 + + ; Verify that node is kosher. + HLRZ U3,$PNFLG(U2) ; Get ID-check value from where it should be + CAIE U3,$PVLID ; and make sure it's what it should be... + PSRERR ERBAD ; Yuckity yuck! + + HLRZ U3,$PNPTR(U2) ; Get + CAIE U3,CORLST-$PNPTR ; Special check before taking look at "node". + SKIPN $PNSPP(U3) ; Is predecessor unactive? + JRST PSRRL2 ; No, or not real node, don't merge. + EXCH U2,U3 + PUSHJ P,PSRMRG ; Merge if so + +PSRRL2: HRRZ U3,$PNPTR(U2) ; Get + JUMPE U3,PSRRL4 + SKIPE $PNSPP(U3) ; Is successor unactive? + PUSHJ P,PSRMRG + SKIPN $PNSPP(U2) ; Is block itself on spacelist by now? + PUSHJ P,PSRMK2 ; Make it unactive, put on spacelist. + + ; Could check here for freeing up pages. +PSRRL4: +PSRRL8: PUSHJ P,PSRGC + POP P,U4 + POP P,U3 + POP P,U2 + POPJ P, + +; PSREQV - Temporary hack which converts a block address to a node address, +; so as to maintain compatibility with CORSER. In future the node +; address will be returned to caller of CORGET so as to eliminate this +; searching overhead. +; Takes U2 - block addr +; Returns U2 - node addr for the block + +PSREQV: PUSH P,U3 ? PUSH P,U4 + MOVEI U3,CORLST-$PNPTR + JRST PSREQ4 +PSREQ2: HRRZ U4,$PNBLK(U3) + CAIN U2,(U4) + JRST PSREQ6 +PSREQ4: HRRZ U3,$PNPTR(U3) + JUMPN U3,PSREQ2 + PSRERR ERBAD ; No block corresponds to this address!! +PSREQ6: MOVEI U2,(U3) + POP P,U4 ? POP P,U3 + POPJ P, + +subttl Primitives - OS dependent page hacking + +; PSRGC - Frees up core from U2 block insofar as possible. +; U2 - block just freed +; Clobbers U3,U4 + +PSRGC: MOVE U4,$PNPTR(U2) + TRNE U4,-1 + POPJ P, + + MOVE U4,$PNBLK(U2) ; Get <# wds>,, + MOVEI U3,PG$SIZ-1(U4) + LSH U3,-PG$BTS ; Find 1st page # freed. + MOVE U4,FFPAGE + SUBI U4,(U3) + JUMPLE U4,PSRGC9 +IFN OS%ITS,{ + IMUL U4,[-1,,] + HRRI U4,(U3) + SYSCAL CORBLK,[MOVEI 0 + MOVEI %JSELF + U4] + PSRERR ERARG ; Should only happen if bad args. +} +IFN OS%TNX,{ + PUSH P,1 ? PUSH P,2 ? PUSH P,3 + SETO 1, + MOVEI 2,(U3) + HRLI 2,.FHSLF + MOVEI 3,(U4) + TLO 3,(PM%CNT) + PMAP + ERJMP .+1 + POP P,3 ? POP P,2 ? POP P,1 +} + MOVEM U3,FFPAGE + +PSRGC9: POPJ P, + + +; PSRADJ - Splits up block of core into 2 blocks. +; This is the ONLY PLACE where new nodes/blocks are added to +; the corelist!! +; U1 - # words to put in active new block +; U2 - ptr to block to split up (unactive, on spacelist) +; Returns +; U2 - ptr to active new block +; Clobbers U3,U4 + +PSRADJ: MOVEI U3,(U2) ; Put big unactive node in U3 + PUSHJ P,PSRGTN ; Get a new node in U2 + HLRZ U4,$PNBLK(U3) + SUBI U4,(U1) + CAIG U4, ; Make sure block is big enough for split... + PSRERR ERARG ; Ugh?? Caller messed up. + HRLM U4,$PNBLK(U3) ; Store reduced size for big unactive block + HRLM U1,$PNBLK(U2) ; and set desired size for new block. + MOVE U4,$PNBLK(U3) ; Get addr of big block, + HRRM U4,$PNBLK(U2) ; and store it as addr for new block + ADDI U4,(U1) ; and find new addr of big unactive block. + HRRM U4,$PNBLK(U3) ; Store away, all block-size specs done. + + ; Insert new block into corelist, and make it active! + MOVE U4,$PNPTR(U3) ; Get ,, for old node + HRRI U4,(U3) ; for new node is old one. + MOVEM U4,$PNPTR(U2) ; Fix up new node... + HLRZS U4 ; Now get , + HRRM U2,$PNPTR(U4) ; So as to zap predecessor to point at new. + HRLM U2,$PNPTR(U3) ; And zap successor also. + MOVEI U4,$PVLID ; Final touch to active node is ID... + HRLM U4,$PNFLG(U2) ; set it. +IFN OS%ITS,{ + MOVE U4,$PNPTR(U3) + TRNN U4,-1 + PJRST PSRCOR +} + POPJ P, + +IFN OS%ITS,{ + +IFDEF CORLUZ,.SCALAR CBKERR + +PSRCOR: HLRZ U4,$PNBLK(U2) ; Get length of block + ADD U4,$PNBLK(U2) ; Find first unused addr + MOVEI U4,PG$SIZ-1(U4) ; Clear LH and adjust for + LSH U4,-PG$BTS ; finding 1st unused page #. + CAMG U4,FFPAGE + POPJ P, + PUSH P,U4 + SUB U4,FFPAGE + IMUL U4,[-1,,] + HRR U4,FFPAGE +IFDEF CORLUZ,[ + SETZM CBKERR + SYSCAL CORBLK,[ MOVEI %CBNDR+%CBNDW + MOVEI %JSELF + U4 + MOVEI %JSNEW + %CLERR,,CBKERR] + CORLUZ +] +.ELSE,[ + SYSCAL CORBLK,[ MOVEI %CBNDR+%CBNDW + MOVEI %JSELF + U4 + MOVEI %JSNEW] + PSRERR EROOM +] + POP P,FFPAGE + POPJ P, + +};OS%ITS + + +subttl Primitives - Merging, Freeing, Copying + +; PSRMKU - Make unactive, put node on spacelist. +; U3 - ptr to node to put on spacelist. +; Clobbers U4 + +PSRMK2: MOVEI U3,(U2) +PSRMKU: MOVE U4,SPCLST + HRLI U4,SPCLST-$PNSPP + MOVEM U4,$PNSPP(U3) + TRNE U4,-1 ; If successor exists, + HRLM U3,$PNSPP(U4) ; zap it. + HRRZM U3,SPCLST ; and zap predecessor. + HRRZS $PNFLG(U3) ; Also zap ID check. + POPJ P, + +; PSRMRG - Merge two adjacent blocks +; U2 - ptr to node, 1st block (only count is changed) +; U3 - ptr to node, 2nd block (can be on Spacelist or Corelist) +; Clobbers U3,U4 + +PSRMRG: HRRZ U3,$PNPTR(U2) ; Get addr of succ + CAIN U3, ; Make sure actually have a successor. + PSRERR ERARG ; Caller screwed up. + HLLZ U4,$PNBLK(U3) ; Get # words in U3 node, and use to + ADDM U4,$PNBLK(U2) ; increment count of current block. + PUSHJ P,PSRFRE ; Free U3 node. + POPJ P, + + + +; PSRACT - Make U3 block active (already on corelist, just take off +; the spacelist) +; Clobbers U4 + +PSRACT: MOVEI U4,$PVLID ; Insert ID check + HRLM U4,$PNFLG(U3) ; into node for future refs by user prog. +PSRACX: MOVE U4,$PNSPP(U3) + TRNE U4,-1 ; Test for successor + HLLM U4,$PNSPP(U4) ; Zap successor if there's one. + MOVSS U4 + HLRM U4,$PNSPP(U4) ; Zap predecessor (always) + SETZM $PNSPP(U3) + POPJ P, + + +; PSRFRE - Puts U3 block on Freelist. Takes it off Spacelist/Corelist as nec. +; PSRFRX - Ditto but assumes block isn't on Spacelist. +; PSRFR - Ditto but assumes block isn't on Corelist or Spacelist. +; All clobber U4. + +PSRFRE: SKIPE $PNSPP(U3) ; On spacelist? + PUSHJ P,PSRACX ; Take it off, so it's only on corelist. +PSRFRX: MOVE U4,$PNPTR(U3) ; Get ,, + TRNE U4,-1 + HLLM U4,$PNPTR(U4) ; Zap successor if one. + MOVSS U4 + HLRM U4,$PNPTR(U4) ; Zap predecessor (always) + +PSRFR: MOVE U4,FRELST + MOVEM U4,$PNPTR(U3) + HRRZM U3,FRELST + POPJ P, + +; PSRCPY - Copy block from U3 to U2. Overlap is OK as long as +; U2 < U3. +; Clobbers U4 + +PSRCPY: PUSH P,U2 + MOVE U2,$PNBLK(U2) ; Get address + HRL U2,$PNBLK(U3) ; Get address + HLRZ U4,$PNBLK(U3) ; Get # words to copy + ADDI U4,-1(U2) ; Find last word to copy into + BLT U2,(U4) + POP P,U2 + POPJ P, + + +subttl Primitives - PSRGTN - Get free node. + +; PSRGTN - Get a node. +; Returns addr in U2. + +PSRGTN: SKIPN U2,FRELST ; Get pointer to current free list + JRST PSRGN3 ; None left? Make more. + HRL U2,(U2) ; Get ptr to next free node + HLRZM U2,FRELST ; and store it away. + POPJ P, + + ; Must make new nodes. Requires getting new block recursively, + ; with special hack. +PSRGN3: MOVE U2,FRESAV ; Make a freelist pointing to special + MOVEM U2,FRELST ; node saved just for this occasion. + PUSH P,U1 ; Because PSRGET will need one... + MOVEI U1,$PNSIZ*$PMAKN ; Get this many words for new block + PUSHJ P,PSRGET ; Call recursively. + HLRZ U2,U2 ; Get blk addr by itself + PUSHJ P,PSRMKF ; Make a freelist out of block. + HRRZ U1,(U2) ; Get ptr to second node on list, + MOVEM U1,FRELST ; and make that the new freelist. + SETZM (U2) ; While first node on list becomes the + HRRZM U2,FRESAV ; saved node. + POP P,U1 + JRST PSRGTN + + +; PSRMKF - Makes freelist out of piece of core. +; U1 - # words +; U2 - address of block +; Clobbers U1. U2 (same) will point to 1st node on freelist. + +PSRMKF: CAIGE U1,$PNSIZ*2 ; Must be able to make at least two. + PSRERR ERARG ; Caller screwed up. + PUSH P,U2 + + PUSH P,U1 ; First must zap whole block... + ADDI U1,(U2) ; addr to last wd + 1 + HRLI U2,(U2) + ADDI U2,1 ; addr,,addr+1 + SETZM -1(U2) + BLT U2,-1(U1) ; Clear all of block. + POP P,U1 ; restore size. + + IDIVI U1,$PNSIZ ; Find # possible nodes. + MOVE U2,(P) ; Restore addr of block + MOVNI U1,(U1) + HRLI U2,(U1) ; Have -<# nodes>,, + +PSRMF2: MOVEI U1,$PNSIZ(U2) ; Get ptr to next node + MOVEM U1,(U2) ; Store in current node + ADDI U2,$PNSIZ-1 + AOBJN U2,PSRMF2 + + SETZM -$PNSIZ(U2) ; Clear out last node to terminate list. + POP P,U2 + POPJ P, + + + +subttl Debugging aid - DEBCOR + +; Debugging printout routine. Requires MACROS/NUUOS/OUT. + +IFN $$PDBG,{ +DBC==17 + +DEBRET: JSR DEBRST + POPJ P, + +DEBCOR: JSR DEBSAV + SKIPN A,CORLST + JRST [ FWRITE DBC,[[ No Corelist!!! +]] + JRST DEBRET] + FWRITE DBC,[[Core list:]] +DEBCR2: FWRITE DBC,[[ +Node ],RHV,A,[ Blk ],RHV,$PNBLK(A),[/ ],LHV,$PNBLK(A),[ wds, ]] + HRRZ B,$PNBLK(A) + ANDI B,PG$MSK + CAIE B, + SUBI B,PG$SIZ + HLRZ C,$PNBLK(A) + ADDI B,(C) + ASH B,-PG$BTS + CAIGE B, + SETZ B, + FWRITE DBC,[N8,B,[ pgs ]] + SKIPN $PNSPP(A) + JRST [ FWRITE DBC,[[ACTIVE]] + JRST DEBCR4] + FWRITE DBC,[[FREE, Spacelist ptrs: ],LHV,$PNSPP(A),[,,],RHV,$PNSPP(A)] +DEBCR4: FWRITE DBC,[[ +]] + ; Now verify ID, if active. + SKIPN $PNSPP(A) ; Active? + JRST [ HLRZ B,$PNFLG(A) ; Yes, get ID. + CAIN B,$PVLID ; See if valid. + JRST .+1 ; Yup. + FWRITE DBC,[[ Bad ID! Should be ],RHV,[[$PVLID]],[, is ],RHV,B,[ +]] + JRST .+1] + + ; Now verify that next node points back to this node. + HRRZ C,$PNPTR(A) ; Get addr of successor + JUMPE C,DEBC60 ; No successor? Done. + HLRZ B,$PNPTR(C) ; Get successor's pred + CAIN A,(B) ; Should point back to current node. + JRST DEBC40 ; Yep, no sweat here. + + ; Ugh, list failure!! + FWRITE DBC,[[ Succ node has bad pred! + This node: ],RHV,A,[/ ],LHV,$PNPTR(A),[,,],RHV,$PNPTR(A),[ + Next node: ],RHV,C,[/ ],LHV,$PNPTR(C),[,,],RHV,$PNPTR(C),[ +]] + ; Probably screwed from here on, but continue anyway. + + ; Now verify that next node's block is successor to current block. +DEBC40: HRRZ D,$PNBLK(A) ; Get block addr + HLRZ C,$PNBLK(A) ; and # wds + ADDI D,(C) ; to find next addr after this block. + HRRZ B,$PNPTR(A) ; Get ptr to successor node + JUMPE B,DEBC60 ; If no successor, done with corelist. + HRRZ C,$PNBLK(B) ; Get address next block starts at. + CAIN C,(D) ; Compare... + JRST DEBC50 ; Equal, all's well, so process next. + + ; Ugh, next block isn't contiguous to this one! + FWRITE DBC,[[ Next block not contiguous!! + Should start at ],RHV,D,[, but succ node claims ],RHV,C,[ +]] + +DEBC50: HRRZ B,$PNPTR(A) + JUMPE B,DEBC60 + MOVEI A,(B) + JRST DEBCR2 + + ; Corelist done, now write out Spacelist. +DEBC60: FWRITE DBC,[[End of Corelist, last managed addr is ]] + HRRZ C,$PNBLK(A) ; Get 1st inaccessible addr + HLRZ D,$PNBLK(A) ; according to last node on spacelist + ADDI C,-1(D) ; via +<# wds>-1 + FWRITE DBC,[N8,C,[ +First free page is ],N8,FFPAGE,[ at ]] + MOVE B,FFPAGE + IMULI B,PG$SIZ + FWRITE DBC,[N8,B,[ +----------------------------- +Spacelist:]] + SKIPN A,SPCLST + JRST [ FWRITE DBC,[[ 0 ??]] + JRST DEBRET] + MOVEI A,SPCLST-$PNSPP +DEBC70: HLRZ B,$PNSPP(A) + SETZ C, + CAIE B, + HRRZ C,$PNSPP(B) + CAIE A,(C) + JRST [ FWRITE DBC,[N8,B] + JRST .+1] + CAIN A,(C) + JRST [ FWRITE DBC,[[*]] + JRST .+1] + FWRITE DBC,[[.]] + HRRZ A,$PNSPP(A) + JUMPE A,[FWRITE DBC,[[0]] + JRST DEBC90] +DEBC75: FWRITE DBC,[[* -> ],N8,A,[:]] + JRST DEBC70 + +DEBC90: FWRITE DBC,[[ +Done. +]] + JRST DEBRET + +; Save/restore support for PAGSER debug stuff. Requires MACROS/NUUOS/OUT. + +LVAR DEBSAV: 0 ? JRST DEBSV0 ; jump to pure +LVAR DEBACS: BLOCK 20 + +DEBSV0: PUSH P,U40 +IFE $$UCAL,PUSH P,UUORPC + MOVEM 17,DEBACS+17 + MOVEI 17,DEBACS + BLT 17,DEBACS+16 ; Save ACs + MOVE 17,DEBACS+17 +IFN OS%ITS,[ + .OPEN DBC,[.UAO,,'TTY] + .VALUE + OUT(DBC,OPEN(UC$IOT)) +] +IFN OS%TNX, OUT(DBC,OPEN(UC$IOT,[.PRIOU])) + JRST @DEBSAV + +LVAR DEBRST: 0 ? JRST DEBRS0 ; jump to pure + +DEBRS0: +IFN OS%ITS,.CLOSE DBC, + MOVSI 17,DEBACS + BLT 17,17 +IFE $$UCAL,POP P,UUORPC + POP P,U40 + JRST @DEBRST + +} ;end ifn $$pdbg + +.END PAGSER diff --git a/src/sysnet/ftps.336 b/src/sysnet/ftps.336 new file mode 100755 index 00000000..4f40ad99 --- /dev/null +++ b/src/sysnet/ftps.336 @@ -0,0 +1,2873 @@ +.SYMTAB 5001.,7000. ;-*-MIDAS-*- + +TITLE FTPS ;New FTP server + ; Written by KLH @ MIT-AI using UUO package. + +;;; After months of frustration I cannot stand it any more. +;;; Since those pinheads at Thinking Machines insist on +;;; writing broken copies of the NAMES file to .MAIL., I have +;;; disallowed that from now on. -- Gumby + +IFNDEF $.ARPA,$.ARPA==0 ;1 to do .ARPA kludges +IFNDEF $$DM,$$DM==0 ;1 to include COMSYS interface + +.MLLIT==1 + + ; Service Port assignments +SPNFTP==3 ; NCP FTP socket for ICP +SPTFTP==25 ; TCP FTP port +SPSMTP==31 ; SMTP port (both NCP/TCP) + +F=0 ; Flag reg +A=1 ; A-E general utility +B=2 +C=3 +D=4 +E=5 +T=6 ; Needed for NETWRK +TT=7 +R=10 ; Holds IDX into rcpt string array. +I=11 ; Interrupt handler acc +OC=12 ; Output channel index +U1=13 ;UUO accs +U2=14 +U3=15 +U4=16 +P=17 ; Standard PDL reg + + ; I/O Channel assignments +NETICP==1 ; Net ICP channel. Keep this, NETI, NETO on these numbers! +NETI==2 ; Net input +NETO==3 ; Net output +NETD==4 ; Net data channel +DC==5 ; general purpose dsk channel (in and out) +DMC==6 ; dsk chan for mail file output on DM +ERRCHN==15 ; for OUT error output +STRC==16 ; UUO string output channel +TMPC==17 ; temp UUO chan + + ;LH flags +%DMSW==1 ; set when on DM +%ICPFF==2 ; Set during ICP phase +%LTCP==4 ; Set if using TCP (not NCP) +%LSMTP==10 ; Set if pretending to be SMTP +%LCHAOS==20 ; Set if Chaosnet SMTP + + ; RH flags +%NTDIR==1 ; 0 when attempting input net data conn, 1 for output. +%TMP==2 ;random temp +%CR==4 ;set when last net input char was CR +%DEC==10 ;used by numerical parser to indicate # is decimal + + ; Random params +SKTNUM==10 ; # of sockets available (limited by ITS) +UBPFJ==10 ; Magic bit for .OPEN on USR device to not reown + +LPAREN==:"( ; All right, so I'm paranoid +RPAREN==:") + + SUBTTL Random locations and Interrupt handler + +LOC 41 + JSR UUOH ; To UUO package. + JSR TSINT +LOC 100 + ;also use time routines +DATIME"$$OUT==0 ; Use the OUT package's printing rtns +DATIME"$$DSTB==1 ; DST bit in time words +DATIME"$$ABS==1 ; Absolute days/seconds conversions +DATIME"$$OUTT==1 ; Tables for pretty output +DATIME"$$UPTM==1 ; Rtns for system time-in-30'ths conversions +.INSRT DSK:SYSENG;DATIME > + +;Use standard NETWRK routines (to get host table file) +IFE $.ARPA,$$NEW3==1 +$$HST3==1 +$$HSTMAP==1 ;access HOSTS3 file +$$HSTSIX==1 ;want sixbit host name abbreviations +$$SERVE==1 ;Server ICP +$$SYSDBG==1 ;We handle SYSDBG ourselves +$$ARPA==1 ;Support Arpanet +$$CHAOS==1 ;Support Chaosnet too +$$OWNHST==1 ;Want OWNHST routine +;$$CVH==1 ;Need host-number conversion routines + +.INSRT SYSENG;NETWRK > + +.INSRT SYSENG; FSDEFS > + +$$OUT==1 ; Use new output stuff +$$OTIM==1 ; With time output stuff +$$OERR==1 ; and error output +$$OHST==1 ; and host output +UAREAS==1 ; Assemble UUO areas +USTRGS==1 ; and string hackery. +.INSRT KSC;NUUOS > + ;and wonderful filename parser +.INSRT KSC;NFNPAR > + +CONSTANTS + +;;; Additional FWRITE goodies: + +DEFINE CCONC LOC,LIST ; For concatenating stuff to existing string. + PUSHJ P,[BCONC LOC + FWRITE STRC,[LIST] + ECONC LOC + POPJ P,] +TERMIN + +DEFWR EOL,,OXEOL + + +PAT: +PATCH: BLOCK 100 +PDLLEN==100 +PDL: BLOCK PDLLEN + + ; Losing sites list. +LUZRL==10. +LUZRS: BLOCK LUZRL + ; Very sad feature. +ASSMSG: ASCSTR [530 Your host prohibited] + + ; Apply salt & butter here. +POPBA1: AOS -2(P) +POPBAJ: POP P,B + POP P,A + POPJ P, +POPJ1: AOS (P) + POPJ P, + +POPAJ1: AOS -1(P) +POPAJ: POP P,A +CPOPJ: +APOPJ: POPJ P, + +POPCBJ: POP P,C +POPBJ: POP P,B + POPJ P, + +JUNK: 0 ;for random useless writes +ARPHST: 0 ;junk for NETWRK +SMTPSW: 0 ; -1 = Refuse SMTP service (for when COMSAT gronked). +SENDSW: 0 ; If sending, -1 don't mail. 0 mail if failed. 1 always mail. +SORMSW: 0 ; 0 mail, -1 send. +DEBUG: 0 ; Non-zero when debugging. + ; +1 => don't logout when done + ; -1 => just say "debug" in greeting + ; -1 => don't logout if error, but currently we never + ; logout if error (see code at AUTPSY) +VERSHN: .FNAM2 + + + ;Interrupt handler - mostly for fatal conditions +TSINT: 0 + 0 + MOVEM I,ISAVE' ;for debugging, just in case + SKIPGE I,TSINT + .DISMIS TSINT+1 ;if not 1st wd interrupt, ignore. + TDNE I,[%PIIOC] + JSR IOCERR + TDNN I,[%PIRLT] + JSR AUTPSY ;die here for unknown 1st wd interrupt + TLNE F,%ICPFF + JSR LOGOUT ;die here if .REALT interrupt within ICP... + MOVE I,ALIVEC ; Get activity count as of last int + CAMN I,LASTRI ; See if aliveness count changed + JSR LOGOUT ; No, die of boredom. + MOVEM I,LASTRI + .DISMIS TSINT+1 ;else stay alive and continue + +IOCERR: 0 + .SUSET [.RBCHN,,I] ;Find erring channel. + CAIE I,DC ;Disk error? + JRST IOCER1 ; No. + SKIPE STOIOC ;Writing some data file? + JRST STOIOC+1 ; Yes - handle it. +IOCER1: CAIL I,NETICP ;Else better be IOC error on network. + CAILE I,NETD + JSR AUTPSY ;Unknown IOC error, die. + JSR LOGOUT ;Ah, user end closed connections, die quietly + +LASTRI: 0 +ALIVEC: 0 + + ;; Disk writing IOC error handling + +STOIOC: 0 ;Return addr. + SYSCAL DELEWO,[%CLIMM,,DC] ;Flush file being written. + NOP + .CLOSE DC, + SYSCAL DISMIS,[ %CLIMM,,TSINT ? STOIOC ? [0] ? [0]] + + ;; Ways out. + +LOGOUT: 0 ;JSR'd to for more or less normal disappearance. + SKIPG DEBUG ; If +1, never logout + .LOGOUT + .VALUE + +AUTPSY: 0 ;JSR'd to for oddball condition or bug. + ;(referenced by UUO handler) + .VALUE + JRST .-1 + + +BUFFAR: BLOCK $ARSIZ ; ARBLK for buffer area holding stuff transferred. +TMPAR: BLOCK $ARSIZ ; ARBLK for temp translation buffer (TCP image mode) +DIRAR: BLOCK $ARSIZ ; ARBLK for directory buffer +DCTYPE: 0 ; Transfer Type. 0=ASCII, -1=Image, 1=Local-byte +DCBYTE: 0 ; Byte size. One of 8., 32., 36. +USRNAM: 0 ; User name, as set by USER. +ERRCOD: 0 ; Error code returned by last .CALL + +LDSOC: 0 ;lcl skt for data skt open +FDSOC: 0 ;frn skt for data skt open +FDHST: 0 ;frn hst for data skt open +FSDSKT: 0 ; Foreign Specially-specified data socket to use +FSDHST: 0 ; ditto, site to use + + +DEFDEV: SIXBIT /DSK/ ; Initial default file spec for a transfer. +DEFDIR: SIXBIT /(NIL)/ +DEFFN1: SIXBIT /_FTPS_/ +DEFFN2: SIXBIT />/ + +DEFSTR: BLOCK 4 ;Starred default stuff for NLST +MASK1: 0 +MASK2: 0 + +FILDEV: 0 ; Actual file spec in use. +FILDIR: 0 +FILFN1: 0 +FILFN2: 0 + +RCHDEV: 0 ; To hold file spec as returned by RCHST. +RCHDIR: 0 +RCHFN1: 0 +RCHFN2: 0 + +FTPOF1: SIXBIT /_FTPS_/ ; Filenames to use for writing +FTPOF2: SIXBIT /OUTPUT/ + +AIMDEV: SIXBIT /DSK/ ; File spec for COMSAT mail request. +AIMDIR: SIXBIT /.MAIL./ +AIMFN1: SIXBIT /MAIL/ +AIMFN2: SIXBIT />/ +AIMXF1: SIXBIT /XMAIL/ ; Debug file spec, if XDBG seen. + +DMMDEV: SIXBIT /DSK/ ; File spec for COMSYS mail request. +DMMDIR: SIXBIT /COMSYS/ +DMMFN1: SIXBIT /M/ +DMMFN2: SIXBIT />/ + +NETDEV: SIXBIT /NET/ ; Device for NET. + +DEFFLG: 0 ; Default startup flags for F +ICPSOC: SPNFTP ; Initial port/socket # to receive conn on +LOCSOC: 0 ; Holds base local socket # (S) +FRNSOC: 0 ; Holds " foreign " (U) +FRNHST: 0 ; Holds host # we're serving. (new format, with network-number) +OLDHSN: 0 ; Old-format, without network-number, temporary for mailers + +RCHBLK: BLOCK 10 ;used by .RCHST calls +SYSDBG: 0 ; System debug switch +MACHNM: 0 ; Machine name (AI,MC,ML,DM) +ITSVER: 0 ; ITS version # in sixbit +OWNHST: 0 ; # of own site. +OWNNAM: 0 ; Addr of ASCIZ string for own site-name. +XDBGSW: 0 ; -1 if XDBG command seen + SUBTTL Start and ICP + + ; Start of program +GO: MOVEI P,PDL ; Init PDL pointer + MOVE C,0 ; Save possible arg from invoker + MOVE F,DEFFLG ; Set default startup flags. + CALL DATIME"UPINI ; Find the time. + JSR LOGOUT ; Give up if unknown. + ; Find out what kind of server we're supposed to be. + .SUSET [.RXJNAM,,B] ; Get JNAME + CAMN B,[SIXBIT /FTP/] + MOVE C,[SIXBIT /RFC003/] + HLRZ D,C ; Get possible 'SYN or 'RFC + CAMN B,[SIXBIT /TCP/] ; Invoked by TCP handler? + JRST [ TLO F,%LTCP ; Yup, say we're hacking TCP conns + .SUSET [.SXJNAM,,[SIXBIT /FTPS/]] ; set JNAME + MOVEI B,SPTFTP ; Set up default port # + CAIE D,'SYN ; Was specific port given? + JRST GO4 ; Nope + JRST GO2] ; Yup, decipher it. + CAMN B,[SIXBIT /CHAOS/] + JRST GOCHA + CAIE D,'RFC + JRST [ .SUSET [.RSNAM,,A] + HLRZ D,A + CAIE D,'RFC + JRST GO5 ; No match, assume ICPSOC set up. + JRST .+1] +GO2: MOVE A,C + MOVEI B,(A) ; Convert RH of SIXBIT to port # + ANDI B,7 ; Get low 3 bits + LDB C,[.BP 700,A] ; Get and add next 3 higher bits + LSH C,3 + ADDI B,(C) + LDB C,[.BP 70000,A] ; Then next 3 bits + LSH C,6 + ADDI B,(C) +GO4: MOVEM B,ICPSOC + + ; Now set flags and thence SNAME to right stuff for port. + ; %LTCP has already been set if it was going to be. + ; Default is flags from DEFFLG. +GO5: MOVE B,ICPSOC + CAIN B,SPSMTP ; Using SMTP service port? + JRST [ TLO F,%LSMTP ; Yeah, say to act like SMTP. + .SUSET [.SXJNAM,,[SIXBIT /SMTP/]] ; say that's who we are + JRST .+1] + ; Set timer to log out if icp not finished within 60 sec. + TLO F,%ICPFF ;indicate icp phase + MOVE A,[600000,,[60.*60.]] ;flush old ticks, start + .REALT A, ;new rate, 60 sec frame(ints). + .SUSET [.SMASK,,[%PIIOC+%PIRLT]] ;enable ioc and realt + .SUSET [.SPICLR,,[-1]] ;enable ints + + ; Start ICP + TLNE F,%LTCP ; If not hacking TCP, use NCP. + JRST GOTCP ; Aha, must listen with TCP. + + ; NCP listen open. + MOVEI A,NETICP ;Group of 3 channels + MOVE B,ICPSOC ; Get ICP socket # to use + MOVE C,[40+.UAI,,40+.UAO] ;I,,O Modes + PUSHJ P,NETWRK"ARPSRV ;Do server ICP for Arpanet + JSR LOGOUT ;Timed out + MOVEM B,FRNHST ; Save host, find out sockets + SYSCAL RCHST,[MOVEI NETI ? CRET A ? CRET LOCSOC ? CRET A] + JSR LOGOUT + SUBI A,3 + MOVEM A,FRNSOC + JRST GO99 ; C nonzero if locked out by SYSDBG + +GOCHA: TLO F,%LSMTP+%LCHAOS ;Chaosnet SMTP server + MOVEI A,NETI + MOVEI C,[ASCIZ/SMTP/] + MOVEI D,8 + PUSHJ P,NETWRK"CHASRV + JSR LOGOUT + TLO B,NETWRK"NW%CHS + MOVEM B,FRNHST + .SUSET [.SMASK,,[%PIIOC+%PIRLT]] ;enable ioc and realt + .SUSET [.SPICLR,,[-1]] ;enable ints + MOVE A,[600000,,[5*60.*60.]] ;check connection every 5 minutes + .REALT A, + JRST MAINIT + +GOTCP: SYSCAL TCPOPN,[MOVEI NETI ? MOVEI NETO ? ICPSOC + [-1] ? [-1]] ; Wild fgn port and host. + JSR LOGOUT ; Bah, failed for some reason. + MOVEI A,%NSLSN ; Initial state to hang on. +GOTCP2: SYSCAL NETBLK,[MOVEI NETO ? A ? MOVEM A] + JSR LOGOUT ; Gack?? + CAIN A,%NSRFC ; If in SYN-RECEIVED state + JRST GOTCP2 ; then it's OK to keep waiting. + CAIE A,%NSOPN ; Else should be open now. + CAIN A,%NSRFN + CAIA + JSR LOGOUT ; Aw, phooie. + + ; TCP connection open now. + SYSCAL RFNAME,[MOVEI NETO ? MOVEM A + MOVEM LOCSOC ; Local port # (should be = ICPSOC) + MOVEM FRNSOC + MOVEM A] ;Foreign host + JSR LOGOUT +; PUSHJ P,NETWRK"CVH2NA ; Convert to format mailer expects + MOVEM A,FRNHST + ; Drop through + +GO99: TLNN F,%LTCP ; If TCP, don't turn off clock. + .SUSET [.SAMASK,,[%PIRLT]] ; Now can turn off REALT, because + TLNE F,%LTCP + JRST [ MOVE A,[600000,,[5*60.*60.]] ;flush old ticks, start + .REALT A, ;new rate, 5 min frame(ints). + JRST .+1] + AOS ALIVEC + TLZ F,%ICPFF ; ICP finished! + JRST MAINIT ; ICP done, fall through to initialization. + SUBTTL Post-ICP Initialization + +MAINIT: OUTOPN NETO, ; Initialize .IOT/SIOT output channel. + SYSCAL SSTATU,[CRET JUNK ? CRET SYSDBG + REPEAT 3, CRET JUNK + CRET MACHNM + CRET ITSVER] + JSR AUTPSY + SKIPGE SYSDBG + JRST [ MOVEI A,[ASCSTR [421 System is being debugged, sorry.]] + TLNN F,%LTCP ;Message is different for NCP. + MOVEI A,[ASCSTR [401 System is being debugged, sorry.]] + PUSHJ P,NETREP + JSR LOGOUT] + ;From this point on we are committed to coming up. + HRRZ A,ARPAGS ;Map in the hosts file + MOVEI B,NETICP ;Use this I/O channel for disk + PUSHJ P,NETWRK"HSTMAP + JSR AUTPSY + SUB A,ARPAGS ;RH(A) gets number of pages used + HRL A,A + ADDM A,ARPAGS ;use them up + UARINIT ARPAGS ;initialize core + STRINIT ;initialize strings + MOVE A,[NETWRK"NW%ARP] ; Look us up on Arpanet + PUSHJ P,NETWRK"OWNHST ; Get # of own site. + JRST [ MOVE A,[NETWRK"NW%CHS] ; Hmm, maybe we're chaos-only? + PUSHJ P,NETWRK"OWNHST + JSR AUTPSY ; Guess not + JRST .+1 ] ; Yep, CHAOS/SMTP or something + MOVEM A,OWNHST ; Save # of own site. + CAMN A,[NETWRK"NW%ARP+<1_16.>+6] ; Host addr for MIT-DM + TLO F,%DMSW + MOVE B,OWNHST + PUSHJ P,NETWRK"HSTSRC ;RH(A) -> host name, D -> numbers table entry + JSR AUTPSY ;We don't exist? + HRRZM A,OWNNAM ;store (points to ASCIZ site name) + MOVE A,FRNHST ;Get sixbit host name + PUSHJ P,NETWRK"HSTSIX + JSR AUTPSY + MOVE E,A + .SUSET [.RINTB,,B] ; See if toplevel and can login + JUMPGE B,MAIN40 ;if sign bit not set, nope. skip login. + MOVE A,FRNHST + TLZ A,777000 ;Clear network number + TDNN A,[177700000] ;Try to reduce to old-style number + TRNE A,374 + JRST BIGHST ;Can't + LDB B,[000200,,A] + LSH B,6 + LSH A,-9 + IOR A,B +BIGHST: MOVEM A,OLDHSN ;Save old-format host# for mailer + SETZ B, ; Else begin messy algorithm to produce UNAME... +REPEAT 3,[LSHC A,-3 + LSH B,-3 + TLO B,200000 +] + .SUSET [.RUNAME,,A] + ANDI A,7777 + HRRI B,'F_12. + TLNE F,%LSMTP ; If we're supposed to be SMTP, + HRRI B,'M_12. ; use nnnMjj for Mail server. + IOR B,A ;nnnFjj (nnn= site #, jj= job #) + SYSCAL LOGIN,[B ? E] + AOJA B,.-1 ; Keep trying. + +MAIN40: .SUSET [.SSNAME,,E] ; For PEEK + MOVE A,FRNHST + PUSHJ P,ASSHOL ; Vandelous host? + JRST [ MOVEI A,ASSMSG ; Sigh, go away. + PUSHJ P,NETREP + JSR LOGOUT] ; See yah! + TLNE F,%LSMTP + JRST MAIN41 ;SMTP protocol works differently + SKIPE SYSDBG + JRST [ MOVEI A,[ASCSTR [050 System is being debugged -- proceed with caution!]] + PUSHJ P,NETREP + JRST .+1] + SKIPE DEBUG + JRST [ MOVEI A,[ASCSTR [050 FTP server is being debugged -- proceed with caution!]] + PUSHJ P,NETREP + JRST .+1] + TLNN F,%LTCP + JRST [ MAKSTR REPLY,[[300- ],TZ,@OWNNAM,[ ITS ],6F,ITSVER,[, FTP server ],6F,VERSHN,[ on ],WBI,,[ +300 Bugs/gripes to BUG-FTP @ MIT-MC]] + JRST MAIN45 ] + + MAKSTR REPLY,[[220- ],TZ,@OWNNAM,[ ITS ],6F,ITSVER,[, FTP server ],6F,VERSHN,[ on ],WBI,,[ +220 Bugs/gripes to BUG-FTP @ MIT-MC]] + JRST MAIN45 + +;In SMTP, not allowed to send preliminary replies, so just send one long line. +MAIN41: MAKSTR REPLY,[[220 ],TZ,@OWNNAM,[ ITS ],6F,ITSVER,[, SMTP server ],6F,VERSHN,[ on ],WBI,,] + SKIPE SYSDBG + CCONC REPLY,[[; ITS is being debugged -- proceed with caution!]] + SKIPE DEBUG + CCONC REPLY,[[; Server is being debugged -- proceed with caution!]] + +MAIN45: MOVEI A,REPLY + PUSHJ P,NETREP + + SETZM DCTYPE ; Initialize TYPE to ASCII + MOVEI A,8. + MOVEM A,DCBYTE ; and correspondingly BYTE size must be 8. + ;drop thru to mainline + SUBTTL MAIN LOOP + + ; Very simple command dispatcher. + SETZM NCMXCT ; Zero # FTP commands executed. +MAIN: AOS ALIVEC + PUSHJ P,GETNLN ;get a line (into LINPUT) + MOVEI B,40 ; Parse up to space + PUSHJ P,PRSWRD ; parse a word off, ptr to word string in B, rest in A. + MAKSTR ARGSTR,[TS,(A)] ; Store rest of line in ARGSTR. + MOVE A,B ; Now convert the word + PUSHJ P,CVSIX ; to sixbit. + MOVE C,[-NCOMS,,COMTAB] ; Default to FTP commands + TLNE F,%LSMTP ; and if using SMTP + MOVE C,[-NSCOMS,,SCMTAB] ; then use a somewhat different table. +MAIN10: MOVE B,(C) ; Loop thru command table testing... + CAME A,(B) + AOBJN C,MAIN10 + JUMPGE C,MAIN70 ; Counted out => Bad command! + HLRZ B,(C) ; Aha, get the routine for it. + MOVEI A,ARGSTR ; Set up pointer to arg + PUSHJ P,STRIM ; Perform helpful trimming of blanks front and rear. + PUSHJ P,(B) ; and execute command, + AOS NCMXCT ; bumping "executed" count and + JRST MAIN ; returning to loop when done. + +MAIN70: MAKSTR REPLY,[[500 Unrecognized command: ],6F,A] + MOVEI A,REPLY + PUSHJ P,NETREP + JRST MAIN + +NCMXCT: 0 ; # FTP commands executed since startup. + + + ; Command dispatch table. Routines for commands are + ; allowed to use ACs A-E freely, since the MAIN loop + ; requires nothing saved between commands. +DEFINE COMM NAME,ADDR +ADDR,,[SIXBIT /NAME/] +TERMIN + +COMTAB: COMM USER,USER ; Log in as . Just sets default directory. + COMM XCWD,XCWD ; Change working dir to . Almost same as USER. + COMM CWD,XCWD ; Goddamn brain damage + COMM PASS,PASS ; is a (gasp! shudder!) PASSWORD?? + COMM ACCT,ACCT ; purports to be (ugh bletch!) Account?? + COMM BYTE,BYTE ; Set byte size of data conn to (8, 36) + COMM SOCK,SOCK ; = socket # to connect data chan to. + COMM TYPE,TYPE ; Set data conn type to (A, I) + COMM STRU,STRU ; Set structure mode to (F only) + COMM MODE,MODE ; Transfer mode. S only. + COMM DELE,DELE ; Delete + COMM RNFR,RNFR ; Rename From , followed by RNTO + COMM RNTO,RNTO ; Rename To , completes RNFR. + COMM LIST,LIST ; List on data connection + COMM RETR,RETR ; Send over data connection. + COMM STOR,STOR ; Write data to + COMM MLFL,MLFL ; Mail junk to over data connection. + COMM MAIL,MAIL ; Mail junk to + COMM XRSQ,XRSQ ; Specify to use with XRCP. + COMM XRCP,XRCP ; Specify as rcpt for message text. + COMM XSEN,XSEN ; Like MAIL, but do CLI only. (SEND) + COMM XSEM,XSEM ; SEND, and Mail if fail. + COMM XMAS,XMAS ; Mail And Send text as gift. + COMM NOOP,NOOP ; NOOP as in JFCL. + COMM ALLO,NOOP ; Don't need ALLOCATE, so treat as NOOP. + COMM BYE,BYE ; Bye bye. + COMM QUIT,BYE ; Ditto + COMM REIN,UNIMPL ; Reinitialize, not implemented. Could be. + COMM APPE,UNIMPL ; Append, not implemented.(Could be for ASCII file/conn) + COMM PASV,UNIMPL ; Passive, not implem. (don't know if possible) + COMM REST,UNIMPL ; Restart (File xfer). Ugh. + COMM NLST,NLST ; Name-list for directory. + COMM SITE,UNIMPL ; Site parameters, but we have nothing special. + COMM STAT,STAT ; Status of server or (if ) specified file. Ugh. + COMM HELP,UNIMPL ; Info re server implementation status. Could, but why? + COMM ABOR,UNIMPL ; Abort current command, like xfer. Ugh!! + COMM XLBT,XLBT ; Loop-back test + + ; New stuff for TCP FTP + COMM PORT,PORT ; New cmd similar to SOCK + COMM MSND,XSEN ; Official name for XSEN + COMM MSOM,XSEM ; Official name for XSEM + COMM MSAM,XMAS ; Official name for XMAS (sigh) + COMM MRSQ,XRSQ ; Ditto for XRSQ + COMM MRCP,XRCP ; Ditto for XRCP + + COMM XDBG,XDBG ; Hack debug stuff +NCOMS==.-COMTAB + + ; SMTP command dispatch table +SCMTAB: COMM HELO,SMHELO + COMM MAIL,SMMAIL + COMM RCPT,SMRCPT + COMM DATA,SMDATA + COMM RSET,SMRSET + COMM NOOP,SMNOOP + COMM QUIT,SMQUIT + COMM SEND,SMSEND + COMM SOML,SMSOML + COMM SAML,SMSAML + COMM VRFY,UNIMPL + COMM EXPN,UNIMPL + COMM HELP,UNIMPL + COMM XDBG,XDBG ; Hack debug stuff +NSCOMS==.-SCMTAB + + ; Commonly used return addresses +ACKENR: MOVEI A,REPLY ; PJRST ACKENR uses whatever string is in REPLY. +ACKEND: ; PJRST ACKEND is also common; same as NETREP. + ; Fall thru... + +; NETREP - Network Reply, sends string pointed to by A out over +; command connections and follows up with terminating CRLF. +NETREP: OUTS NETO,(A) + OUTS NETO,[ASCSTR [ +]] + .NETS NETO, ; Kick it right along... + POPJ P, + +; FILERR - From ERRCOD and the FILDEV file block, composes +; a "file error" message and sends it out. Clobbers A, B! + +FILERR: PUSHJ P,FILSTR ; Compose string containing file name. + MOVE B,A + PUSHJ P,ERRSTR ; And string containing error description. + TLNE F,%LSMTP + JRST [ MAKSTR REPLY,[[452 File error for ],TS,(B),[ - ],TS,(A)] + PJRST ACKENR] + TLNN F,%LTCP + JRST [ MAKSTR REPLY,[[455 File error for ],TS,(B),[ - ],TS,(A)] + PJRST ACKENR] + MAKSTR REPLY,[[555 File error for ],TS,(B),[ - ],TS,(A)] + PJRST ACKENR + + +; PROTER - Protection error. Like FILERR but returns amusing error +; messages for files FTPS itself protects +;;; should say something like "Don't FTP to XXX; use MLDEV" +PROTER: PUSHJ P,FILSTR ; Compose string containing file name. + ;; This is the same syntax that (bletch) unix uses in its error msg! + MAKSTR REPLY,[[550 ],TS,(A),[: permission denied]] + PJRST ACKENR + +; ASSHOL - Prevent assholes +; Skips if the host in A is OK. +; Does not skip for losing hosts. +; +; Sigh, I put the following in when a random Internet host (which did not +; have any liaison or mailboxes) decided to keep connecting to us and ship +; monster-sized random unknown binary files into the .TEMP. directory. +; -- CSTACY, 2 February 1984 + +ASSHOL: PUSH P,B ; Smash only T. + MOVSI T,-LUZRL ; AOBJN for losers table. +ASSHO1: MOVE B,LUZRS(T) ; Get host address. + JUMPE B,ASSHO2 ; Ignore zero ones. + CAMN A,B ; Is this a losse? + JRST [ POP P,B ; Yeah - restore stack + POPJ P,] ; take non-skip return. +ASSHO2: AOBJN T,ASSHO1 ; Keep checking. + POP P,B ; All through - host is OK. + AOS (P) ; Winskip. + POPJ P, + + SUBTTL SMTP command routines + + +SMHELO: HRRZ B,(A) + JUMPE B,SMERR + MAKSTR FGNNAM,[TS,ARGSTR] ; Copy argument into hostname string +IFN $.ARPA, MAKSTR REPLY,[[250 ],TZ,@OWNNAM,[.ARPA]] +.ELSE, MAKSTR REPLY,[[250 ],TZ,@OWNNAM] + SKIPE NCMXCT ; Is this the first command seen? + PJRST ACKENR ; Nope, just return. + MOVEI A,REPLY + PJRST SMRST2 ; Yes, so reset things on our way back. + +SMRSET: MOVEI A,[ASCSTR [250 Reset]] +SMRST2: SETZM RCPIDX ; Simple, just clear index + SETZM FRMSTR ; and return-path string + SETZM GOTFRM' + SETOM RSCHEM ; Say hacking rcpts-first. + PJRST ACKEND + +SMNOOP: MAKSTR REPLY,[[250 JFCL]] + PJRST ACKENR + +SMERR: MAKSTR REPLY,[[500 Error in command string]] + PJRST ACKENR + +;;; SMTP send and mail commands + +SMSEND: SETOM SENDSW ;Don't mail if send fails +SMSN05: SETOM SORMSW ;Sending, not mailing + JRST SMSN10 + +SMSAML: MOVEI A,1 ;Send and mail + MOVEM A,SENDSW + JRST SMSN05 + +SMSOML: SETZM SENDSW ;Mail if send fails + JRST SMSN05 + +SMMAIL: SETZM SORMSW ;Mailing, not sending +SMSN10: SKIPE GOTFRM ; Mustn't already have anything. + JRST [ MOVEI A,[ASCSTR [503 Bad sequence, MAIL already seen?]] + PJRST ACKEND] + SKIPN NCMXCT + JRST [ MOVEI A,[ASCSTR [503 Must give HELO first]] + PJRST ACKEND] + MOVEI B,": + CALL PRSWRD ; Get initial word + EXCH A,B + CALL CVSUPR ; Make uppercase + EQUSTR A,[ASCSTR [FROM]] + JRST SMERR ; Must have "FROM:" + MOVE A,B + CALL STRIMA ; Strip off angle brackets + JRST [ MOVEI A,[ASCSTR [553 Bad syntax, no brackets]] + PJRST ACKEND] + MOVE B,A ; Save ptr to stripped string + CALL CVRCP ; Convert SMTP rcpt (hack hack!), return A + PJRST ACKEND ; Ugh! Error reply in A. + MAKSTR FRMSTR,[TS,(B)] ; Store return path, use stripped string. + SETOM GOTFRM + MOVEI A,[ASCSTR [250 OK]] + SKIPE SORMSW + PJRST ACKEND + CALL BLOATP ; Make sure it's OK to write mail file. + JRST [ MOVEI A,[ASCSTR [421 Sorry, big mail backlog! Try again later.]] + PUSHJ P,NETREP ; Send the reply, + JSR LOGOUT ] ; then punt. + PJRST ACKEND + +SMRCPT: SKIPN GOTFRM + JRST [ MOVEI A,[ASCSTR [503 Must give MAIL first]] + PJRST ACKEND] + MOVEI B,": + CALL PRSWRD ; Get initial word + EXCH A,B + CALL CVSUPR + EQUSTR A,[ASCSTR [TO]] + JRST SMERR ; Must have "TO:" + MOVE A,B + CALL CVRCPT ; Convert SMTP rcpt (hack hack!), return A + PJRST ACKEND ; Ugh! Error reply in A. + CALL RCPSTO ; Store recipient name + JRST [ MOVEI A,[ASCSTR [553 Null rcpt]] + PJRST ACKEND] + MOVEI A,[ASCSTR [250 OK]] + PJRST ACKEND + +SMDATA: SKIPN GOTFRM + JRST [ MOVEI A,[ASCSTR [503 Must give MAIL first]] + PJRST ACKEND] + JUMPLE R,[MOVEI A,[ASCSTR [503 No recipients?]] + PJRST ACKEND] + MOVEI A,[ASCSTR [354 Hello mailer!]] + TLNE F,%DMSW + MOVEI A,[ASCSTR [354 Hello sailor!]] + CALL NETREP ; Send the response + CALL GETML ; Get mail text + PJRST SMRST2 ; Shit, reset and report error in A + SKIPN SORMSW + JRST SMDAT9 ;Just mailing + SETZ R, ; Initialize for plucking rcpts +SMDAT1: PUSHJ P,RCPSEQ ; From table into RCPSTR... + JRST SMDAT8 ; Exit when no more. + MOVEI A,RCPSTR + PUSHJ P,CVSIXH ; Convert name to 6bit... + MOVE B,A + PUSHJ P,ONLINE ; See if online... + JRST [ SKIPL SENDSW + JRST SMDAT9 ;Forget sending, mail instead + MOVEI A,[ASCSTR [450 That user is not on-line now.]] + PJRST RCLACK ] + PUSHJ P,SENDIT ; Try to :SEND it... + JRST [ SKIPL SENDSW + JRST SMDAT9 ;Forget sending, mail instead + MOVEI A,[ASCSTR [450 That user is either not on-line or not accepting messages.]] + PJRST RCLACK] + JRST SMDAT1 ;Try next RCPT in case multiple + +SMDAT8: SKIPG SENDSW ;Send succeeded, mail also? + JRST SMDAT7 +SMDAT9: CALL MAILIT ; Do it! + PJRST SMRST2 ; Ugh, error here. +SMDAT7: MOVEI A,[ASCSTR [250 OK, mail sent.]] + PJRST SMRST2 + + +; Design for SMTP interactive sends. --- CSTACY 12/29/83. +; (partially implemented) +; +; The subroutine ITSRCP takes a mailbox and looks to see if it is a +; plausible ITS uname (username of any six chars and a host of MC, ML, +; DM, or AI). If it is, it returns true with the uname and device name +; in some ACs, otherwise it returns false. +; +; SMSEND, SMSAML, and SMSOML set a switch (SENDSW) to indicate which has +; been called, then jumps into common code at SMSN10, which checks for +; proper command sequences as in SMMAIL, then set a switch indicating +; that we are hacking sends (SORMSW). +; +; The RCPT handler (SMRCPT) is modified so that if SORMSW is set, we +; call ITSRCP to examine the recipient. If ITSRCP returns true, we +; probe for a HACTRN on the appropriate device. +; +; If not found, and we are SENDing, we reject the recipient with a 450 +; reply ("User not online or refusing sends now"). If not found and if +; we are SAMLing, we also reject. If found, or if we don't care because +; we are SOMLing, we accept and store the recipient as usual. +; +; The routine which is named SENDIT is renamed CLISND or something, and +; the NCP/FTP mail commands (like XMAS) which call it are modified; we +; usurp the name SENDIT for something more like MAILIT. +; +; Also, the routine in MAILIT which actually writes the request file is +; abstracted out into a subroutine. +; +; Next, the DATA handler (SMDATA) is modified so that if SORMSW if set, +; we call SENDIT instead of MAILIT. +; +; Like MAILIT, SENDIT makes sure that the message text is not too long; +; a message over 5400 characters is too long. We process each recipient +; by calling ITSRCP and if this returns true, calling CLISND. +; +; If CLISND fails and the command was SEND, we lost and for this +; recipient. It is too late to reject the recipient, but if there was +; only one recipient in the list we can reply RESET. If there was more +; than one recipient in this case, we send the message as a "Failing +; Qsend" in mail. +; +; If CLISND fails and the command was SOML, we mail and continue on happily. +; If CLISND fails and the command was SAML, we mail and continue on happily, +; since I can't think of anything better to do. +; +; When all the recipients have been mailed and/or sent to, we reply with +; a success code and return from the SMDATA command + + +; CVRCPT - Takes SMTP path in string in A, +; returns hacked COMSAT/COMSYS rcpt string in A. +; Converts "<@A,@B,@C:rcpt@D>" to "rcpt@D@C@B@A" +; Fails to skip if some problem (leaves err message in A) +CVRPSW: 0 ; Count of stuff added to output string + +CVRCPT: CALL STRIMA ; Strip off angle brackets + JRST [ MOVEI A,[ASCSTR [553 Bad path syntax]] + RET] +CVRCP: PUSHAE P,[B,C,D,E] + SETZM CVRPSW + BCONC ; Start output of a new string + HRRZ D,(A) ; Get count + MOVE E,1(A) ; Get BP + JUMPLE D,CVRP90 ; Allow null path "<>" + + ; See if first char is "@", if not, then no routing info. + MOVE B,E + ILDB B,B + CAIE B,"@ + JRST [ OUT(STRC,S(D,E)) ; No routing, copy whole string. + JRST CVRP80] + + ; Have routing info, must start hacking. + ; First scan forward for the ":". If none found, we still scan + ; for commas anyway, for benefit of old SMTPs. +CVRP10: ILDB B,E + CAIE B,": + SOJG D,CVRP10 + SOJLE D,CVRP15 ; Possible to have a null rcpt or something? + OUT(STRC,S(D,E)) ; First part is mailbox + AOS CVRPSW ; Say we got mailbox part. + ADDI D,1 ; Pretend we used up the ":" too. + + ; Okay, hack routing. If a ":" existed, it has been processed. +CVRP15: SKIPGE B,D + SETZ B, + HRRZ D,(A) ; Get back total length + MOVE E,1(A) ; and BP to start of string + SUBI D,(B) ; Find # chars of routing info. + MOVE C,E + PTSKIP D,C ; Get BP to last char + MOVE B,D ; Copy count + JRST CVRP30 + + ; Got recipient portion, copy it over +CVRP20: MOVEI A,(D) + SUBI A,(B) ; Find # chars used + CAIGE A,2 ; Route spec must have at least "@X" + JRST CVRP99 + OUT(STRC,S(A,C)) ; Copy into output string + MOVE A,C + ILDB A,A ; Check the first char + CAIE A,"@ ; Must be "@"! + JRST [ SKIPN CVRPSW ; If not, only allow if it's mailbox. + JRST .+1 + JRST CVRP99] ; Ugh, complain. + AOS CVRPSW + SOJLE B,CVRP80 + MOVEI D,(B) ; Set up new count of chars left + D7BPT C ; Move over the comma we found. +CVRP30: LDB A,C + CAIN A,", + JRST CVRP20 + D7BPT C + SOJG B,CVRP30 + JRST CVRP20 + +CVRP80: ECONC TMPSTR + MOVEI A,TMPSTR +CVRP90: AOSA -4(P) +CVRP99: MOVEI A,[ASCSTR [553 Bad path syntax]] + POPAE P,[E,D,C,B] + RET + +STRIMA: CALL STRIM ; Just in case. + PUSHAE P,[B,C,D,E] + HRRZ D,(A) + JUMPE D,STRMA9 + MOVE E,1(A) ;get cnt and bp for string. + ILDB B,E + CAIE B,"< ; > should be this. + JRST STRMA9 + SOJLE D,STRMA9 ; Decrement count + MOVEM E,1(A) ; Store trimmed start ptr + PTSKIP D,E ; Increment ptr by # chars remaining + LDB B,E ; Get last char, < + CAIE B,"> + JRST STRMA9 ; Sigh. + SOJL D,STRMA9 + HRRM D,(A) ; Store new cnt back. + AOS -4(P) +STRMA9: POPAE P,[E,D,C,B] + POPJ P, + + + SUBTTL Minor command routines + +UNIMPL: MOVEI A,[ASCSTR [502 This command is not implemented, sorry.]] + PJRST ACKEND + +XDBG: SETOM XDBGSW + MOVEI A,[ASCSTR [200 OK, debug stuff turned on]] + PJRST ACKEND + + ; NOOP - acknowlege gravely. +NOOP: MOVEI A,[ASCSTR [200 JFCL]] + PJRST ACKEND + + ; BYE - Log out and so forth. Maybe should print a BYE-pgm msg?? +BYE: MOVEI A,[ASCSTR [231 BCNU]] + TLNE F,%LTCP +SMQUIT: MOVEI A,[ASCSTR [221 BCNU]] + PUSHJ P,NETREP + TLNN F,%LCHAOS + JSR LOGOUT + ;; TCP finish reputedly hangs up if done here. + ;; No one seems to have failed to get the response either. + ;; CHAOS otherwise manages to close before data received, + ;; though, so finish it. + SYSCAL FINISH,[MOVEI NETO] + JFCL + JSR LOGOUT + + ; USER - "Login", just sets default directory name. +USER: HRRZ B,(A) ; Get count of string. + TLNN F,%LTCP + JUMPE B,[MAKSTR REPLY,[[230 Null USER was given; user name remains ],6F,USRNAM] + PJRST ACKENR] + JUMPE B,[MAKSTR REPLY,[[230 Null USER was given; user name remains ],6F,USRNAM] + PJRST ACKENR] + PUSHJ P,CVSIX ; Convert argument to SIXBIT + MOVEM A,USRNAM ; and store as specified user name. + MOVEM A,DEFDIR ; and make it the default directory to reference. + MAKSTR REPLY,[[230 OK, your user name is ],6F,USRNAM] + PJRST ACKENR + + ; XCWD - Change working directory, just sets default dir name. +XCWD: HRRZ B,(A) ; Get count of string. + JUMPE B,[MAKSTR REPLY,[[250 Null XCWD was given; dir name remains ],6F,DEFDIR] + PJRST ACKENR] + PUSHJ P,CVSIX ; Convert argument to SIXBIT + MOVEM A,DEFDIR ; and make it the default directory to reference. + MAKSTR REPLY,[[250 OK, your directory by default is ],6F,DEFDIR] + PJRST ACKENR + + ; PASS - Loser obviously on wrong machine. +PASS: MOVEI A,[ASCSTR [230 What makes you think you need a password?]] + PJRST ACKEND ; Do a little kidding. 2xx code really accepts. + + ; ACCT - Loser also obviously on wrong machine! +ACCT: MOVEI A,[ASCSTR [430 Account ID is not in hash table; add 1 and try again.]] + PJRST ACKEND ; More kidding. This time, DON'T accept! + + ; MODE - Set transfer mode. (only S=Stream accepted) +MODE: PUSHJ P,CVSUPR ; Convert arg to uppercase. + EQUSTR A,[ASCSTR [S]] + SKIPA A,[[ASCSTR [504 Only Stream I/O is implemented here.]]] + MOVEI A,[ASCSTR [200 Mode Stream]] + PJRST ACKEND + + ; STRU - Set structure type. Only F=File accepted. +STRU: PUSHJ P,CVSUPR ; Convert arg to uppercase. + EQUSTR A,[ASCSTR [F]] + SKIPA A,[[ASCSTR [504 Only FILE structure is allowed.]]] + MOVEI A,[ASCSTR [200 FILE structure]] + PJRST ACKEND + + ; TYPE - Set transfer type (A=Ascii, I=Image) +TYPE: PUSHJ P,CVSUPR ; Convert arg to uppercase. + EQUSTR A,[ASCSTR [L 36]] + CAIA + JRST [SETOM DCTYPE ; Pretend Image 36-bit. + MOVEI B,36. + MOVEM B,DCBYTE + JRST TYPE40] + EQUSTR A,[ASCSTR [L 8]] + CAIA + JRST TYPE18 + EQUSTR A,[ASCSTR [L]] ; Local? + CAIA +TYPE18: JRST [MOVEI A,1 ; Yes, set to Local. + MOVEM A,DCTYPE + TLNN F,%LTCP ; If TCP, always use bytesize 8 + JRST TYPE40 + MOVEI A,8. + MOVEM A,DCBYTE + JRST TYPE40] +TYPE30: EQUSTR A,[ASCSTR [I N]] + CAIA + JRST TYPE32 + EQUSTR A,[ASCSTR [I]] ; Image? + CAIA +TYPE32: JRST [SETOM DCTYPE ; Aha. Set to Image. + TLNN F,%LTCP + JRST TYPE40 ; For NCP, byte size is independent + MOVEI B,36. ; But for TCP, implies 36-bit words. + MOVEM B,DCBYTE + JRST TYPE40] + EQUSTR A,[ASCSTR [A N]] + CAIA + JRST TYPE34 + EQUSTR A,[ASCSTR [A]] ; Ascii? + JRST TYPE60 +TYPE34: SETZM DCTYPE ; Yep, set to that. + MOVEI A,8. ; And force byte size, ASCII must always be 8.! + MOVEM A,DCBYTE +TYPE40: MAKSTR REPLY,[[200 Type ],TS,ARGSTR] + PJRST ACKENR +TYPE60: MAKSTR REPLY,[[504 Invalid Type: ],TS,ARGSTR] + PJRST ACKENR + + ; BYTE - Set transfer byte size. +BYTE: TLNE F,%LTCP + PJRST UNIMPL ; No such command in TCP version, always 8. + PUSHJ P,CVSDEC ; Convert decimal string. + JRST [ MAKSTR REPLY,[[501 Bad numeric argument: ],TS,ARGSTR] + PJRST ACKENR] + CAIL A,1 ; Well, is the # anything we grok? + CAILE A,36. + JRST [MOVEI A,[ASCSTR [402 Byte sizes only between 1 and 36, please.]] + PJRST ACKEND] + MOVEM A,DCBYTE ; Ah, store new (?) byte size. + MAKSTR REPLY,[[200 Byte ],N9,DCBYTE] + PJRST ACKENR + + + ; DELE - do as it says. +DELE: MOVE B,[DEFDEV,,FILDEV] + PUSHJ P,FILPAR ; Parse filename, using given defaults. + HLRZ B,FILDIR + CAIN B,'.MA ; Don't allow deletion on .MAIL. directories + PJRST PROTER ; Fuck off, asshole! + SYSCAL OPEN,[CERR ERRCOD ? CIMM DC ? FILDEV ? FILFN1 ? FILFN2 ? FILDIR] + PJRST FILERR + PUSHJ P,RCHSTR ; Find true filenames and make string of it. + MOVE B,[RCHFN1,,FILFN1] + BLT B,FILFN2 ; Make sure that what gets deleted is what we say! + SYSCAL DELETE,[CERR ERRCOD ? FILDEV ? FILFN1 ? FILFN2 ? FILDIR] + PJRST FILERR ; File error of sorts, report & return. + MAKSTR REPLY,[[250 Deleted ],TS,(A)] + TLNN F,%LTCP + JRST [ MAKSTR REPLY,[[254 Deleted ],TS,(A)] + PJRST ACKENR ] + PJRST ACKENR + + ; LIST - Send listing of specified dir over data connection. +LIST: MOVE B,[DFLDEV,,FILDEV] ; Use special defaults to parse arg + PUSHJ P,FILPAR + SKIPN A,FILDIR ; Was directory specified? + JRST [ SKIPN A,FILFN1 ; If not, try "Fn1". + SKIPE A,USRNAM ; If no "Fn1", try given USER name. + JRST .+1 + MOVEI A,[ASCSTR [503 USER name was not given.]] + PJRST ACKEND] + MOVEM A,FILDIR + MOVE A,[[SIXBIT /.FILE.(DIR)/],,FILFN1] + BLT A,FILFN2 ; Set up Fn1 and FN2 for directory. + PUSHAE P,[DCBYTE,DCTYPE] + SETZM DCTYPE ; Temporarily make type ASCII, + MOVEI A,8. + MOVEM A,DCBYTE ; and set corresponding size. + PUSHJ P,RETR05 ; And send user the "file". + POPAE P,[DCTYPE,DCBYTE] + POPJ P, + +DFLDEV: SIXBIT /DSK/ ; Special "default fnm" when parsing LIST arg. + REPEAT 3, 0 + SUBTTL RNFR/RNTO - Renaming commands + + ; RNFR - Specifies file to be renamed + ; RNTO - specifies filename to rename to. + ; Ordinarily RNTO should immediately follow RNFR. + ; The RNFRCT var is meant to enforce this. + +RNFR: MOVE B,[DEFDEV,,FILDEV] ; Set up defaults + PUSHJ P,FILPAR ; And parse given filename. + HLRZ A,FILDIR + CAIN A,'.MA ; Don't allow rename on .MAIL. directories + PJRST PROTER ; Bah, error. Report that and return. + SYSCAL OPEN,[CERR ERRCOD ? [.UAI,,DC] + FILDEV ? FILFN1 ? FILFN2 ? FILDIR] ; See if exists. + PJRST FILERR ; Bombed, report. + PUSHJ P,RCHSTR ; Ah, find true FN's and compose reply. + TLNN F,%LTCP + JRST [ MAKSTR REPLY,[[200 OK, renaming ],TS,(A),[ to...]] + JRST RNFR1] + MAKSTR REPLY,[[350 OK, renaming ],TS,(A),[ to...]] +RNFR1: MOVE A,NCMXCT ; Now find # of FTP cmds so far + MOVEM A,RNFRCT ; and save it for RNTO to check. + PJRST ACKENR + +RNFRCT: 0 ; Holds NCMXCT at time of last RNFR. + +RNTO: MOVE B,NCMXCT ; Check to see if RNTO follows RNFR. + SUB B,RNFRCT ; Should differ by 1 only. + SOJN B,[MOVEI A,[ASCSTR [503 RNTO is valid only immediately after a RNFR!]] + PJRST ACKEND] + MOVE B,[FILDEV,,FILDEV] ; Use previous, RNFR values as defaults. + PUSHJ P,FILPAR ; Parse filename. + PUSHJ P,RCHSTR ; Get string for previously opened file... + MOVE B,FILDEV ; now check dev, dir for compatibility + MOVE C,FILDIR + CAMN B,RCHDEV + CAME C,RCHDIR + JRST [MOVEI A,[ASCSTR [553 Operation failed, because renaming cannot change device or directory.]] + .CLOSE DC, + PJRST ACKEND] + SYSCAL RENMWO,[CERR ERRCOD ? CIMM DC ? FILFN1 ? FILFN2] ; Try rename. + PJRST FILERR + MAKSTR REPLY,[[250 ],TS,(A),[ renamed to ]] + TLNN F,%LTCP + JRST [ MAKSTR REPLY,[[253 ],TS,(A),[ renamed to ]] + JRST .+1] + PUSHJ P,RCHSTR ; Get genuine filenames + .CLOSE DC, + CONC REPLY,[TS,(A)] ; Concatenate new filename onto reply. + PJRST ACKENR ; Return successfully + SUBTTL SOCK - Socket to use for data connection + + ; SOCK [,] - Use given # for data connection, + ; perhaps with optional (decimal) host # to use as well. + +SOCK: TLNE F,%LTCP + PJRST UNIMPL ; Not in TCP version, use PORT. + SETZM FSDHST ; Clear so non-write is obvious. + MOVEI B,", ; Parse argument up to comma, if any. + PUSHJ P,PRSWRD + HRRZ C,(A) ; See what count is for remainder... + JUMPE C,SOCK50 ; 0 => No remainder, hence no host spec. + EXCH A,B ; Aha, word with remainder! Word is host spec... + PUSHJ P,CVSDEC ; Convert from decimal... + JRST SOCK70 ; org? + MOVEM A,FSDHST ; Store as host # to use. +SOCK50: MOVE A,B ; Now get remainder into A - it's the socket #. + PUSHJ P,CVSDEC ; Convert that + JRST SOCK70 + MOVEM A,FSDSKT ; and store it for later. + SKIPN A,FSDHST ; Now get specified host # for acknowledgement + MOVE A,FRNHST ; (use # of connected host if none specified). + TLZ A,777000 ;Clear network number + MAKSTR REPLY,[[200 Host ],N9,A,[, socket ],N9,FSDSKT] + PJRST ACKENR + +SOCK70: MAKSTR REPLY,[[501 Bad argument for SOCK: ],TS,ARGSTR] + SETZM FSDHST + SETZM FSDSKT + PJRST ACKENR + +; PORT - Use given host/port for data connection. + +PORT: TLNN F,%LTCP ; TCP version only! + PJRST UNIMPL + SETZB D,FSDHST ; Clear so non-write is obvious. + SETZM FSDSKT + + MOVSI C,-6 ; Hack 6 octets + PUSH P,[401000,,D] ; Set up BP into D and E +PORT2: MOVEI B,", + CALL PRSWRD ; Get the ascii octet + HRRZ T,(A) ; See if this is last thing + JUMPE T,[AOBJP C,.+1 ; Keep going if OK to be last thing. + JRST PORT70] ; Else ended too soon! + EXCH A,B + CALL CVSDEC ; Convert ascii to number (decimal) + JRST PORT70 ; Barf? + IDPB A,(P) ; Store it away + MOVE A,B ; Put back ptr to arg string + AOBJN C,PORT2 ; Keep going + + ; We could check here for junk after arg, but don't bother. + ; Go put away the stuff we parsed. + MOVEM D,FSDHST ; Store host (Internet = HOSTS3 fmt) + LSH E,-<36.-16.> ; Right justify the 16-bit port number + MOVEM E,FSDSKT ; and store that. + POP P,JUNK + CAMN D,FRNHST ; See if host is same as one connected to. + JRST [ MAKSTR REPLY,[[200 OK, port ],N9,E] + PJRST ACKENR] ; Win! + MAKSTR REPLY,[[200 OK, port ],N9,E,[ (WARNING: host ],OCT,D,[, not ],OCT,FRNHST,[!)]] + PJRST ACKENR + +PORT70: POP P,JUNK + MAKSTR REPLY,[[501 Bad argument for PORT: ],TS,ARGSTR] + PJRST ACKENR + SUBTTL STOR - Write file received from net. + + ; STOR - User wants to store data in that filename. + +STOR: MOVE B,[DEFDEV,,FILDEV] + PUSHJ P,FILPAR ; Parse filename with given default/dest + HLRZ A,FILDIR + CAIN A,'.MA ; Don't allow rename on .MAIL. directories + PJRST PROTER ; Bah, error. Report that and return. + SKIPN USRNAM ; If no USER name specified, + JRST [ MOVE B,FILDIR ; then resulting directory becomes default. + MOVEM B,DEFDIR + JRST .+1] + MOVEI C,.BIO + SKIPN DCTYPE ; Open dsk output in correct mode for type. + MOVEI C,.UAO ; ASCII needs Unit Ascii Out. + SKIPLE DCTYPE ; Local needs + MOVEI C,.UIO ; Unit Image Out. + SYSCAL OPEN,[CERR ERRCOD ? CTL C + CIMM DC ? FILDEV ? FTPOF1 ? FTPOF2 ? FILDIR] + JRST [ MOVE A,FTPOF1 ; Failed??? Indicate filename actually tried. + MOVEM A,FILFN1 + MOVE A,FTPOF2 + MOVEM A,FILFN2 + PJRST FILERR] ; and go report. + + ; File opened for writing, now attempt to open data connection... + MOVEI A,[ASCSTR [150 Socket to me!]] + TLNE F,%LTCP + CALL NETREP + PUSHJ P,DATCNI ; Like so. + POPJ P, ; Failed?? oh well. (DATCNI reports lossage itself) + TLNN F,%LTCP + JRST [ MOVEI A,[ASCSTR [250 Socket to me!]] + PUSHJ P,NETREP + JRST .+1] + ; Data connection open! Now begin data transfer... + MOVEI T,STOBIG + MOVEM T,STOIOC ;If any IOC lossage, give user error response. + MOVEI A,NETD + MOVEI B,DC ; Set up input and output channel #'s + PUSHJ P,XFR ; Xfer from NETD to DC in appropriate mode. + SETZM STOIOC +STOR40: SYSCAL RENMWO,[CERR ERRCOD ; When done, rename to right thing! + CIMM DC ? FILFN1 ? FILFN2] ; (i.e. originally specified names) + PJRST FILERR + PUSHJ P,RCHSTR ; Find true filenames before closing. + .CLOSE DC, + MAKSTR REPLY,[[226 FINIS - ],TS,(A)] ; And report what it was. + TLNN F,%LTCP + JRST [ MAKSTR REPLY,[[252 FINIS - ],TS,(A)] ; And report what it was. + JRST .+1] + TLNN F,%DMSW + PJRST ACKENR ; and return forthwith if not on DM. + MOVE A,FILDIR + CAME A,['NETWRK] ; If on DM, see if we just wrote to NETWRK; dir + PJRST ACKENR + SYSCAL DEMSIG,[['NETRJS]] ; and wake up RJE demon to gobble if so. + JFCL + PJRST ACKENR + +;;; Note - disk IOC's while writing: err, drop the connection, and don't return. + +STOBIG: SETZM STOIOC ;Unset IOC handler. + OUTS NETO,[ASCSTR [452 File System failure - maybe disk full + +]] + .NETS NETO, ; Kick it right along... + TLNN F,%LCHAOS + JSR LOGOUT + SYSCAL FINISH,[MOVEI NETO] + JFCL + JSR LOGOUT + + SUBTTL STAT - Status report + +STAT: PUSH P,A ;Save pointer to argument string. + PUSHJ P,FNPARD ;Parse as filename, DDT style. + JUMPN A,STAT1 ;Was anything parsed out of there? + JUMPN B,STAT1 + JUMPN C,STAT1 + JUMPE D,STAT2 +STAT1: POP P,A ;Yes - Recover string for reparsing, + PJRST NLST ; and proceed like NLST command. + +STAT2: POP P,JUNK ;No filename - just give general information. + MAKSTR REPLY,[[211-],TZ,@OWNNAM,[ ITS ],6F,ITSVER,[, FTP server ],6F,VERSHN,[ on ],WBI,,EOL, ] + SKIPE SYSDBG + CCONC REPLY,[[211-Caution: System is being debugged.],EOL, ] + SKIPE DEBUG + CCONC REPLY,[[211-Caution: FTP server is being debugged.],EOL, ] + CCONC REPLY,[[211-Hacking FILE structure STREAM mode transfers in ],N9,DCBYTE,[ bit ]] + MOVEI A,[ASCIZ "ASCII"] ;0 means ascii + SKIPLE DCTYPE + MOVEI A,[ASCIZ "image"] + SKIPGE DCTYPE + MOVEI A,[ASCIZ "local"] + CONC REPLY,[TZ,(A),[ bytes.],EOL, ] + CONC REPLY,[[211-Working directory is: ],6F,DEFDIR] + SKIPN USRNAM + JRST [ CONC REPLY,[[ (You are not logged in.)],EOL, ] + JRST STAT3 ] + CONC REPLY,[[ (Logged in as ],6F,USRNAM,[)],EOL, ] +STAT3: SKIPN ERRCOD + JRST STAT9 + PUSHJ P,FILSTR ;Let's report most recent error. + MOVE B,A ;Compose string containing file name. + PUSHJ P,ERRSTR ;And string containing error description. + CONC REPLY,[[211-Most recent file error was: ],TS,(B),[ - ],TS,(A)] +STAT9: MOVEI A,[ASCIZ "closed"] + .STATUS NETD,B + SKIPE B + MOVEI A,[ASCIZ "open"] + CONC REPLY,[[211 Data connection is ],TZ,(A),[. My socket: ],N9,LDSOC,[, your socket: ],N9,FDSOC] + PJRST ACKENR + + SUBTTL NLST - wildcard-type directory listing + +NLST: MOVE B,DEFDEV ;Set defaults to DEV:DIR;* * + MOVEM B,DEFSTR + MOVE B,DEFDIR + MOVEM B,DEFSTR+1 + MOVSI B,(SIXBIT/*/) + MOVEM B,DEFSTR+2 + MOVEM B,DEFSTR+3 + MOVE B,[DEFSTR,,FILDEV] + PUSHJ P,FILPAR ;Get wild file name argument command. + SYSCAL OPEN,[CERR ERRCOD ? CTLI .BII ;Read the directory + CIMM DC ? FILDEV ? [SIXBIT/.FILE./] ? [SIXBIT/(DIR)/] ? FILDIR] + PJRST FILERR ; Bombed, report file error & return. + UAROPN [%ARTCH+%ARTZM,,DIRAR ? [2000]] ; Get buffer + MOVE C,DIRAR+$ARRPT ; Get BP to beg of buffer + HRLI C,-2000 + .IOT DC,C ;Read in the dir + .CLOSE DC, + PUSHAE P,[DCBYTE,DCTYPE] + SETZM DCTYPE ; Temporarily make type ASCII, + MOVEI A,8. + MOVEM A,DCBYTE ; and set corresponding size. + MAKSTR REPLY,[[150 Begin dir listing for ],6Q,FILDEV,[: ],6Q,FILDIR,[; ],6Q,FILFN1,[ ],6Q,FILFN2] + MOVEI A,REPLY + TLNE F,%LTCP + CALL NETREP + PUSHJ P,DATCNO ;Now open data connection + JRST NLSTX ;Foo. + TLNN F,%LTCP + JRST [ MAKSTR REPLY,[[250 Begin directory listing for ],6Q,FILDEV,[: ],6Q,FILDIR,[; ],6Q,FILFN1,[ ],6Q,FILFN2] + MOVEI A,REPLY + PUSHJ P,NETREP + JRST .+1] +REPEAT 2,[ ;Convert stars to zeros + SETO C, + MOVE B,FILFN1+.RPCNT + CAMN B,[SIXBIT/*/] + SETZ C, +REPEAT 6,[ ;Generate mask + MOVEI A,0 + LSHC A,6 + CAIN A,'* + TLZ C,770000 + ROT C,6 +];INNER REPEAT + MOVEM C,MASK1+.RPCNT + ANDM C,FILFN1+.RPCNT +];REPEAT + OUTOPN NETD, ;Will send directory listing to NETD + HRRZ C,DIRAR+$ARRPT ;Pointer to binary directory + MOVEI D,2000(C) ;End + ADD C,UDNAMP(C) +NLST1: CAML C,D + JRST NLST3 ;Done + MOVE A,UNFN1(C) ;Test file name against pattern + MOVE B,UNFN2(C) + AND A,MASK1 + AND B,MASK2 + CAMN A,FILFN1 + CAME B,FILFN2 + JRST NLST2 + FWRITE NETD,[6Q,FILDEV,[: ],6Q,FILDIR,[; ],6Q,UNFN1(C),[ ],6Q,UNFN2(C)] + CRLF NETD, +NLST2: ADDI C,LUNBLK + JRST NLST1 + +NLST3: SYSCAL FINISH,[MOVEI NETD] ; Force output NOW. + JSR IOCERR + .CLOSE NETD, + TLNE F,%LTCP ; If using TCP, + .CLOSE NETICP, ; must also flush other direction. + MOVEI A,[ASCSTR [226 That's all, folks!]] + TLNN F,%LTCP + MOVEI A,[ASCSTR [252 That's all, folks!]] + PUSHJ P,ACKEND +NLSTX: POPAE P,[DCTYPE,DCBYTE] + UARCLS DIRAR + POPJ P, + SUBTTL RETR - Send file over net. + + ; RETR - User wants to retrieve specified file + +RETR: MOVE B,[DEFDEV,,FILDEV] + PUSHJ P,FILPAR ; Parse filename as usual... + SKIPN USRNAM ; If no USER name given, + JRST [ MOVE B,FILDIR ; use resulting dir as default in future. + MOVEM B,DEFDIR + JRST .+1] + ; Entry pt when FILDEV set up. +RETR05: MOVEI C,.UAI ; Use Unit Ascii In, unless + SKIPE DCTYPE ; 36-bit Image requested. + MOVEI C,.BII + SKIPLE DCTYPE ; For Local type, + MOVEI C,.UII ; use Unit Image In. + SYSCAL OPEN,[CERR ERRCOD ? CTL C ; Open, using mode in C + CIMM DC ? FILDEV ? FILFN1 ? FILFN2 ? FILDIR] + PJRST FILERR ; Bombed, report file error & return. + + ; Desired file opened, now open data connection to xfer it! + PUSHJ P,RCHSTR ; Get true filename of what we're reading. + MAKSTR REPLY,[[150 Look out! Here comes ],TS,(A)] + MOVEI A,REPLY + TLNE F,%LTCP + CALL NETREP + PUSHJ P,DATCNO ; Attempt open for output... + POPJ P, ;Foo? + + ; File and Data conn both open, now xfer... + TLNN F,%LTCP + JRST [ PUSHJ P,RCHSTR ; Get true filename of what we're reading. + MAKSTR REPLY,[[250 Look out! Here comes ],TS,(A)] + MOVEI A,REPLY + PUSHJ P,NETREP + JRST .+1] + MOVEI A,DC + MOVEI B,NETD ; Set up input and output chans + PUSHJ P,XFR ; Now xfer from DC to NETD. + SYSCAL FINISH,[MOVEI NETD] ; Ensure all pushed out. + JSR IOCERR +RETR40: .CLOSE NETD, + TLNE F,%LTCP ; If using TCP, + .CLOSE NETICP, ; also close other direction. + MOVEI A,[ASCSTR [226 That's all, folks!]] + TLNN F,%LTCP + MOVEI A,[ASCSTR [252 That's all, folks!]] + PJRST ACKEND + SUBTTL Data Transfer Routines + +XFRBFL==4000 ; ASCII buffer area length to use, in words. + +; Transfer data from channel in A to channel in B, using appropriate +; mode - Image, Local or ASCII. Closes input channel and clobbers A. + +XFR: SKIPGE DCTYPE ; Use appropriate mode - Image or ASCII. + JRST [ CALL XFRIMG ; Use image. + JRST XFR9] + SKIPLE DCTYPE + JRST [ CALL XFRLCL ; Use Local byte + JRST XFR9] ; Drop thru for ASCII. + CALL XFRASC +XFR9: TRNE F,%NTDIR ; Skip if we were hacking input + RET ; Nope, net chans left open. + TLNE F,%LTCP ; If using TCP, must ensure that the + .CLOSE NETICP, ; output channel gets closed too! + RET + + ; ASCII transfer +XFRASC: PUSHAE P,[C,D] + UAROPN [%ARTCH+%ARTZM,,BUFFAR ? [XFRBFL]] ; Get buffer + MOVE C,BUFFAR+$ARRPT ; Get BP to beg of buffer + MOVEI D,5 ;First read ahead one word. + SYSCAL SIOT,[A ? C ? D] ;When we output the buffer we always save 1 word, so that + JSR AUTPSY ;We can always flush up to 5 chars of padding (^C's or ^@'s). + AOS ALIVEC + JUMPG D,XFRAS2 ;Didn't get even 1 word => at EOF. +XFRASL: MOVE C,BUFFAR+$ARRPT ;Try to fill up buffer, assuming already have 1 word. + ADDI C,1 + MOVEI D,XFRBFL*5-5 + SYSCAL SIOT,[A ? C ? D] + JSR AUTPSY + JUMPG D,XFRAS1 ;Didn't fill it all up => at EOF, flush some padding. + MOVE C,BUFFAR+$ARRPT + MOVEI D,XFRBFL*5-5 ;Did fill it => output it, but save the last word, + SYSCAL SIOT,[B ? C ? D] + JSR AUTPSY + MOVE C,BUFFAR+$ARLOC + MOVE C,(C)XFRBFL-1 ;which we move into the first word. + MOVEM C,@BUFFAR+$ARLOC + JRST XFRASL + +XFRAS2: ADDI D,XFRBFL*5-5 +XFRAS1: MOVNS D + ADDI D,XFRBFL*5 ;# chars we have in buffer now. + SYSCAL CLOSE,[A] + JSR AUTPSY + SETZ A, + PTSKIP A,C ; get canonical BP (SIOT may return 440700,,) + +XFRAS4: JUMPE D,XFRAS9 ;Discard any number of ^@'s or ^C's, then one ^L. + LDB A,C + CAIE A,^C + JUMPN A,XFRAS3 + D7BPT C + SOJA D,XFRAS4 + +XFRAS3: CAIE A,^L + JRST XFRAS5 + D7BPT C + SOJE D,XFRAS9 +XFRAS5: MOVE C,BUFFAR+$ARRPT ;Output what's left after flushing padding. + SYSCAL SIOT,[B ? C ? D] + JSR AUTPSY +XFRAS9: UARCLS BUFFAR + POPAE P,[D,C] + POPJ P, + + ; Local-byte Transfer. + ; Unfortunately %NTDIR (0=netin, 1=netout) must be used to + ; select two different algorithms, because ITS is still + ; too stupid to know about byte sizes other than 7 or 36 + ; when talking to the disk. +XFRLCL: PUSHAE P,[C,D,E] + UAROPN [%ARTZM,,BUFFAR ? [XFRBFL]] ; Set up buffer area + MOVE C,$ARLOC+BUFFAR ; and a BP to it + MOVE D,DCBYTE ; Get byte-size + DPB D,[$SFLD,,C] ; Stick into size field of BP + TLO C,440000 ; Start at beg of word + MOVEI D,36. + IDIV D,DCBYTE ; Find # bytes in a word + MOVEM D,XFRBPW ; Save + IMULI D,XFRBFL ; Find # bytes in buffer + MOVE E,D ; Save cnt + PUSHAE P,[C] ; Save BP + +XFRLC2: MOVE D,E ; Get # bytes max to read + MOVE C,(P) ; Restore BP + TRNE F,%NTDIR ; All's well if input is from NET + JRST [ MOVEI D,XFRBFL ; Nope, DSK... set # wds + HRLI C,444400 ; and use word-size bytes. + JRST .+1] ; + SYSCAL SIOT,[A ? C ? D] ; Slurp up + JSR AUTPSY + AOS ALIVEC + TRNE F,%NTDIR ; If input was from DSK, + IMUL D,XFRBPW ; convert count to # bytes. + SUBM E,D ; Get # bytes read in D + JUMPLE D,XFRLC9 + TRNN F,%NTDIR ; If output is to DSK, + JRST [ PUSH P,E ; Pad out. + IDIV D,XFRBPW ; Find # words + CAILE E, ; Round up + AOS D + CAILE E, ; Pad out with zeros + PUSHJ P,[PUSH P,D ? SETZ D, ? IDPB D,C ? POP P,D + SOS (P) ? SOS (P) ; Call again til done. + SOJA E,APOPJ] + POP P,E + JRST .+1] + MOVE C,(P) ; Restore BP + TRNN F,%NTDIR ; Again, if output is to DSK, + HRLI C,444400 ; use word-size bytes. + SYSCAL SIOT,[B ? C ? D] ; Output them + JSR AUTPSY + JRST XFRLC2 + +XFRLC9: POP P,C + UARCLS BUFFAR + POPAE P,[E,D,C] + POPJ P, +.SCALAR XFRBPW ; # bytes per word + + ; Image Transfer. +XFRIMG: TLNE F,%LTCP + JRST XFRIT ; Go hack TCP image transfer + PUSH P,C + UAROPN [%ARTZM,,BUFFAR ? [XFRBFL]] ; Set up buffer area + MOVE C,$ARLOC+BUFFAR ; and an AOBJN ptr + HRLI C,-XFRBFL + PUSH P,C ; Save it. +XFRIM4: SYSCAL IOT,[A ? C] + JSR AUTPSY + AOS ALIVEC + JUMPGE C,[MOVE C,(P) ; Restore AOBJN ptr + SYSCAL IOT,[B ? C] ; And use to output buffer. + JSR AUTPSY + MOVE C,(P) ; Restore again for more input. + JRST XFRIM4] + SYSCAL CLOSE,[A] ; Aha, got it all. Close empty input chan. + JSR AUTPSY + POP P,A ; Partially counted out, recover original ptr. + HLRES C ; Put partial neg cnt in RH + HRLOI C,XFRBFL-1(C) ; Put <#wds-1> in LH, -1 in RH + EQVI C,(A) ; And convert to AOBJN pointing to buffer. + SYSCAL IOT,[B ? C] ; And output rest of stuff. + JSR AUTPSY + UARCLS BUFFAR ; Done! + POP P,C + POPJ P, + + ; Net into area, ASCII. Gobbles stuff from data connection into + ; BUFFAR. +GETNAR: PUSH P,A + UAROPN [%ARTCH+%ARTZM,,BUFFAR ? [2000]] ; Open text area with 1K increment. +GETNA2: MOVM A,BUFFAR+$ARCHL ; Get # chars available + SYSCAL SIOT,[CIMM NETD ? BUFFAR+$ARWPT ? A] ; Slurp. + JSR AUTPSY + MOVNM A,BUFFAR+$ARCHL ; Restore proper $ARCHL. + JUMPG A,POPAJ1 ; Jump out if reached EOF. (Skip return) + MOVEI A,2000 ; Not yet, expand by this much + UAREXP A,BUFFAR + JRST GETNA2 ; Read in more. + +; XFRIT - TCP Image transfer. Network 8-bit bytes are packed into +; disk 36-bit words, and vice versa. +; A/ input channel +; B/ output channel + +XFRIT: PUSHAE P,[C,D,E,R] + TRNE F,%NTDIR + JRST XFRITO ; Output, from disk to net. + + ; TCP Image Input, network 8-bit bytes must be packed into + ; 36-bit words. +XFR8BL==<<+7>/8.> ; # words in 8-bit byte buffer + UAROPN [%ARTZM,,BUFFAR ? [XFRBFL]] + UAROPN [%ARTZM,,TMPAR ? [XFR8BL]] + MOVE E,$ARLOC+BUFFAR + HRLI E,-XFRBFL ; Set up initial AOBJN to word buffer + MOVEI R,0 ; Point to beginning of cycle + +XFRIT2: MOVEI D,4*XFR8BL ; # bytes to slurp from net + PUSH P,D + MOVE C,$ARLOC+TMPAR + HRLI C,441000 + SYSCAL SIOT,[A ? C ? D] ; Get input + JSR AUTPSY + AOS ALIVEC ; Say we're still active + TRZ F,%TMP + CAILE D, + TRO F,%TMP ; Set flag if last slurp. + POP P,C ; Restore # bytes we asked for + SUBI C,(D) ; Find # bytes we got + IDIVI C,4 ; Get # words (rem in D) + JUMPE C,[HRR C,$ARLOC+TMPAR ; If no full words, skip stuff. + JRST XFRIT4] + MOVN C,C + HRLZS C + HRR C,$ARLOC+TMPAR ; Now have AOBJN to the fullwords we got + JRST @XFITCT(R) ; Re-enter cycle at right place + + ; C has AOBJN to full words we received (4 8-bit bytes) + ; D has # remaining bytes in last word + ; E has AOBJN to disk output buffer + ; R has # nibbles needed to fill out word in T. If 0, nothing in T. +XFITC0: + MOVE T,(C) ; Get word with 4 bytes left justified + LSH T,-4 ; Right-justify it. + AOBJP C,[MOVEI R,1 ; Jump if no more words + JRST XFRIT4] ; Handle wrapup stuff +IRP CNT,,[1,2,3,4,5,6,7,8] +XFITC!CNT: MOVE TT,(C) ; Get next one + LSHC T,CNT*4 ; Shift in to fill up word in T + MOVEM T,(E) ; Deposit word in buff + AOBJN E,.+2 ; Increment ptr, skip unless full + CALL XFITCB ; Force out word buff, reset E +IFN CNT-8,[ LSHC T,<32.-> ; Shift in unused portion + AOBJP C,[MOVEI R,CNT+1 ; Jump if no more input + JRST XFRIT4] ; Go handle wrapup stuff +] ; all but last subcycle +TERMIN + AOBJN C,XFITC0 ; Back to start of cycle + MOVEI R,0 ; No more data. Say no nibbles needed + ; Drop through + + ; No more 32-bit full words from input buffer. + ; T contains partial data, right-justified. + ; TT is empty, awaiting the next input word. + ; D contains the # of bytes in the next input word. + ; R has the # of nibbles left to fill out word in T (0-8) + +XFRIT4: JUMPE D,XFRIT5 ; If no remaining data, just get new entry point! + MOVE TT,(C) ; Get last data word + LSH D,1 ; Turn # bytes into # nibbles + JUMPE R,XFRIT3 ; If nothing currently in T, must skip some stuff. + MOVEI C,(R) ; Assume enough data to fill last word + CAIG D,(R) + MOVEI C,(D) ; Not enough data nibbles, just shift in all + LSH C,2 ; 4 bits per nibble + LSHC T,(C) ; Shift in desired amount + CAIGE D,(R) ; Did we have enough to fill out the word? + JRST XFRIT3 ; Nope, don't deposit anything. + MOVEM T,(E) ; Have full word for deposit + AOBJN E,.+2 + CALL XFITCB ; Output buff full, force out. + + ; Now shift in unused portion of data +XFRIT3: SUBI R,(D) ; Get new # nibbles needed + JUMPGE R,XFRIT5 ; If zero or positive, easy to set up. + MOVE C,R ; Negative, has # of data nibbles left in TT + IMUL C,[-4] ; 4 bits per nibble (make positive) + LSHC T,(C) ; Right-justify remaining data in T + ADDI R,9. ; Find # nibbles needed to fill out word + +XFRIT5: TRNN F,%TMP ; Last slurp? + JRST XFRIT2 ; Nope, go get another slurp. + + ; Last slurp, so must left-justify any remaining data and deposit it. + ; This code applies a heuristic to determine whether the remaining + ; data should actually be written or not. Normally if the user + ; FTP isn't buggy, R will either be 0 (no nibbles left) or + ; 8 (1 nibble left over, since end fell in middle of an octet). + ; If R isn't one of these, there was at least one full data byte + ; that shouldn't have been sent. In that case we pad out the word + ; and write it anyway. + JUMPN R,[ + CAIN R,8. ; If only 1 nibble left (partial byte) + JRST .+1 ; then ignore and assume all's well. + LSH R,2 ; 4 bits per nibble + LSH T,(R) ; Note pad with zeros! + MOVEM T,(E) ; Store last (partial) word. + AOBJN E,.+1 + JRST .+1] + CALL XFITCB ; Always force out. + JRST XFRIT9 + +XFITCT: XFITC0 ? XFITC1 ? XFITC2 ? XFITC3 + XFITC4 ? XFITC5 ? XFITC6 ? XFITC7 ? XFITC8 + + + ; Force out word buffer, and reset write pointer in E +XFITCB: HRRZS E + SUB E,$ARLOC+BUFFAR ; Find # words deposited + MOVNS E + HRLZS E + HRR E,$ARLOC+BUFFAR ; Make it an AOBJN pointer + SYSCAL IOT,[B ? E] ; Image output (E has AOBJN) + JSR AUTPSY + MOVE E,$ARLOC+BUFFAR ; Now initialize write ptr again + HRLI E,-XFRBFL + RET + + + ; XFR TCP Image Output, Disk to Net +XFRITO: UAROPN [%ARTZM,,BUFFAR ? [XFRBFL]] + UAROPN [%ARTZM,,TMPAR ? [XFR8BL]] + +XFRIT6: MOVSI C,-XFRBFL + HRR C,$ARLOC+BUFFAR + MOVE D,C + SYSCAL IOT,[A ? C] ; Slurp stuff up + JSR AUTPSY + AOS ALIVEC + TRZ F,%TMP + CAIGE C, + TRO F,%TMP ; Not counted out, this is last slurp. + HLRES C + HRLOI C,XFRBFL-1(C) + EQVI C,(D) ; Now have AOBJN to words we read in. + JUMPGE C,XFRIT9 + + HLRE D,C + IMUL D,[-9.] ; Find # of 4-bit nibbles + ADDI D,1 + IDIVI D,2. ; Find # of 8-bit bytes. + PUSH P,D + HRRZ E,$ARLOC+TMPAR + SUBI E,1 ; Allow for increment of first PUSH + TLO E,(SETZ) ; Make PDL ptr + +XFRIT7: MOVE TT,(C) ; Get word 0 + LSHC T,32. ; Get 1st 32 bits right justified + LSH T,4. ; Left justify it + PUSH E,T ; Store bytes 0-3 + AOBJP C,XFRIT8 ; If counted out, must store last 4 bits. + +REPEAT 7,[ + LSHC T,4*<.RPCNT+1> ; Get low 4 bits of wd 0 + MOVE TT,(C) ; Glom onto wd 1 + LSHC T,<32.-<4*<.RPCNT+1>>> ; Fill out to 32 bits from wd 1 + LSH T,4 ; Make left justified + PUSH E,T ; Store bytes 4-7 + AOBJP C,XFRIT8 ; If counted out, store last 8 bits. +] + PUSH E,TT ; Reached alignment, store last wd directly + JRST XFRIT7 ; then repeat the cycle + +XFRIT8: PUSH E,TT + POP P,D + MOVE C,$ARLOC+TMPAR + HRLI C,441000 + SYSCAL SIOT,[B ? C ? D] + JSR AUTPSY + + TRNN F,%TMP + JRST XFRIT6 + +XFRIT9: UARCLS TMPAR + SYSCAL CLOSE,[A] + JSR AUTPSY + UARCLS BUFFAR + POPAE P,[R,E,D,C] + RET + + SUBTTL Opening Data Connection + +; DATCNI - Opens Data connection for Input +; DATCNO - Ditto for Output. Both use appropriate byte/size. +; Skips when connection successfully opened. Else reports an +; error and doesn't skip on return. + +DATCNI: TRZA F,%NTDIR ; Clear flag to indicate Input direction. +DATCNO: TRO F,%NTDIR ; Set to indicate Output. + PUSHJ P,CNNCHK ; Check data type and byte size, and set up OPEN bits + POPJ P, ; Bleah? Oh well, return. + TLNE F,%LTCP ; If hacking TCP conns, + JRST DATTCP ; must use special routine. + PUSH P,A + MOVE A,LOCSOC ; Get local socket # (S) that was sent to User. + ADDI A,2 ; Use S+2 as local socket for receiving input, unless + TRNE F,%NTDIR ; outputting onto net, in which case + ADDI A,1 ; use S+3. + MOVEM A,LDSOC ; Store as default Local Data socket # + MOVE A,FRNSOC ; Similarly, get foreign socket # (U) + ADDI A,5 ; And use U+5 for foreign send + TRNE F,%NTDIR ; Unless outputting, in which case + SUBI A,1 ; U+4 is the right default Foreign Data skt #. + SKIPE FSDSKT + MOVE A,FSDSKT ; But if socket explicitly specified, use that. + MOVEM A,FDSOC ; and store whatever it was. + MOVE A,FRNHST + SKIPE FSDHST ; Ditto for foreign host. + MOVE A,FSDHST + TLZ A,777000 ;Clear network number (cretinous bug in old ITS) + MOVEM A,FDHST + + MOVEI A,40+.UAI ; Use either unit ascii + SKIPE DCTYPE + MOVEI A,44040+.BII ;or 36-bit block image + SKIPLE DCTYPE + JRST [ MOVE A,DCBYTE ; Local byte. Get bytesize to use + LSH A,9. ; put into right place + IORI A,40+.UII ; and set for Unit-Image. + JRST .+1] + TRNE F,%NTDIR + TRO A,1 ;set output bit if necessary + TRO A,100 ;and always use 3.7 to get 8x ITS buffer size. + SYSCAL OPEN,[CTL A ? CIMM NETD ? NETDEV ? LDSOC ? FDSOC ? FDHST] + JRST DATCN9 + + MAKSTR REPLY,[[255 SOCK ],N9,LDSOC] + MOVEI A,REPLY + PUSHJ P,NETREP ; Send SOCK reply informing user which skt to use. + MOVEI A,NETD + TRNE F,%NTDIR ; Skip for input + JRST DATCN5 ;go wait for net output conn + NETHANG 900.,A,%NSRFS,[%NSOPN,%NSCLI,%NSINP] + JRST DATCN9 ; Connection failed. + JRST POPAJ1 + +DATCN5: NETHANG 900.,A,%NSRFS,%NSOPN + JRST DATCN9 ; Connection attempt failed? + JRST POPAJ1 ; Won! + +DATCN9: .CLOSE NETD, + POP P,A + MAKSTR REPLY,[[454 Can't connect to your socket ],N9,FDSOC] + PJRST ACKENR + + + +; CNNCHK - Simple thingy to make sure byte size & type are consistent. +CNNCHK: SKIPLE DCTYPE ; For Type L, any size 1-36 is ok. + JRST POPJ1 + PUSH P,A + MOVE A,DCBYTE + SKIPN DCTYPE + JRST [ CAIN A,8. ;type ascii. size should be 8 + JRST POPAJ1 ; Win... + MOVEI A,[ASCSTR [Only size 8 is allowed with Type A.]] + JRST CNNCH5] ; Ugh. + CAIN A,36. ;type image, size should be 36 + JRST POPAJ1 ; Win... + MOVEI A,[ASCSTR [Only size 36 is allowed with type I; maybe you want type L?]] +CNNCH5: PUSH P,B + MOVE B,[SIXBIT /ASCII/] + SKIPE DCTYPE ; Set up proper type description... + MOVE B,[SIXBIT /IMAGE/] + MAKSTR REPLY,[[505- Type/Byte-size conflict! Type ],6F,B,[, Byte ],N9,DCBYTE,[??]] + CONC REPLY,[[ +505 ],TS,(A)] + POP P,B + POP P,A ; Flush saved A, doesn't matter now. + PJRST ACKENR + + ; Open TCP data connection +DATTCP: PUSH P,A ; Save ACs + PUSH P,B + MOVE A,LOCSOC + SUBI A,1 ; Use server port # - 1 for local port + CAIG A, + JSR AUTPSY ; Just in case clobbered. + MOVEM A,LDSOC ; Store as Local Data port # + SKIPN A,FSDSKT ; If user's data port explicitly given, use it + MOVE A,FRNSOC ; else use control connection port. + MOVEM A,FDSOC ; Store as Foreign Data port # + SKIPN A,FSDHST ; Same procedure for foreign host. + MOVE A,FRNHST + MOVEM A,FDHST + +; Assume bytesize is correct. +; MOVE A,DCBYTE ; Make absolutely sure that bytesize right +; CAIE A,8. +; JRST [ MAKSTR REPLY,[[560 Byte size must be 8, is ],N9,A,[???]] +; JRST DATTC9] + MOVEI A,NETD ; I/O chan to use (default input) + MOVEI B,NETICP ; Scratch channel # + TRNE F,%NTDIR ; Default wins if want input data chan + EXCH A,B ; Oops, want output, swap chans. + SYSCAL TCPOPN,[ A ? B ? LDSOC ? FDSOC ? FDHST ? CERR A] + JRST [ MAKSTR REPLY,[[425 Can't connect to your port ],N9,FDSOC,[ - ],ERR,A] + JRST DATTC8] + + ; Wait for connection (output chan) to become open + MOVEI A,900. ; Time to wait + SYSCAL NETBLK,[B ? MOVEI %NSRFS ? A ? CRET A] + JRST [ MAKSTR REPLY,[[425 Can't connect to your port ],N9,FDSOC,[ - timed out.]] + JRST DATTC8] + CAIE A,%NSOPN + CAIN A,%NSRFN + CAIA + JRST [ MAKSTR REPLY,[[425 Can't connect to your port ],N9,FDSOC,[ - state ],OCT,A] + JRST DATTC8] + POP P,B ; Open! Take win return. + PJRST POPAJ1 + +DATTC8: .CLOSE NETD, + .CLOSE NETICP, +DATTC9: POP P,B + POP P,A + PJRST ACKENR + +SUBTTL XRSQ, XRCP - Select multi-rcpt scheme, and specify rcpts. + + ; XRSQ - Specifies a multi-rcpt scheme to use, + ; or inquires preference. Always resets stuff. + +XRSQ: HRRZ B,(A) ; Get count for argument string + JUMPLE B,[SETZM RSCHEM ; No argument means reset to no scheme. + MOVEI A,[ASCSTR [200 OK, we're now using no scheme.]] + JRST XRSQ70] ; Reset stuff and send message. + PUSHJ P,CVSUPR ; Convert arg to uppercase + EQUSTR A,[ASCSTR [?]] + CAIA + JRST [MOVEI A,[ASCSTR [215 R The preferred scheme is recipients first.]] + JRST XRSQ70] + EQUSTR A,[ASCSTR [R]] + CAIA + JRST [SETOM RSCHEM ; Aha, want to use R scheme! + MOVEI A,[ASCSTR [200 OK, we're now using scheme R.]] + JRST XRSQ70] + ; If here, didn't recognize anything. + MAKSTR REPLY,[[501 This site can't use scheme ],TS,(A),[.]] + MOVEI A,REPLY ; Point to reply string, and drop thru. + + ; Come here to reset all schemes and return reply. +XRSQ70: SETZM RCPIDX ; Simple, just clear index. + PJRST ACKEND + +RSCHEM: 0 ; Scheme in use. 0 is none, -1 is (R)cpts first; in future + ; +1 may mean (T)ext first. + + + ; XRCP - Specifies a recipient for the text of + ; a following MLFL or MAIL, using R scheme. + +XRCP: SKIPL RSCHEM ; Make sure R scheme is being used. + JRST [ MOVEI A,[ASCSTR [507 No scheme is selected yet; use XRSQ.]] + PJRST ACKEND] + PUSHJ P,RCPSTO ; Store argument string in tables. + PJRST NLREND ; If null rcpt, complain. + PUSHJ P,BLOATP ; Die immediately if can't accept mail now + JSR LOGOUT + MOVEI A,[ASCSTR [200 Check.]] + PJRST ACKEND ; Affirm that rcpt is stored. + +NLREND: MOVEI A,[ASCSTR [450 No recipient?]] + PJRST ACKEND + + +; RCPSTO - Stores current argument string in recipient +; tables and sets R to current RCPIDX. + +RCPSTO: MOVE R,RCPIDX ; Get current IDX into rcpt table + HRRZ B,(A) ; Get count of string + CAIN B,0 ; Null? + POPJ P, ; If so, return w/o skipping or changing R. + JUMPLE R,[UAROPN [RTABAR ? [10]] ; If first rcpt, initialize array table + UAROPN [%ARTCH,,RSTRAR ? [20]] ; And string storage area. + JRST .+1] + MOVEI C,2(R) ; See if there will be enough room in array... + CAMLE C,$ARLEN+RTABAR ; Skip if enough. + JRST [ MOVEI B,10 ; Nope, need to expand by 10. + UAREXP B,RTABAR ; (it's just a nice small round number) + JRST .-1] ; Re-try check, just to be sure. + OUTOPN TMPC,[$UCUAR,,RSTRAR] ; Open (or re-open) temp chan + MOVE C,$ARWPT+RSTRAR ; And before writing into string area, save + SUB C,$ARLOC+RSTRAR ; its relative write BP. + OUTS TMPC,(A) ; Now store string! + MOVE B,$ARLOC+RTABAR ; Get start addr of array, + ADDI B,(R) ; So as to get abs addr of new slot + MOVEM C,1(B) ; And store relative BP to string + HRRZ C,(A) ; Along with + MOVEM C,(B) ; its char count. + ADDI R,2 ; Now officially enter, by bumping idx! + MOVEM R,RCPIDX + AOS (P) + POPJ P, + +RCPIDX: 0 ; Holds IDX to first free rcpt slot in RTABAR. +RTABAR: BLOCK $ARSIZ ; Rcpt table, a "String array" of 2-wd string descriptors. +RSTRAR: BLOCK $ARSIZ ; Area holding string text for above. +RCPSTR: BLOCK 2 ; Holds descriptor for a selected rcpt - NOT a normal string var! See RCPSEQ. + + + + +; RCPSEQ - Given idx to rcpt in R, stuffs string descriptor +; for that rcpt into RCPSTR, and increments R to point at next rcpt. + +RCPSEQ: CAML R,RCPIDX ; At or past limit yet? + POPJ P, ; Non-skip return if so. + PUSHAE P,[A,B] + MOVE A,$ARLOC+RTABAR ; Get start addr of array + ADDI A,(R) ; Get abs addr of selected rcpt descr. + MOVE B,1(A) ; Get rel. BP for string + ADD B,$ARLOC+RSTRAR ; Make abs + MOVEM B,RCPSTR+1 ; Store + MOVE B,(A) ; Get char cnt + MOVEM B,RCPSTR ; And store that too to finish. + POPAE P,[B,A] + ADDI R,2 ; Bump R to point at next rcpt... + AOS (P) ; Skip on win... + + POPJ P, + + SUBTTL MLFL, MAIL, XSEN/XSEM/XMAS - Mailing Commands/Routines. + +; RCLRET - Rcpt Clear Return, commonly PJRST'd to after +; error reported in a mail routine. +RCLRET: SETZM RCPIDX ; Clear recipient storage. + POPJ P, ; And return. + + +; RCLACK - Clear recipients then exit through ACKEND +; A has string pointer to ack message to send. +RCLACK: SETZM RCPIDX + PJRST ACKEND + + ; MLFL - Receives text over data connection to mail to + ; specified recipient. + +MLFL: SKIPE DCTYPE ; Make sure current type is ASCII... + JRST [ MOVEI A,[ASCSTR [402 MLFL is implemented only for ASCII mode.]] + PJRST RCLACK] + PUSHJ P,RCPSTO ; Store argument as rcpt... + JUMPLE R,NLREND ; Null rcpt, error unless some rcpts already + ; stored, which implies R scheme in use. + PUSHJ P,BLOATP ; Punt if mailer's dir is getting full + JSR LOGOUT + PUSHJ P,DATCNI ; Open data connection + PJRST RCLRET ; foo, didn't win. + MOVEI A,[ASCSTR [250 Hello, mailer!]] + PUSHJ P,NETREP + PUSHJ P,GETNAR ; Now pull stuff into area over data conn! + PJRST RCLRET ; Whoops? well, it does own reporting. + PUSHJ P,MAILIT ; Now mail the area! + PJRST RCLRET ; tsk tsk + MOVEI A,[ASCSTR [252 Thanks for the mail.]] + PJRST RCLACK + + ; MAIL - Collect text over command connections until a + ; . seen, and mail to recipient. + +MAIL: PUSHJ P,RCPSTO ; Store arg as rcpt... + JUMPLE R,NLREND ; If twas null, error if no other rcpts. + PUSHJ P,BLOATP ; Don't accept mail if mailer dir is full + JSR LOGOUT + MOVEI A,[ASCSTR [350 Hello, mailer!]] + PUSHJ P,NETREP + PUSHJ P,GETML ; Pull in the mail! + PJRST RCLRET ; If error, reset rcpt storage. + PUSHJ P,MAILIT ; Now mail it! + PJRST RCLRET ; As above. + MOVEI A,[ASCSTR [256 Thanks for the blurb.]] + PJRST RCLACK + + ; XSEN - eXperimental, SENd. Collects text just like MAIL but + ; instead of mailing, tries to :SEND to recipient. + +XSEN: PUSHJ P,RCPSTO ; Store rcpt name for mailing purposes + JUMPLE R,NLREND ; Error if null rcpt and no others stored. + CAIE R,2 + JRST [ MOVEI A,[ASCSTR [450 You can't XSEN to more than one recipient.]] + PJRST RCLACK] + PUSHJ P,CVSIX ; Convert name to 6bit... + MOVE B,A + PUSHJ P,ONLINE ; See if online... + JRST [ MOVEI A,[ASCSTR [450 That user is not on-line now.]] + PJRST RCLACK] + MOVEI A,[ASCSTR [350 That user is on-line; proceed with message.]] + PUSHJ P,NETREP + PUSHJ P,GETML ; Get messge text! + JRST RCLRET + PUSHJ P,SENDIT ; Try to :SEND it... + JRST [ MOVEI A,[ASCSTR [450 That user is either not on-line or not accepting messages.]] + PJRST RCLACK] + MOVEI A,[ASCSTR [256 Message was sent successfully.]] + PJRST RCLACK + + ; XSEM - Like XSEN, but Mails if the :SEND fails. + +XSEM: PUSHJ P,RCPSTO ; Store rcpt name for mailing purposes + JUMPLE R,NLREND ; Error if null rcpt and no others stored. + CAIE R,2 + JRST [ MOVEI A,[ASCSTR [450 You can't XSEM to more than one recipient.]] + PJRST RCLACK] + PUSHJ P,CVSIX + MOVE B,A + MOVEI A,[ASCSTR [350 Proceed with message.]] + PUSHJ P,NETREP + PUSHJ P,GETML + JRST RCLRET + PUSHJ P,SENDIT + CAIA + JRST [MOVEI A,[ASCSTR [256 Message was sent successfully.]] + PJRST RCLACK] + PUSHJ P,BLOATP ; Punt now if mailer busy + JSR LOGOUT + PUSHJ P,MAILIT + JRST RCLRET + MOVEI A,[ASCSTR [256 Message was not sent but was mailed.]] + PJRST RCLACK + + + ; XMAS - Mail And Send. Does both XSEN and MAIL. + +XMAS: PUSHJ P,RCPSTO ; Store rcpt name for mailing purposes + JUMPLE R,NLREND ; Error if null rcpt and no others stored. + CAIE R,2 + JRST [ MOVEI A,[ASCSTR [450 You can't XMAS to more than one recipient.]] + PJRST RCLACK] + PUSHJ P,BLOATP ; Punt now if mailer busy + JSR LOGOUT + PUSHJ P,CVSIX + MOVE B,A + MOVEI A,[ASCSTR [350 Proceed with message.]] + PUSHJ P,NETREP + PUSHJ P,GETML + JRST RCLRET + PUSHJ P,SENDIT + JRST [ PUSHJ P,MAILIT + JRST RCLRET + MOVEI A,[ASCSTR [256 Message was not sent but was mailed.]] + PJRST RCLACK] + PUSHJ P,MAILIT + JRST RCLRET + MOVEI A,[ASCSTR [256 Message was both sent and mailed.]] + PJRST RCLACK + + +; ONLINE - See if UNAME in B is logged in. + +ONLINE: SYSCAL OPEN,[[UBPFJ+.UII,,DC] ? ['USR,,] ? B ? ['HACTRN]] + CAIA + AOS (P) + .CLOSE DC, + POPJ P, + +; SENDIT - Sends stored mail to UNAME specified by B. Skips if +; successfully sent. +SENDIT: SYSCAL OPEN,[[.UAO,,DC] ? ['CLI,,0] ? B ? ['HACTRN]] + POPJ P, + OUTOPN DC, ;open as .IOT UUO channel + FWRITE DC,[TI,177,[TTY msg from ],HST,FRNHST,[: +],TA,BUFFAR] + .CLOSE DC, + AOS (P) + POPJ P, + + +; GETML - Get Mail over command connections. Reads lines until a +; . seen. Skips if successfully read. A clobbered. + +GETML: UAROPN [%ARTCH+%ARTZM,,BUFFAR ? [2000]] + OUTOPN TMPC,[$UCUAR,,BUFFAR] +GETML2: PUSHJ P,GETNLN + EQUSTR A,[ASCSTR [.]] ; Message terminator? + CAIA ; Nope + JRST GETML5 ; Yep, go end msg. + TLNN F,%LSMTP ; Using SMTP transparency? + JRST GETML4 ; Nope, skip it. + HRRZ B,(A) + JUMPE B,GETML4 + MOVE C,1(A) + ILDB B,C ; Get 1st char of line + CAIE B,". ; If it starts with a period, + JRST GETML4 + MOVEM C,1(A) ; Then must flush it from line. + SOS (A) +GETML4: OUTS TMPC,(A) ; Squirp line into storage area. + CRLF TMPC, ; With tasteful CRLF. + JRST GETML2 + +GETML5: MOVE A,$ARRPT+BUFFAR + PTRDIF A,$ARWPT+BUFFAR ; Compare read with write ptr to see how big. + JUMPE A,[MOVEI A,[ASCSTR [256 Message was empty and thus not mailed.]] + PJRST ACKEND] + AOS (P) + POPJ P, + +; Refuse to accept mail if mailer directory is close to full. +; This is an attempt to avoid bloating the mailer so the dir fills up and +; it dies needing human intervention. + +.VECTOR UFD(+1) ; OK, so the server is a page larger now... +UFDBMX==:*UFDBPW ; Max number of bytes in a directory + +IFN UFDBYT-6, .ERR UFDBYT HAS CHANGED! +UFDBPS: 440600,,UFD+UDDESC + 360600,,UFD+UDDESC + 300600,,UFD+UDDESC + 220600,,UFD+UDDESC + 140600,,UFD+UDDESC + 060600,,UFD+UDDESC + +BLOATP: PUSHAE P,[A,B,C,D,E] + SKIPE SMTPSW ;Maybe someone manually decided COMSAT + JRST BLOTP8 ; is bloated, in which case we should die. + MOVEI A,AIMDEV +; DM runs COMSAT now. +; TLNE F,%DMSW +; MOVEI A,DMMDEV + SYSCAL OPEN,[[.BII,,DC] ? MOVE (A) + [SIXBIT /.FILE./] ? [SIXBIT /(DIR)/] + MOVE 1(A)] + JRST BLOTP9 + MOVE A,[-,,UFD] + .IOT DC,A + CAME A,[-1,,UFD+LUFD] + JRST BLOTP9 + .CLOSE DC, + MOVEI C,UFDBMX ; C: available room in bytes + SKIPA A,UFD+UDNAMP ; A: -> current name block +BLOTP1: ADDI A,LUNBLK + CAIL A,LUFD + JRST BLOTP7 + SKIPN UFD+UNFN1(A) + JRST BLOTP1 + SUBI C,LUNBLK*UFDBPW + MOVE B,UFD+UNRNDM(A) + LDB D,[UNDSCP B] + IDIVI D,UFDBPW + ADD D,UFDBPS(E) + TLNE B,UNLINK + JRST BLOTP5 +BLOTP3: ILDB B,D + SOJ C, + JUMPE B,BLOTP1 + TRNN B,40 + JRST BLOTP3 +REPEAT NXLBYT, ILDB B,D ? SOJ C, + JRST BLOTP3 + +BLOTP5: ILDB B,D + SOJ C, + JUMPE B,BLOTP1 + CAIE B,': + JRST BLOTP5 + ILDB B,D + SOJA C,BLOTP5 + +BLOTP7: ; Leave dir 25% free. This is about the right amount of room to + ; allow LISTS MSGS to get garbage collected even if it gets huge + ; (like 1700 blocks or more). Of course this is a function of how + ; fragmented the disk is -- your results may vary... + CAIL C,/100. + JRST BLOTP9 +BLOTP8: ; The directory is bloated, so we should temporarily refuse + ; this message. For SMTP we can return a good temp error, but + ; for FTP we can't since FTP reply codes are so + ; non-standardized -- so in the latter case we just die, + ; which will get treated as a temporary error. + TLNN F,%LSMTP ; Are we SMTP? + JSR LOGOUT ; No, just die. + CAIA ; Take non-skip loss return +BLOTP9: AOS -5(P) + POPAE P,[E,D,C,B,A] + POPJ P, + +IFN 0,[ ; Old version that tries to count MAIL files. +;Refuse to accept the mail if more than 30 queued mail files. +;This is an attempt to avoid bloating the mailer so the dir fills +;up and it dies needing human intervention. +BLOATP: PUSHAE P,[A,B,C] + SKIPE SMTPSW ;Maybe someone manually decided COMSAT + JRST BLOTP8 ; is bloated, in which case we should die. + MOVEI A,AIMDEV +; DM runs COMSAT now. +; TLNE F,%DMSW +; MOVEI A,DMMDEV + SYSCAL OPEN,[[.UAI,,DC] ? (A) ? 2(A) ? [SIXBIT/>/] ? 1(A)] + JRST BLOTP9 + SYSCAL RFNAME,[MOVEI DC ? MOVEM B ? MOVEM B ? MOVEM B] + .LOSE %LSSYS + SYSCAL OPEN,[[.UAI,,DC] ? (A) ? 2(A) ? [SIXBIT/-<':_6> + ;Don't worry about additional carries, close enough for gov't work + CAMG B,C + JRST BLOTP9 +BLOTP8: ; There are more than 30 versions, so we should temporarily refuse + ; this message. For SMTP we can return a good temp error, but + ; for FTP we can't since FTP reply codes are so + ; non-standardized -- so in the latter case we just die, + ; which will get treated as a temporary error. + TLNN F,%LSMTP ; Are we SMTP? + JSR LOGOUT ; No, just die. + CAIA ; Take non-skip loss return +BLOTP9: AOS -3(P) + POPAE P,[C,B,A] + POPJ P, + +] ; IFN 0 + +; MAILIT - Routine that actually mails stored message text to recipient +; specified in ARGSTR. Clobbers A. + +MAILIT: PUSH P,B + MOVE A,$ARWPT+BUFFAR ; Get write pointer (end of used area) + SUB A,$ARLOC+BUFFAR ; Make relative to beg + MULI A,5 ; do bp hack + ADD B,UADBP7(A) ; Get # chars. + MOVE A,B + POP P,B + CAILE A,16.*5000. ; Big enough that Comsat will probably reject? + JRST TOOBIG + +IFN $$DM,[ + TLNN F,%DMSW + JRST MALT50 ;"normal" non-DM + ; DM mail + MOVSI A,DMMDEV ; Set up file name block for error message + HRRI A,FILDEV + BLT A,FILDEV+3 + MOVEI A,DMMDEV + SYSCAL OPEN,[CERR ERRCOD ? [.UAO,,DC] ? (A) ? FTPOF1 ? FTPOF2 ? 1(A)] + PJRST MLTERR ; Couldn't open for write?? Report & return. + OUTOPN DC, + OUTOPN DMC,[$UCXCT,,[PUSHJ P,DMOUT]] + FWRITE DC,[["RECEIVED-FROM-HOST" ],N9,FRNHST,[ +"SCHEDULE" ("SENDING") +"TO" (]] + SETZ R, ; Initialize for plucking rcpts +MALT20: PUSHJ P,RCPSEQ ; From table into RCPSTR... + JRST MALT30 ; Exit when no more. + OUTI DC,"" + OUTS DMC,RCPSTR ; Output rcpt as muddle string + OUTI DC,"" + OUTI DC,40 ; Separate each w/space. + JRST MALT20 ; Get another. +MALT30: FWRITE DC,[[) +"TEXT" +"]] + FWRITE DMC,[TA,BUFFAR] ;out goes the message text + FWRITE DC,[[ +" +]] + SYSCAL RENMWO,[CERR ERRCOD ? CIMM DC ? 2(A) ? 3(A)] + PJRST MLTERR ; Failed?? + SYSCAL FINISH,[CERR ERRCOD ? CIMM DC] + PJRST MLTERR ; Write out file + directory to disk + .CLOSE DC, + SYSCAL DEMSIG,[['COMSYS]] + JFCL + JRST MALT90 ;won +];$$DM + + + ; AI,ML,MC mail +MALT50: MOVSI A,AIMDEV ; Set up file name block for error message + HRRI A,FILDEV + BLT A,FILDEV+3 + MOVEI A,STOBIG + MOVEM A,STOIOC ;If any IOC lossage, give user error response. + MOVEI A,AIMDEV + SYSCAL OPEN,[CERR ERRCOD ? [.UAO,,DC] ? (A) ? FTPOF1 ? FTPOF2 ? 1(A)] + PJRST MLTERR ; Failed on open??? + OUTOPN DC, ; Open UUO chan for .IOT/SIOT + FWRITE DC,[[NET-MAIL-FROM-HOST:],OCT,FRNHST,[ +]] + TLNN F,%LSMTP + JRST MALT59 ; Skip SMTP hacking + SKIPE FRMSTR ; Any return-path given? + OUTCAL(DC,("RETURN-PATH:"),TS(FRMSTR),EOL) +MALT59: SETZ R, ;Initialize for plucking off rcpts. + PUSH P,A +MALT60: PUSHJ P,RCPSEQ ; Get descriptor into RCPSTR. + JRST MALT70 ; Done... + FWRITE DC,[[TO:"]] + MOVE A,RCPSTR+1 ;Check first character in rcpt + ILDB A,A ;To see if structured rcpt + CAIE A,"( + CAIN A,"[ + JRST MALT61 + CAIE A,"" ;or quoted + CAIN A,"{ + JRST MALT61 + TLNE F,%LSMTP ; Don't quote SMTP rcpts for now. + JRST MALT61 + OUT(DC,LPAR,(|"|),TS(RCPSTR),(|"|),RPAR,EOL) ;Not structured, quote it + JRST MALT60 +MALT61: FWRITE DC,[TS,RCPSTR,[ +]] ;Structured or quoted, take as is + JRST MALT60 ; Get another. + +.SCALAR FGNHST,FGNDEV ; Foreign dev and host for received lines + +MALT70: SYSCAL RFNAME,[MOVEI NETI ? MOVEM A ? REPEAT 3,[ ? MOVEM FGNHST]] + SETZM FGNHST ; Get type of net conn and foreign address + CAMN A,[SIXBIT 'CHAOS'] + HRRZS FGNHST ; Clear out HOSTS3 gubbish for Chaos + SKIPN FGNHST ; Total lossage? + MOVSI A,'??? ; Yeah, make sure user knows we're senile + MOVEM A,FGNDEV ; Save net type away + POP P,A + OUT(DC,CRLF,("TEXT;-1"),CRLF,("Received: from "),TS(FGNNAM),SP) + OUT(DC,C(LPAREN),6F(FGNDEV),SP,O(FGNHST),C(RPAREN)) +;Note: the Received-from line contains the .ARPA kludge!! +IFN $.ARPA, OUT(DC,(" by "),TZ(@OWNNAM),(".ARPA; "),TIM(RFC1)) +.ELSE, OUT(DC,(" by "),TZ(@OWNNAM),("; "),TIM(RFC1)) + OUT(DC,CRLF,TA(BUFFAR)) + SKIPE XDBGSW + JRST [ SYSCAL RENMWO,[CERR ERRCOD ? CIMM DC ? AIMXF1 ? 3(A)] + PJRST MLTERR + JRST MALT75] + SYSCAL RENMWO,[CERR ERRCOD ? CIMM DC ? 2(A) ? 3(A)] + PJRST MLTERR ; Argh? Report file error & return. +MALT75: SYSCAL FINISH,[CERR ERRCOD ? CIMM DC] + PJRST MLTERR ; Write out file + directory to disk + .CLOSE DC, + SETZM STOIOC +MALT90: AOS (P) + POPJ P, + +MLTERR: SETZM STOIOC ; Just a little paranoia + PJRST FILERR + +;Mail too big, reject it +TOOBIG: MOVEI A,[ASCSTR [552 Message is too large to mail; use FTP.]] + PUSHJ P,NETREP + POPJ P, ;Error return + +IFN $$DM,[ + ; Hack, XCT'd for each character of DM mail (!!) which + ; ensures that data is quoted properly for MUDDLE parsing. +DMOUT: PUSHAE P,[40,UUOH,U2] + CAIN U1,^C ;CATCH ^C'S + JRST DMOUT3 + CAIE U1,"" ;catch quote mark + CAIN U1,"\ ;or MUDDLE quoting char + JRST DMOUT3 +DMOUT2: OUTI DC,(U1) ;before outputting. + POPAE P,[U2,UUOH,40] + POPJ P, +DMOUT3: PUSH P,U1 + OUTI DC,"\ ;and quote either + POP P,U1 + JRST DMOUT2 +];$$DM + + SUBTTL String hacking rtns + +UUODEF EQUSTR,UEQSTR ;extra UUO for easy string comparision + +UEQSTR: MOVE U1,40 + LDB U2,[$ACFLD,,U1] + MOVE U2,(U2) ;get addr of string AC points to + HRRZ U3,(U1) ;GET CNT 1 + HRRZ U4,(U2) ;AND 2 + CAIE U3,(U4) + JRST UUORET ;NOT EQUAL, DIFFERENT LENGTHS + MOVE U1,1(U1) + MOVE U2,1(U2) + PUSH P,U3 ; Save cnt on stack. +UEQST2: SOSGE (P) + JRST UEQST5 + ILDB U3,U1 + ILDB U4,U2 + CAIN U3,(U4) + JRST UEQST2 + SUB P,[1,,1] + JRST UUORET +UEQST5: SUB P,[1,,1] + AOS UUOH + JRST UUORET + + + ; Parse a word off string pointed to by A, leaves ptr to word in + ; B and updates string read from. B furnishes char to break on. +PRSWRD: PUSHAE P,[C,D] + MOVE D,B ; Save desired break char in D. + BCONC + HRRZ C,(A) ;make sure something there + JUMPG C,PRSW5 + JRST PRSW6 +PRSW2: ILDB B,1(A) + CAIN B,(D) + JRST PRSW6 + OUTI STRC,(B) ; Collect string. +PRSW5: SOJGE C,PRSW2 + SETZ C, +PRSW6: ECONC WRDSTR + HRRM C,(A) + MOVEI B,WRDSTR + POPAE P,[D,C] + POPJ P, + + ;takes ptr in A to string, clobbers so that leading/trailing blanks flushed. +STRIM: PUSHAE P,[B,C,D,E] + HRRZ D,(A) + JUMPE D,STRIM9 + MOVE E,1(A) ;get cnt and bp for string. +STRIM1: MOVE C,E ;save so don't have to D7BPT it. + ILDB B,E + CAIN B,40 + JRST [ SOJG D,STRIM1 + JRST STRIM8] ;all blanks. + MOVEM C,1(A) ;store trimmed start ptr (perhaps same as original) + PTSKIP D,C ;increment ptr by # chars remaining +STRIM2: LDB B,C + CAIN B,40 + JRST [ D7BPT C + SOJG D,STRIM2 + JRST STRIM8] ;all blanks and first loop missed?? +STRIM8: HRRM D,(A) ;store new cnt back. +STRIM9: POPAE P,[E,D,C,B] + POPJ P, + +; GETNLN - Get Network Line. Reads input over NETI until CRLF seen, +; returns ptr in A to resulting string. If NETI input vanishes +; an immediate logout is done. + +GETNLN: BCONC ; Begin string + TRZ F,%CR + JRST GETLN4 +GETLN2: TRZE F,%CR + JRST [ CAIN A,^J ; CR followed by LF => terminate line. + JRST GETLN7 + OUTI STRC,^M ; Otherwise, it's either a + JUMPE A,GETLN4 ; CR-NULL, meaning use a bare CR, or + JRST .+1] ; it's a "violation", but pass sequence anyway. + CAIN A,^M + TROA F,%CR +GETLN3: OUTI STRC,(A) +GETLN4: .IOT NETI,A + AOS ALIVEC + CAIN A,377 ; Is it an IAC? + JRST GETLN5 ; Barf! Go flush the TELNET negotiation + JUMPGE A,GETLN2 + JSR LOGOUT ; Die if connection closed on us. + +GETLN5: .IOT NETI,A ; Get next byte + CAIL A,251. + CAILE A,254. ; If it's one of the usual DO/DONT/WILL/WONT + JRST GETLN4 ; (if not, flush IAC and its arg) + .IOT NETI,A ; Then flush the option code following it. + JRST GETLN4 + +GETLN7: ECONC LINPUT ; End string... + MOVEI A,LINPUT + POPJ P, + + +; CVSIX - converts a string var in A to 6bit wd in A +; stops when reach 0 or get 6 chars, or hit blank and previous +; chars were nonblank + +CVSIXH: PUSHAE P,[B,C,D,E,R] ;CVSIXH stops at @ + MOVEI R,"@ + JRST CVSIX0 + +CVSIX: PUSHAE P,[B,C,D,E,R] + MOVEI R,-1 +CVSIX0: MOVE C,1(A) + HRRZ B,(A) + CAILE B,6 + MOVEI B,6 +CVT760: SETZ A, + MOVE D,[440600,,A] +CVT761: ILDB E,C + CAIN E,40 + JUMPN A,CVT762 ;if hit blank, stop only if something already accumulated + JUMPE E,CVT762 + CAMN E,R + JRST CVT762 ;delimiter + CAIL E,141 ;convert to uppercase + CAILE E,172 + CAIA + SUBI E,40 + SUBI E,40 ;convert to 6bit + IDPB E,D + SOJG B,CVT761 +CVT762: POPAE P,[R,E,D,C,B] + POPJ P, + +CVSUPR: PUSHAE P,[B,C,D] + MOVE B,1(A) + HRRZ C,(A) + JUMPG C,CVSUP5 + JRST CVSUP7 +CVSUP2: ILDB D,B + CAIL D,"a + CAILE D,"z + JRST CVSUP5 + SUBI D,40 + DPB D,B +CVSUP5: SOJGE C,CVSUP2 +CVSUP7: POPAE P,[D,C,B] + POPJ P, + + +; A - ptr to string descriptor +; B - [default file block],,[result file block] + +FILPAR: PUSHAE P,[A,B,C,D,E] + HRRZ E,B ;get result addr + BLT B,3(E) ;zap default values into result block + PUSHJ P,FNPARD ;parse string as filename, DDT style + CAIE A, + MOVEM A,(E) ;device + CAIE B, + MOVEM B,1(E) ;dir + CAIE C, + MOVEM C,2(E) ;fn1 + CAIE D, + MOVEM D,3(E) ;fn2 + POPAE P,[E,D,C,B,A] + POPJ P, + +; FILGET - File Getter. A has ,,; specified file +; is opened and read into specified area; if =0 then +; an area is created. In either case the ARPT is returned in A, +; and routine skips. If the OPEN fails, its error code is +; returned instead with no skip. +; TXFIN - similar, but assumes DC already open on channel, and never skips, +; since no lossage is possible. (!) + +FILGET: .CALL OPNBII ; Try to open FILBLK specified. + JRST [ MOVE A,OPNERR ; For failure, return error code. + POPJ P,] + AOS (P) +FILIN: PUSH P,B + MOVE B,[DC,,FGTDEV] + .RCHST B, ;get channel status for possible later ref. + SYSCAL FILLEN,[CIMM DC ? CRET B ? CERR OPNERR] + JRST [ MOVE B,OPNERR ; Failed? Should only happen if + CAIE B,34 ; error = wrong type dev. + JSR SYSLOS ; no. this shouldn't happen. + MOVEI B,400 ; If no length available, use 1/4 page + JRST .+1] + ADDI B,1 ;add 1 so .IOT ptr won't count out completely + HLRZS A ; put ARPT into RH. + UAROPN A,[(A) ? B] ;open area, with length at least that of file + MOVN B,B ;neg + HRLZ B,B ;for .iot ptr + HRR B,$ARLOC(A) ;get addr to store it...starting addr of area +FILGT5: .IOT DC,B ;grab + HRRZM B,$ARWPT(A) ;set write ptr for area. + JUMPGE B,[MOVEI B,400 ; If counted completely out, + UAREXP B,(A) ; expand and get more. + HRRZ B,$ARWPT(A) + HRLI B,-400 + JRST FILGT5] + .CLOSE DC, + POP P,B + POPJ P, + +OPNBII: SETZ ? SIXBIT /OPEN/ ? [.BII,,DC] ? CERR OPNERR + (A) ? 2(A) ? 3(A) ? SETZ 1(A) +OPNERR: 0 + +FGTDEV: BLOCK 10 ;channel status info + + +; TXFGET - Text File Getter. Like FILGET, but assumes file is text +; and converts area to text, adjusting EOF properly. +; TXFIN - similar conversion but like FILIN assumes DC is open and +; never skips. + +TXFGET: PUSHJ P,FILGET ; Open and get file into area. + POPJ P, ; failed. + AOSA (P) ; Won, skip into conversion & skip on return. +TXFIN: PUSHJ P,FILIN + UARTYP [%ARTCH,,(A)] ; Convert area to text, adjusting EOF automatically. + POPJ P, + +SUBTTL Randomness +; IPNUM - takes addr to string in A, +; tries to parse as a number (oct or dec). returns value in A, +; doesn't skip if bad parse. + +IPNUM8: TRZA F,%DEC ;don't force to decimal. +CVSDEC: +IPNUM: TRO F,%DEC ;do! + PUSH P,B + HRRZ B,(A) ;get cnt + MOVE A,1(A) ;and bp + MOVEM A,NUMPTR' ;save ptr to string +IPNUM0: JUMPE B,POPBJ + ILDB A,NUMPTR ;loop to flush leading blanks + CAIE A,40 + CAIN A,^I + SOJA B,IPNUM0 + + TRO F,%TMP ;set flag to negate result + CAIE A,"- + JRST [ TRZ F,%TMP ;unless not negative # + D7BPT NUMPTR ;in which case must decr. bp + JRST .+1] + PUSHAE P,[C,D] + SETZB C,D +IPNUM2: SOJL B,IPNUM6 ;decrement cnt; if count out here, it's octal. + ILDB A,NUMPTR ;get ascii digit + CAIL A,"0 ;check to be sure it's a digit + CAILE A,"9 + JRST IPNUM3 ;foo! non-numeric char. + LSH C,3 ; octal*8 + IMULI D,10. ; decimal*10 + ADDI C,-"0(A) + ADDI D,-"0(A) + JRST IPNUM2 + +IPNUM3: CAIE A,". ;is non-numeric char a decimal pt? + JRST IPNUM5 ;no, go flush blanks/tabs + MOVE C,D ;ah yes, use decimal accumulator. + ;now flush blanks/tabs +IPNUM4: SOJL B,IPNUM6 + ILDB A,NUMPTR +IPNUM5: CAIE A,40 + CAIN A,^I + JRST IPNUM4 + JRST IPNUM7 ;foo, lose again. can't do fractions. + +IPNUM6: TRNE F,%DEC + SKIPA A,D ;use decimal if flag set. + MOVE A,C + AOS -3(P) + TRNE F,%TMP + MOVN A,A +IPNUM7: POPAE P,[D,C,B] + POPJ P, + +;XLBT decimal-ITS-host-address +;If a loop-back plug is present, this is the wrong address and +;we return 529 wrong address. If it's the right address we return +;200 right address. 500 Illegal command indicates that the right +;host was probably reached, anyway not one that knows about XBLT. + +XLBT: PUSHJ P,CVSDEC ; Convert decimal string. + JRST [ MAKSTR REPLY,[[501 Bad numeric argument: ],TS,ARGSTR] + PJRST ACKENR ] + PUSHJ P,NETWRK"STDHST ; Standardize the number. + CAME A,OWNHST + JRST [ MAKSTR REPLY,[[529 Wrong host. This is ],HND,OWNHST,[.]] + PJRST ACKENR ] + MOVEI A,[ASCSTR [200 Right address]] + PJRST ACKEND + + ; Compose filename string from RCHST results & return ptr in A. +RCHSTR: SYSCAL RCHST,[CIMM DC ? CRET RCHDEV + CRET RCHFN1 ? CRET RCHFN2 ? CRET RCHDIR] + JSR AUTPSY + MAKSTR FILNAM,[6F,RCHDEV,[:],6F,RCHDIR,[;],6F,RCHFN1,[ ],6F,RCHFN2] + MOVEI A,FILNAM + POPJ P, + + ; Compose filename string from FILDEV block & return ptr in A. +FILSTR: SKIPN A,FILDIR + MOVE A,[SIXBIT /(NIL)/] + MAKSTR FILNAM,[6Q,FILDEV,[:],6Q,A,[;],6Q,FILFN1,[ ],6Q,FILFN2] + MOVEI A,FILNAM + POPJ P, + + ; Compose error string for last failing .CALL and return ptr in A. +ERRSTR: PUSH P,B + SYSCAL OPEN,[CIMM TMPC ? ['ERR,,] ? [4] ? ERRCOD] + JSR AUTPSY + BCONC + CAIA +ERRST2: OUTI STRC,(A) + .IOT TMPC,A + CAIN A,^M + JRST ERRST5 + CAIE A,^L + CAIN A,^C + CAIA + JUMPGE A,ERRST2 +ERRST5: ECONC STRERR + MOVEI A,STRERR + POP P,B + POPJ P, + +STRNAM FGNNAM ; Foreign host name as furnished in SMTP HELO command +STRNAM FRMSTR ; Return-path name given in SMTP MAIL, SEND, etc. +STRNAM TMPSTR +STRNAM REPLY +STRNAM WRDSTR +STRNAM LINPUT +STRNAM FILNAM +STRNAM STRERR +STRNAM ARGSTR + +STRNGS: SBLOCK + NSTRS==<.-STRNGS>/2 + + +CONSTANTS +VARIABLES + +ARPAGS: ,,LSTPAG ; Define free area to be everything above this. +LSTPAG==<.+1777>/2000 + +END GO diff --git a/src/sysnet/ftpu.161 b/src/sysnet/ftpu.161 new file mode 100755 index 00000000..bfa09229 --- /dev/null +++ b/src/sysnet/ftpu.161 @@ -0,0 +1,2816 @@ +;-*- Mode: MIDAS -*- +TITLE FTPU - NEW FTP USER FOR ITS + +.SYMTAB 5001.,7000. + +SUBTTL Basic Definitions + +;Accumulators + +F=0 ; Flags +A=1 ;Standard ACs +B=2 +C=3 +D=4 +E=5 +T=6 +TT=7 +R=10 +; =11 ;Not used +OC=12 ; Output package +U1=13 ;UUO accs +U2=14 +U3=15 +U4=16 +P=17 ;Stack pointer. + +;Channels + +ICPCH==0 ;ICPCH must be 0 for socket table hackery to win!! +TMPC==1 ;temp +NETI==2 ;Net input ch (telnet connection) +NETO==3 ;Net output ch (telnet connection) +NETDI==4 ;Net data input channel +NETDO==5 ;Net data output channel +STRC==6 ;UUO string output channel +DC==7 ;general purpose dsk channel (in and out) +TYIC==10 ;TTY input +TYOC==11 ;TTY output +ERRC==12 ;ERR device +SCRIPC==13 ;Script file out +COMC==14 ;Command file in + +; Flags +%LTCP==1 ; LH 1 = Using TCP +%TMP==1 ; RH temporary flag + +TIMOUT=30.*120. ;Timeout value is two minutes. + +;Subroutine Packages. +DEFINE %%.CRLF C,ARG +IFSN ARG,, .ERR non-null argument "ARG" after CRLF in FWRITE + CRLF C, +TERMIN + +$$OUT==1 +$$OFLT==1 +UAREAS==1 ; Assemble UUO areas +USTRGS==1 ; and string hackery. +UFLOAT==1 ; and floating point typeout +.INSRT KSC;NUUOS > + ;and wonderful filename parser +.INSRT KSC;NFNPAR > + +$$HST3==1 +$$SYMLOOK==1 ;and miraculous network routines +$$HSTMAP==1 ;and routines for the host names table file +$$HOSTNM==1 +$$OWNHST==1 +$$ICP==1 ;and network connection routines +$$CONNECT==1 ;and tcp net connection routines +$$ANALYZE==1 ;include network error analysis routine +$$ARPA==1 ;handle Arpanet (only, for now) +$$TCP==1 ;handle Internet host parsing. +USETCP: -1 ;For the hostname parser (default) +USENCP: 0 ;For the hostname parser. +.INSRT SYSENG;NETWRK > + +FTPSKT==3 ;standard ICP socket # +FTPORT==25 ;TCP FTP port # + + +SUBTTL Random locations + +TMPLOC 41, ;"1," means illegal instructions cause fatal interrupts. +TMPLOC 42, JSR TSINT + +PAT: +PATCH: BLOCK 100 +PDLLEN==100 +PDL: -PDLLEN,,. + BLOCK PDLLEN + +POPTJ: POP P,T + POPJ P, + +POPBA1: AOS -2(P) +POPBAJ: POP P,B + POP P,A + POPJ P, +POPJ1: AOSA (P) +POP1J: POP P,JUNK +CPOPJ: POPJ P, + +POPAJ1: AOS -1(P) +POPAJ: POP P,A +APOPJ: POPJ P, + +POPCBJ: POP P,C +POPBJ: POP P,B + POPJ P, + + +JUNK: 0 ;for random useless writes +VERSHN: .FNAM2 + VERSION==.FNAM2 + +SCRIPT: 0 ;nonzero if writing script file. +READIN: 0 ;nonzero while rubout processing - inhibits script file output. +COMFIL: 0 ;nonzero if reading command file. +TYITTY: 0 ;nonzero if TTY can be read from. +TYOTTY: 0 ;nonzero if TTY can be written on. +TRITTY: 0 ;nonzero if TTY input was translated (not really device TTY) +TROTTY: 0 ;similar, for TTY output. +DISTTY: 0 ;nonzero if TTY is display (can rub out) +HDXTTY: 0 ;nonzero if half duplex TTY and shouldn't echo. +SILENT: 0 ;nonzero if shouldn't type on TTY (cleared if try to read tty). +INHIDE: 0 ;nonzero if TYILIN shouldn't echo input. (eg for pwd) +DEBUG: 0 ;nonzero inhibits death, disowning, etc. +PRREP: 0 ; -1 if printing server replies. + +IFNDEF BUFFL,BUFFL==4000 +BUFFER: BLOCK BUFFL ;Buffer for the actual file transfer. +XFRBFL==:BUFFL +XFR8BL==<<+7>/8.> ; # words in 8-bit byte buffer +TMPBUF: BLOCK XFR8BL ; Buffer for packing 8-bit bytes (TCP) + +XFRLBV: 0 ;length of buffer except for one word, in characters, + ; (used by XFRASC.) +XFRLWP: 0 ;Address of last word in used part of buffer +XFRDIR: 0 ;-1 if writing to net +XFRBPW: 0 ;Bytes per word +DCTYPE: 0 ;Transfer Type. 0=ASCII, -1=Image, 1=Local. + ; These are what we think server believes, +DCBYTE: 0 ;Byte size. One of 8., 32., 36. + ; not what user has said he prefers. If user wants to + ; change it, we ask the server before setting these. +DCSENT: 0 ;-1 => The server knows DCTYPE and DCBYTE, either because they + ; are the default (TYPE A, BYTE 8) or because we sent them + ; and they were accepted. + ;0 => The server doesn't know them, they must be TYPE I,BYTE 36 + ; so try sending those before next data transfer operation. + ; For TCP the desired settings are TYPE L 36. +DKIOSW: 0 ;0 Disk input, -1 Disk output +NTIOSW: 0 ;0 Net input, -1 Net output +ICPSOC: 0 ;frn skt to ICP to +LPORT: 0 ;lcl port we listen for data connection on +LDSOC: 0 ;lcl skt for data skt open +FDSOC: 0 ;frn skt for data skt open +FDHST: 0 ;frn hst for data skt open +OWNHST: 0 ; # of own site. +MACHNM: 0 ; Machine name (AI,MC,ML,DM) +ITSVER: 0 ; ITS version # in sixbit +OWNNAM: 0 ; Addr of ASCIZ string for own site-name. + +CNECTD: 0 ;nonzero => connected to a foreign host + +NBITS: 0 ;# bits transferred +NTIME: 0 ;starting time in 30ths + +FILDEV: SIXBIT /DSK/ +FILDIR: 0 +FILFN1: 0 +FILFN2: SIXBIT />/ + +SCRIPF: SIXBIT /DSK/ +SCRIPS: 0 +SCRIP1: SIXBIT /FTPOUT/ +SCRIP2: SIXBIT />/ + +COMDEV: SIXBIT /DSK/ +COMDIR: 0 +COMFN1: SIXBIT /FTPCOM/ +COMFN2: SIXBIT />/ + +FTPOF1: SIXBIT /_FTPU_/ +FTPOF2: SIXBIT /OUTPUT/ + +THOSTB: BLOCK 10 ;Block for THOSTN to store its host name in. + +IFNDEF JCLBFL,JCLBFL==50 +JCLFLG: 0 ;-1 => executing command that came from DDT +SUICID: 0 ;-1 => commit suicide after this command if it wins. +JCLTRN: 0 ;-1 => this is implicit TRAN from JCL. + ; (Suppresses "N bits in M seconds".) +JCLBF1: ASCII/TRAN / +JCLBUF: BLOCK JCLBFL ;Command Line (read from DDT or from TTY) as ASCIZ string. + BLOCK 400 +JCLBFE: ,,-1 ;Nonzero to stop DDT's xfer of JCL. Top byte 0 to end JCL. +JCLBFP: 440700,,JCLBUF ;Addr of block to store JCL in. These 2 words bound +JCLP: 440700,,JCLBUF ;Pointer to read JCL out of. if must "push JCLBUF". +JCLBF2: BLOCK JCLBFL ;Alternate block to read tty input into. +ARGBUF: BLOCK JCLBFL ;ARG reads stuff from JCLBUF, making ASCIZ sting in ARGBUF. +ARGCT: 0 ;These two words are a string variable containing ARGBUF. +ARGPT: 440700,,ARGBUF +ALTARG: BLOCK JCLBFL ;Used to save a way one arg while reading another. + +NCPJNM: SIXBIT /NCPFTP/ ;Name of job to do old-style (NCP based) FTPing. + + +SUBTTL Initialization and Main Loop + +GO: MOVE P,PDL ;Set up PDL and TTY + SETOM TYITTY + SETOM TYOTTY + SETZM TRITTY + SETZM TROTTY + SETZM DISTTY + SETZM HDXTTY + SYSCAL OPEN,[%CLBIT,,.UAI ? %CLIMM,,TYIC ? [SIXBIT /TTY/]] + SETZM TYITTY ;Sometimes we dont have a TTY to read from. + SYSCAL RFNAME,[%CLIMM,,TYIC ? %CLOUT,,B] + .LOSE %LSFIL + CAME B,['TTY,,] ;If the device name is not "TTY" + SETOM TRITTY ; there must be an input translation. + SYSCAL TTYGET,[%CLIMM,,TYIC ? %CLOUT,,B ? %CLOUT,,C] + JRST GO1 + ANDCM B,[606060606060] ;If TYIC really has a TTY, turn off echo. + ANDCM C,[606060606060] + TLO C,010000 ;Enable ^G/^S interrupts + SYSCAL TTYSET,[%CLIMM,,TYIC ? B ? C] + .LOSE 1400 +GO1: SYSCAL OPEN,[%CLBIT,,<.UAO\%TJDIS> ? %CLIMM,,TYOC ? [SIXBIT /TTY/]] + SETZM TYOTTY ;No typeout is maybe OK, if have script XFILE. + SYSCAL RFNAME,[%CLIMM,,TYOC ? %CLOUT,,B] + .LOSE %LSFIL + CAME B,['TTY,,] ;If the device name is not "TTY" + SETOM TROTTY ; there must be an output translation. + SETZM DISTTY + SYSCAL CNSGET,[%CLIMM,,TYOC ? REPEAT 4,[%CLOUT,,JUNK ?] %CLOUT,,A] + JRST GO2 + TLNE A,%TOOVR ;DISTTY on also for glass TTY's + TLNE A,%TOERS ;DISTTY gets -1 if we are on a display TTY. + SETOM DISTTY + TLNE A,%TOHDX ;HDXTTY gets -1 if half duplex (shouldn't echo). + SETOM HDXTTY +GO2: .SUSET [.RXJNAM,,B] ;Look at our job name. + TLO F,%LTCP ;We usually do TCP based FTPing. + CAMN B,NCPJNM ;But if our jname is the magic one + JRST [ TLZ F,%LTCP ; we wont use the Internet FTP. + SETZM USETCP + SETZM USENCP + JRST .+1] + MOVEI A,FTPORT ;TCP means we use this port. + TLNN F,%LTCP + MOVEI A,FTPSKT ;NCP means this is the ICP socket + MOVEM A,ICPSOC ;Remember which port or socket to use. + + MOVEI A,LSTPAG + MOVEI B,0 + PUSHJ P,NETWRK"HSTMAP ;Read in HOSTS3 at LSTPAG + .LOSE + + MOVE B,A ;Then make ARPAGS point at all pages left above it. + SUBI B,400 ;HSTMAP leaves A pointing to first unused page. + HRL A,B + MOVEM A,ARPAGS + UARINIT ARPAGS ;initialize core + STRINIT ;initialize strings + OUTOPN TYOC,[$UCXCT,,[PUSHJ P,UUOTYO]] + OUTOPN SCRIPC, ;allow uuos to type out + + MOVE A,[NETWRK"NW%ARP] ;Get own host number, on Arpanet + PUSHJ P,NETWRK"OWNHST + .LOSE ;Not connected to Arpanet? + MOVEM A,OWNHST + .SUSET [.RSNAME,,FILDIR] + MOVE A,FILDIR + MOVEM A,COMDIR + MOVEM A,SCRIPS + + .SUSET [.ROPTION,,TT] ;Get JCL if present + TLZN TT,OPTCMD + JRST NOJCL + SETZM JCLBUF + MOVE A,[JCLBUF,,JCLBUF+1] + BLT A,JCLBFE + .BREAK 12,[5,,JCLBUF] + MOVE A,JCLP ;If JCL contains an underscore, an implied TRAN + SETOM JCLFLG +TRNCH1: ILDB B,A + CAIE B,^C + CAIN B,^M + JRST TRNCH2 + JUMPE B,TRNCH2 + CAIE B,"_ + CAIN B," + JRST TRNCH3 + CAIE B,"= + JRST TRNCH1 +TRNCH3: SOS JCLP ;insert TRAN in front of JCL + SETOM SUICID ;and exit after completing the transfer. + SETOM JCLTRN ;Suppress the "n bits in m seconds" printout. +TRNCH2: SKIPN JCLBUF +NOJCL: SETZM JCLP + .SUSET [.ROPTION,,TT] + TLO TT,%OPOPC + .SUSET [.SOPTION,,TT] + .SUSET [.SMASK,,[%PIIOC]] ;Enable IOC interrupts + SKIPN TRITTY + .SUSET [.SMSK2,,[1_TYIC]] ;Enable ^G/^S interrupts + JRST MAIN + +SUBTTL Main loop. + +;Come here after finishing a command, or after an error. +MAIN: PUSHJ P,STILOPN ;If connection was closed by other side, tell user. + PUSHJ P,GRATU ;Check for gratuitous reply from server + TLNE F,%LTCP ;If using Internet FTP, + JRST [ .CLOSE NETDI, ; we use a new PORT each time. + .CLOSE NETDO, + JRST .+1 ] + SKIPE JCLFLG ;Prompt for input unless supplied by superior. + JRST MAIN2 + SKIPN CNECTD + OUTI TYOC,"$ ;Prompt with $ if connected, $$ if not. + OUTI TYOC,"$ +MAIN2: PUSHJ P,ARGSPC + [ASCIZ //] + LDB A,[350700,,ARGBUF] + JUMPE A,MAIN1 ;Null command is OK. Do nothing. + MOVEI A,ARGBUF + MOVE E,[-COMTBL,,COMTAB] + PUSHJ P,NETWRK"SYMLOOK ;Gobble Command + JRST MAIN3 ; Not a command - try it as a host name. + CAMN B,[-1] ;Numbers are not allowed as commands. + JRST ERRCOM + HLRZ A,(B) + PUSHJ P,(A) ;get address out of table and call the command. + JRST ERRTR1 ;No skip => failed; flush typeahead of all sorts. +MAIN1: SKIPE SUICID + JRST QUIT + JRST ERRTR2 + +MAIN3: MOVE P,PDL + MOVEI A,ARGBUF ;Couldn't parse command as command name => rescan it + PUSHJ P,NHOSTN ;and try it as a host name. + JRST ERRCOM ; Doesn't make sense as either? + PUSHJ P,CONN ;Command is host number, connect to it + JRST ERRTR1 ;Failure to conect is an error. + JRST MAIN1 + +ERRCOM: OUTZ TYOC,[ASCIZ /Invalid command or host name? +/] + JRST ERRTR1 +ERRCTX: OUTZ TYOC,[ASCIZ /Command not supported under TCP +/] + JRST ERRTR1 +ERRHST: OUTZ TYOC,[ASCIZ/Invalid host name? +/] +ERRTR1: SKIPE TYITTY + .RESET TYIC, + SKIPE COMFIL + OUTZ TYOC,[ASCIZ /Closing Command File +/] + .CLOSE COMC, + SETZM COMFIL + SETZM JCLBUF + MOVE A,[440700,,JCLBUF] + MOVEM A,JCLP + SETZM JCLTRN + SETZM SUICID +ERRTR2: MOVE P,PDL ;Fix up PDL before re-entering main loop. + MOVE A,JCLP ;If there's no JCL, next ARG would find out, + ILDB A,A ;but check now so that we prompt before next ARG. + SKIPN A + SETZM JCLFLG + JRST MAIN ;Now go reenter main loop. + + +SUBTTL Command Tables + +COMTAB: + +DEFINE CMD NAME,LOC,HELP/ +IFNB [HELP] TMPLOC HLPTAB+.-COMTAB, [ASCIZ\HELP\] + LOC,,[ASCIZ\NAME\] +TERMIN +IF1 HLPTAB==0 ;loc of HLPTAB not known until size of COMTAB known + + CMD ?,AHELP + CMD NCP,DONCP,Switch to NCP mode. + CMD TCP,DOTCP,Switch to TCP mode. + CMD ACCT,AACCT,Send Account Name + CMD ALLOCATE,AALLOC,Give Size of File to be STOREd + CMD APPEND,AAPPE,Append Local File to Foreign File + CMD ASCII,ATEXT,Transfer File as ASCII Text (TYPE A, BYTE 8) + CMD BYE,ABYE,Disconnect, Giving Server Warning + CMD BYTE,ABYTE,Set Byte Size + CMD CONNECT,ACONN,Connect to Host + CMD CWD,ACWD,Change Foreign Working Directory + CMD DBGET,ADBGET,Debugging get file + CMD DBPUT,ADBPUT,Debugging put file + CMD DEBUG,ADBUG,Toggle Whether to Print Server Replies + CMD DEFAULTS,ADEFA,Set Local Filename Defaults + CMD DELETE,ADELE,Delete File + CMD DIRECTORY,ALSTF,List Foreign File Directory + CMD DISCONNECT,ADISC,Disconnect from Host + CMD DISOWN,ADISOW,Run disowned + CMD ESCRIPT,AESCRIP,Close Script File + CMD GET,AGET,Get File from Foreign Host + CMD HELP,AHELP,List Commands and What They Do + CMD HOSTS,AHSTS,List Hosts + CMD ICPSOCKET,AICPS,Set ICP Socket Number + CMD LISTB,ALSTB,List Foreign Directory Briefly (filenames only) + CMD LISTF,ALSTF,List Foreign File Directory + CMD LISTL,ALSTL,List Local File Directory + CMD LOGIN,ALOGIN,Login to Foreign Host + CMD PASS,APASS,Send Password + CMD PRINT,APRIN,Print File on ML TPL + CMD PROCEED,APROCD,Run without the TTY + CMD PUT,APUT,Put File onto Foreign Host + CMD Q,AQUIT,Leave FTP + CMD QUIT,AQUIT,Leave FTP + CMD QUOTE,AQUOT,Send Arbitrary Command to Server + CMD RENAME,ARENAM,Rename a File at Foreign Host + CMD RETRIEVE,AGET,Get File from Foreign Host + CMD SCRIPT,ASCRIP,Open Script File (gets all typeout) + CMD SEND,APUT,Put File onto Foreign Host + CMD SILENT,ASILNT,Stop typing on the TTY + CMD SOAK,ASOAK,Wait for and Print One Reply From Server + CMD STATUS,ASTAT,Print Server Status + CMD STORE,APUT,Put File onto Foreign Host + CMD TEN,ATEN,Transfer File in Most Efficient Mode (If Both Hosts PDP10s) + CMD TEXT,ATEXT,Transfer File as ASCII Text (TYPE A, BYTE 8) + CMD TRANSFER,ATRAN,Transfer host1filespec_host2filespec + CMD TYPE,ATYPE,Specify Type of Transfer + CMD VALRET,AVALR,Return to superior, not suicidally + CMD XFILE,AXFILE,Read Commands From File + +COMTBL==.-COMTAB + +IF1 EXPUNGE HLPTAB +HLPTAB: BLOCK COMTBL + +SUBTTL Routines called by NETWRK + +;PUTCHR Routine. Writes character from T, clobbers no ACs, never skips. +;Called by NETWRK's error analysis routine ANALYZE. +PUTCHR: + +;Output to script file if any. +;Output to TTY unless have both com file and script file. +TYO: SKIPE SCRIPT ;Write to script file if we have one. + SKIPE READIN ; Except inside TYILIN. + CAIA + .IOT SCRIPC,T + SKIPE SILENT + POPJ P, + SKIPN SCRIPT + SKIPE TYOTTY + CAIA + JRST DIE ;Nothing to type out on??? + SKIPE COMFIL + SKIPN SCRIPT + SKIPN TYOTTY + POPJ P, + .IOT TYOC,T ;Type on TTY if we can + POPJ P, ;unless we have an XFILE and a script. + +;IO UUOs on channel "TYOC" XCT UUOTYO for each char. +UUOTYO: PUSH P,T + MOVE T,U1 + PUSHJ P,TYO + POP P,T + POPJ P, + +;Call "HSTLOOK to translate asciz string <- A into a host number. +;Then set bit 4.9 in A if the host is a PDP10. +NHOSTN: PUSHJ P,NETWRK"HSTLOOK + POPJ P, + MOVE B,A ;Host number in B + PUSHJ P,NETWRK"HSTSRC ;Get SITES table entry addr in D. + JRST [ MOVE A,B ? JRST POPJ1] + MOVE A,B + HLRZ T,NETWRK"STLSYS(D) ;Find host's operating system. + ADD T,NETWRK"HSTADR ;If we guess it's a PDP10, + MOVE T,(T) ; we will be able to use 36 bit mode. + MOVSI TT,-NTENS +NHOST1: CAMN T,TENS(TT) + TLO A,400000 ;Set bit 4.9 in A if machine is a PDP10. + AOBJN TT,NHOST1 + JRST POPJ1 + +;;; Well-known PDP-10 operating systems (machine types are too varied). + +TENS: ASCII /ITS/ ;Incompatible Timesharing System + ASCII /WAITS/ ;Wise-assed incompatible timesharing system + ASCII /TOPS1/ ;TOPS-10 + ASCII /TOPS2/ ;TOPS-20 + ASCII /TENEX/ ;BBN TENEX + ASCII /FOONE/ ;Foonly + ASCII /AUGUS/ ;Foonly + ASCII /TYCOM/ ;Foonly +NTENS==.-TENS + + +INCHR: ILDB T,JCLP ;Get next JCL char or 0 if exhausted. + JUMPN T,CPOPJ + ;If exhausted, read in another line and return its 1st char. + PUSHJ P,TYILIN + JRST INCHR + + + +;Read an argument from the terminal. If there is any of a previous line left, +;we use that; otherwise we read a new line, prompting first. The call should +;be followed by a pointer to the prompt string. Leading and trailing spaces +;are discarded, as is the CR at the end. +;On return, A points at ARGCT, which looks like a string var containing the +;argument, which is an ASCIZ string in ARGBUF. +ARGCON: PUSHJ P,CONTST ;Read arg, but first establish connection if nec. +ARG: SETZM TRANFL' + CAIA +ARGTRN: SETOM TRANFL ;Here to read arg for TRAN command - + ;Stop on = or _ or . + SETZM SPCFL' + CAIA +ARGSPC: SETOM SPCFL ;Here to read an arg that a space can terminate. + PUSH P,B + PUSH P,T + MOVE B,JCLP ;Is there any input already? + ILDB B,B + MOVE T,@-2(P) + SKIPN B + OUTZ TYOC,(T) ;If not, prompt the user for some. + MOVE B,[440700,,ARGBUF] + MOVEM B,ARGPT + SETZM ARGCT +ARG1: PUSHJ P,INCHR + CAIN T,40 + JRST ARG1 +ARGLP: CAIN T,^M + JRST ARGFIN + CAIN T,^C + SETOM SUICID + CAIE T,^C ;Can appear in JCL, not snarfed by TYILIN. + CAIN T,^N + JRST ARGFIN + CAIN T,40 ;In ARGSPC, space terminates once arg is non-null. + SKIPN SPCFL + CAIA + JRST ARGFIN + SKIPN TRANFL ;In TRAN, filenames are terminated by _ or = or  + JRST ARGNRM + CAIE T,"= ;so we must be able to ^Q those characters. + CAIN T,"_ + JRST ARGFIN + CAIN T," + JRST ARGFIN + CAIN T,^Q + JRST ARGCTQ +ARGNRM: IDPB T,B + AOS ARGCT + PUSHJ P,INCHR + JRST ARGLP + +ARGCTQ: IDPB T,B ;Here for "^Q - put it in the string, then don't + ; look for _ or  or = in next char. + AOS ARGCT + PUSHJ P,INCHR + CAIE T,"= ;^Q followed by a _, , = or ^Q => + CAIN T,"_ ; store the quoted character only. + JRST ARGNRM + CAIN T," + JRST ARGNRM + CAIN T,^Q + JRST ARGNRM + CAIN T,^M ;CR isn't suppressed by ^Q. + JRST ARGFIN + PUSH P,T ;^Q followed by anything else. + ;Store both the ^Q and it. + MOVEI T,^Q + IDPB T,B + AOS ARGCT + POP P,T + JRST ARGNRM + +ARGFIN: LDB T,B ;Here for a CR "( or _ or  or = in TRAN command), + CAIE T,40 ; to end the arg. + JRST ARGFI2 ;Flush trailing spaces. + D7BPT B + SOS ARGCT + JRST ARGFIN + +ARGFI2: SETZ T, ;Make sure the arg is an ASCIZ string. + IDPB T,B + POP P,T + POP P,B + MOVEI A,ARGCT ;Return a pointer to a string var + ; containing our stuff. + JRST POPJ1 + +;Throw away rest of line if already read, but if no buffered input don't read any. +FLSLIN: PUSH P,T + MOVE T,JCLP ;If last char read was "EOL", + ;we have nothing to flush. + LDB T,T + CAIE T,^M ;This happens when you type, + ;eg, PROCEED with no space. + CAIN T,^N + JRST POPTJ + CAIN T,^C + JRST POPTJ +FLSLI1: PUSHJ P,INCHR + CAIN T,^C + SETOM SUICID + CAIN T,^N + JRST POPTJ + CAIE T,^M + CAIN T,^C + JRST POPTJ + JRST FLSLI1 + +SUBTTL Connect/Disconnect commands + +;CONNECT command. +ACONN: PUSHJ P,ARG + [ASCIZ /host: /] + MOVEI A,ARGBUF + PUSHJ P,NHOSTN + JRST ERRHST + JRST CONN + +;Connect to host specified in bits 4.8-1.1 of A. +;For NCP, sign(A) should be 1 to try to use image mode. +;For TCP, we only know how to do ASCII for now. + +CONN: JUMPE A,ERRHST ;Meaningless host name. + PUSH P,A + PUSHJ P,BYE ;Flush any existing connection. + JFCL + POP P,A ;A has host number. + SETZM DCTYPE ;Start out assuming ASCII mode + MOVEI B,8. + MOVEM B,DCBYTE ;8-bit bytes. + SETOM DCSENT ;And we are probably content with that too. + TLZE A,(SETZ) ;If it's a PDP10, try to use 36-bit Image. + JRST [ SETZM DCSENT + SKIPE JCLTRN + JRST .+1 ;No message if doing JCL tran command + FWRITE TYOC,[[Will use 36-bit image transfer (TEXT command gives 8-bit ascii mode)],CRLF,,] + JRST .+1 ] + TLNN F,%LTCP + JRST NCPCON ; Dispatch for NCP/TCP processing + +TCPCON: MOVEM A,FDHST ;Remember foreign host number. + MOVE B,FDHST + MOVEI A,NETI + MOVE C,ICPSOC + PUSHJ P,NETWRK"TCPCON + JRST NETERR + SETOM CNECTD ;We are now connected sompleace. + JRST ACONN1 + +NCPCON: MOVE B,A ;Host # + MOVEM B,FDHST + MOVEI A,ICPCH ;Pin # + MOVE C,ICPSOC ;Foreign socket + MOVEI T,FTPSKT + MOVEM T,ICPSOC + MOVE D,[40+.UAI,,40+.UAO] ;Modes + PUSHJ P,NETWRK"ARPICP ;Connect it up + JRST NETERR ;Failed => return error message. + SETOM CNECTD + SYSCAL RCHST,[MOVEI NETI + MOVEM JUNK ;NET + MOVEM LDSOC ;Local socket + MOVEM FDSOC ] ;Foreign socket + .LOSE 1000 + MOVEI A,2 + ADDM A,LDSOC ;Relocate to data socket base + AOS FDSOC +ACONN1: OUTOPN NETO, ;Prepare for using output UUOs on NETO. + MOVEI A,300. ;Expect 300 Initial Greeting + TLNE F,%LTCP ;If using TCP + MOVEI A,220. ; the greeting is 220. + PUSHJ P,REPLY ;Get reply, skip if winning + JRST ERDISC ;Reply says connection no good => disconnect. + PUSHJ P,REPDIS ;Print the text of the greeting message. + JRST POPJ1 + +ERDISC: PUSHJ P,DISC + JFCL + JRST ERRTR1 + +ADISC: +ABYE: PUSHJ P,FLSLIN ;BYE command. No-op if we have no server. +BYE: PUSHJ P,STILOPN + PUSHJ P,GRATU ;Check for gratuitous reply from server. + SKIPN CNECTD + JRST POPJ1 + OUTZ NETO,[ASCIZ /QUIT +/] + MOVEI A,221. ;Wait for acknowledgement, then disconnect. + PUSHJ P,REPLY + JFCL ;You don't want to disconnect? + ;Too bad! We will anyway. +DISC: SKIPN CNECTD ;Disconnect. No-op if not connected. + JRST POPJ1 + SETZM CNECTD + .CLOSE NETO, + .CLOSE NETI, + JRST POPJ1 + +SUBTTL A few simple commands + +AHELP: PUSHJ P,FLSLIN + MOVSI A,-COMTBL +AHELP1: SKIPN HLPTAB(A) + JRST AHELP2 + FWRITE TYOC,[CRLF,,TZ$,COMTAB(A),TI,^I,TZ$,HLPTAB(A)] +AHELP2: AOBJN A,AHELP1 + OUTZ TYOC,[ASCIZ\ +You may also give just a host name or number if not already connected. + +Terminate input with CR or LF. Use rubout to delete last character typed. +Commands and Host names may be abbreviated (if the abbreviation is +unambiguous). +\] + JRST POPJ1 + +AHSTS: PUSHJ P,FLSLIN ;HOSTS command - list all hosts. (Arpanet only) + MOVE A,NETWRK"HSTADR + MOVE B,NETWRK"NAMPTR(A) + ADD B,A ;Get addr of HOSTS3 file NAMES table. + MOVE C,(B) ;C gets number of entries. + MOVE D,1(B) ;D gets words per entry + ADDI B,2 ;B -> first entry +AHSTS1: HLRZ A,NETWRK"NMLSIT(B) + ADD A,NETWRK"HSTADR ;A gets addr of SITES table entry for this host. + HLRZ TT,NETWRK"STLNAM(A) ;Get relative address of the official name + HRRZ T,NETWRK"NMRNAM(B) ;Get relative address of this name + CAME T,TT + JRST AHSTS2 ;Don't mention nicknames + HLRZ TT,NETWRK"STLSYS(A) + ADD TT,NETWRK"HSTADR ;A gets addr of string containing type of system + MOVE TT,(TT) + CAME TT,[ASCIZ /TIP/] ;Dont mention TIPs. Can't FTP to them. + SKIPL NETWRK"STLFLG(A) ;Only mention servers + JRST AHSTS2 + HRRZ A,NETWRK"STRADR(A) ;See if this guy is on Internet +AHSTS3: ADD A,NETWRK"HSTADR + MOVE TT,NETWRK"ADDADR(A) + TLNN TT,(NETWRK"NE%UNT) ; Skip if not an internet address. + JRST AHSTS4 + HRRZ A,NETWRK"ADRCDR(A) + JUMPN A,AHSTS3 + JRST AHSTS2 + +AHSTS4: ADD T,NETWRK"HSTADR + FWRITE TYOC,[TZ$,T,CRLF,,] +AHSTS2: ADD B,D ;B -> next entry + SOJG C,AHSTS1 + JRST POPJ1 + +AQUOT: PUSHJ P,ARGCON + [ASCIZ /FTP protocol command to give to server: /] + JRST SNDARG + +ASTAT: PUSHJ P,ARGCON + [ASCIZ /Server-dependent status-type: /] + OUTZ NETO,[ASCIZ /STAT/] + HRRZ D,(A) ;Get length of arg. + SKIPE D ;If user said anything, + OUTZ NETO,[ASCIZ / /] ;delimit cmd and arg. + JRST SNDARG + +AICPS: PUSHJ P,ARG + [ASCIZ /Socket number: /] + PUSHJ P,RDOCT + MOVEM A,ICPSOC + JRST POPJ1 + +ASOAK: PUSHJ P,FLSLIN +ASOAK0: SETO A, ;Read in and print one reply from server. + PUSH P,PRREP + SETOM PRREP + PUSHJ P,REPLY + JFCL + POP P,PRREP + JRST POPJ1 + +ADBUG: PUSHJ P,FLSLIN + SETCMM PRREP ;DEBUG - complement printing of server replies. + SKIPN PRREP + OUTZ TYOC,[ASCIZ\not \] + OUTZ TYOC,[ASCIZ\printing server replies.\] + CRLF TYOC, + JRST POPJ1 + +DONCP: PUSHJ P,ABYE ;Can't change mode with conns open. + JFCL + OUTZ TYOC,[ASCIZ /Switching to NCP mode, which probably do anything good./] + CRLF TYOC, + TLZ F,%LTCP ;Say not doing TCP. + MOVEI A,FTPSKT ;NCP means this is the ICP socket + MOVEM A,ICPSOC ;Remember which port or socket to use. + MOVE A,[NETWRK"NW%ARP] ;Get own host number, on Arpanet + PUSHJ P,NETWRK"OWNHST + .LOSE ;Not connected to Arpanet? + MOVEM A,OWNHST + JRST POPJ1 + + +DOTCP: PUSHJ P,ABYE ;Can't change mode with conns open. + JFCL + OUTZ TYOC,[ASCIZ /Switching to TCP mode./] + CRLF TYOC, + TLO F,%LTCP ;Say doing TCP. + MOVEI A,FTPORT ;TCP means we use this port. + MOVEM A,ICPSOC ;Remember which port or socket to use. + MOVE A,[SQUOZE 0,/IMPUS3/] + .EVAL A, ;If TCP, need the HOSTS3 format address instead. + .LOSE %LSSYS + MOVEM A,OWNHST + JRST POPJ1 + + +AQUIT: PUSHJ P,FLSLIN +QUIT: PUSHJ P,BYE + JFCL +DIE: .CLOSE SCRIPC, + SKIPE DEBUG + .VALUE + .LOGOUT 1, + +AVALR: PUSHJ P,FLSLIN ;Flush typed-ahead commands. + .BREAK 16,100000 ;Return to superior. Can be $P'd or $G'd. + JRST POPJ1 + +APROCD: SKIPA C,[[ASCIZ //]] ;Proceed command. +ADISOW: MOVEI C,[ASCIZ /  /];Disown command - disown self, keep running. + PUSHJ P,FLSLIN + MOVE A,JCLP + ILDB A,A ;If have input already buffered, it might + ;contain an XFILE and SCRIPT, so we can't be + JUMPN A,ADISO1 ;sure user is losing. + SKIPN TRITTY ;If TTY input is translated, + SKIPE COMFIL ;or redirected with an XFILE, then input is OK. + CAIA + JRST ADISO2 + SKIPN TROTTY ;If TTY output is translated + SKIPE SCRIPT ; or redirected with a SCRIPT, + CAIA ; OK. +ADISO2: JRST [ OUTZ TYOC,[ASCIZ /Can't DISOWN or PROCEED if using the TTY +/] + JRST ERRTR1] +ADISO1: SKIPE DEBUG + .VALUE + .VALUE (C) + SKIPN TROTTY ;If TTY output isn't translated, + SETOM SILENT ; we mustn't use it any more. + JRST POPJ1 + +ASILNT: PUSHJ P,FLSLIN + SETOM SILENT + JRST POPJ1 + +ALOGIN: PUSHJ P,ARGCON + [ASCIZ /as User name: /] + OUTZ NETO,[ASCIZ /USER /] ;Send the command name. + JRST SNDARG ;Send the arg, handle reply. + +APASS: PUSHJ P,ARGCON + [ASCIZ/password: /] + OUTZ NETO,[ASCIZ /PASS /] +SNDARG: FWRITE NETO,[TZ,ARGBUF,CRLF,,] + MOVEI A,200. + JRST REPLY + +AACCT: PUSHJ P,ARGCON + [ASCIZ /account number to log in under: /] + OUTZ NETO,[ASCIZ /ACCT /] ;Send the command name. + JRST SNDARG ;Send the arg, handle reply. + +ACWD: PUSHJ P,ARGCON + [ASCIZ/to Directory: /] + OUTZ NETO,[ASCIZ /CWD /] ;Send the command name. + JRST SNDARG ;Send the arg, handle reply. + +ADEFA: PUSHJ P,ARG ;DEFAULTS - just set local filename. + [ASCIZ /filename defaults: /] + MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR + JRST POPJ1 + +AALLOC: PUSHJ P,ARGCON ;ALLOC - send size for file to be STOREd. + [ASCIZ /# bytes: /] + OUTZ NETO,[ASCIZ /ALLO /] + JRST SNDARG + +;Delete command. +ADELE: PUSHJ P,ARGCON + [ASCIZ /file: /] + OUTZ NETO,[ASCIZ /DELE /] + JRST SNDARG + +;Rename command. +ARENAM: PUSHJ P,ARGCON + [ASCIZ /old file: /] + FWRITE NETO,[[RNFR ],TZ,ARGBUF,CRLF,,] ;Send the old name. + MOVEI A,350. + PUSHJ P,REPLY ;Wait for acceptance. + POPJ P, + PUSHJ P,ARG + [ASCIZ /to new name: /] + FWRITE NETO,[[RNTO ],TZ,ARGBUF,CRLF,,] + MOVEI A,250. + JRST REPLY + +;PRINT command - print file on ML's TPL. +APRIN: MOVE B,FDHST + CAIN B,306 + SKIPN CNECTD + CAIA + JRST APRIN2 + MOVE A,[SETZ 306] + PUSHJ P,CONN ;First connect to ML (if not already connected). + POPJ P, +APRIN2: PUSHJ P,ARG ;Then ask for and open the disk file. + [ASCIZ/local file: /] + MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR + PUSHJ P,DCSEND ;Tell ML to use image mode. + SKIPLE TT,DCTYPE + SETO TT, ; Assume local-byte means image. + SYSCAL OPEN,[ (TT)1+[.BII,,DC ? .UAI,,DC] + FILDEV ? FILFN1 ? FILFN2 ? FILDIR ] + JRST FILERR + PUSHJ P,NETWLS + OUTZ NETO,[ASCIZ /STOR TPL: +/] + JRST APRIN1 ;Then go do a PUT to TPL:. + +SUBTTL Connection Checking + +;Commands that need to be connected before they can work call here +;If we aren't connected to a server, ask user which host and try to connect now. + +CONTST: SKIPN CNECTD ;If no connection, ask for host name. + JRST CONTS1 + PUSHJ P,STILOPN ;If have a server, check that it's really there. + SKIPE CNECTD ;If it is, we win. + POPJ P, ;Otherwise, ask for host to connect to. + SKIPE TYITTY ;In this case, any type-ahead + .RESET TYIC, ;must be intended for something else. +CONTS1: PUSHAE P,[A,JCLBFP,JCLP] ;? ******* + MOVE A,[440700,,JCLBF2] ;Read host name using alternate buffer. + MOVEM A,JCLBFP + MOVEM A,JCLP + SETZM JCLBF2 + PUSHJ P,ACONN + JRST ERRTR1 + POPAE P,[JCLP,JCLBFP,A] + POPJ P, + + +SUBTTL Error Handling + +;Handle File Error +FILERR: .OPEN ERRC,[.UAI,,'ERR ? 1] + .VALUE +FILER1: .IOT ERRC,TT + CAIL TT,40 + JRST [ OUTI TYOC,(TT) ? JRST FILER1 ] + FWRITE TYOC,[[ - ],6F,FILDEV,[: ],6F,FILDIR,[; ],6F,FILFN1,[ ],6F,FILFN2,CRLF,,] + JRST ERRTR1 + +NOTTY: OUTZ TYOC,[ASCIZ /No TTY or Script file to read from +/] + JRST QUIT + +;Here for error making data connection. We need to reset. +DCBORE: OUT(TYOC,("Timed out waiting for server to make data connection."),EOL) + JRST NETCLS + +;Here for error making data connection. A server reply is expected +;and should be soaked up. +DCNERR: .LOGOUT 0, + PUSHJ P,NETWRK"ANALYZ + .VALUE + CRLF TYOC, + PUSHJ P,STILOPN + SKIPE CNECTD + PUSHJ P,ASOAK0 + JFCL + JRST NETCLS + +;Here is call to CONNEC or ICP loses. +NTERDI: MOVEI A,NETDI +NETERR: .LOGOUT 0, ;Die if no one to complain to. + PUSHJ P,NETWRK"ANALYZ ;Else print an error message. + .VALUE ; Sigh? + CRLF TYOC, + PUSHJ P,STILOPN ;See if TELNET connection seems to be closed. + +;Here if lose inside GET or PUT. Close the files. +NETCLS: .CLOSE NETDO, + .CLOSE DC, + .CLOSE NETDI, + JRST ERRTR1 ;Go fix up stuff and safely restart main loop. + + +;Do nothing if we are not supposedly connected, or if we really +;are still connected. If supposedly connected but connection +;broken, make it official and tell the user. + +STILOPN:SKIPN CNECTD ;Do nothing if we know there's no connection. + POPJ P, + SYSCAL WHYINT,[%CLIMM,,NETI ? %CLOUT,,A ? %CLOUT,,B] + JRST STILLS ;If channel is closed + ANDI B,-1 ;or socket state is closed + JUMPN B,CPOPJ ; then connection is broken. +STILLS: PUSHJ P,DISC ;So close channels, zero CNECTD, etc. + JFCL + OUTZ TYOC,[ASCIZ /Connection to Server has broken. +/] + POPJ P, + +;If there is gratuitous input from the server, say so +GRATU: SKIPN CNECTD + POPJ P, + PUSHAE P,[A,B,C] + SYSCAL WHYINT,[%CLIMM,,NETI ? MOVEM A ? MOVEM B ? MOVEM C ] + JRST GRATU9 + CAIN A,%WYNET + CAIG C,0 ;Have any input? + JRST GRATU9 + OUTZ TYOC,[ASCIZ/ +Note: gratuitous response from server: +/] +GRATU1: .IOT NETI,A + .IOT TYOC,A + SOJG C,GRATU1 + CRLF TYOC, +GRATU9: POPAE P,[C,B,A] + POPJ P, + +;Give final bullshit about bits per second +FRATE: SKIPE JCLTRN + JRST QUIT ;Skip this printout for implicit TRAN's from DDT. + SKIPN SCRIPT ;If we are disowned with no file to write in, + SKIPE TROTTY ;log out now rather than hanging up. + CAIA + .LOGOUT + .RDTIME T, + SUB T,NTIME + PUSH P,T + IMULI T,100. + IDIVI T,30. ;Time in hundredths of a second. + IDIVI T,100. ;T has time in seconds, TT has extra hundredths. + FWRITE TYOC,[N9,NBITS,[ bits in ],N10,T,N9,TT,[ seconds (]] + POP P,T + FSC T,233 + FDVRI T,(30.0) + MOVE A,NBITS + FSC A,233 + FDVRI A,(1000.0) ;kilobits + FDVR A,T + FWRITE TYOC,[NFL,A,[ kbps).],CRLF,,] + POPJ P, + + +SUBTTL NCP data transfer commands + +AAPPE: TLNE F,%LTCP + JRST ERRCTX + PUSHJ P,APUT1 + MOVEI A,[ASCIZ/APPE /] + JRST APUT2 + +APUT: TLNE F,%LTCP + JRST PUTTCP ;TCP is different. + PUSHJ P,APUT1 + MOVEI A,[ASCIZ /STOR /] +APUT2: PUSH P,A + PUSHJ P,ARG + [ASCIZ/to foreign file: /] + PUSHJ P,NETWLS + POP P,B + FWRITE NETO,[TZ,(B),TS,(A),CRLF,,] +APRIN1: PUSHJ P,SOCK ;Look for 255 SOCK mumble + JRST NETCLS + MOVEI A,NETDO + PUSHJ P,NETWRK"CONFIN + JRST DCNERR ;lossage + .NETAC NETDO, + JRST DCNERR ;lossage + MOVEI A,250. ;Look for 250 socket to me + TLNE F,%LTCP + MOVEI A,125. + PUSHJ P,REPLY + JRST NETCLS ;lossage + PUSHJ P,REPDIS ;tell user transfer started successfully + SETZM NBITS + .RDTIME TT, + MOVEM TT,NTIME + MOVEI A,DC + MOVEI B,NETDO + SETOM XFRDIR + PUSHJ P,XFR ;Do the transfer (looks at the transfer mode). + SYSCAL FINISH,[MOVEI NETDO] + JFCL + .CLOSE NETDO, + MOVEI A,252. ;look for 252 finis + TLNE F,%LTCP + MOVEI A,226. + PUSHJ P,REPLY + JRST NETCLS ;lossage + PUSHJ P,FRATE + JRST POPJ1 ;winnage + +;Do a listen on the output data socket. +NETWLS: PUSH P,A + SKIPE DCTYPE ;Ascii? + JRST NETWL1 ;Image. + MOVEI D,160+.UAO + MOVE A,DCBYTE + CAIN A,8 + JRST NETWL2 + FWRITE TYOC,[[Byte size ],N9,A,[ illegal with TYPE A; use BYTE 8],CRLF,,] + JRST ERRTR1 + +NETWL1: MOVE A,DCBYTE + MOVEI D,44160+.BIO + CAIN A,36. + JRST NETWL2 + PUSHJ P,BSETUP + IORI D,160+.UIO +NETWL2: MOVEI A,NETDO ;Listen data connection + MOVE B,FDHST + HRLI D,400000 + PUSHJ P,NETWRK"ARPCON + JRST NETERR ;lossage + POP P,A + POPJ P, + +;Set up for doing image-mode transfer with strange byte size +BSETUP: CAIL A,1 + CAILE A,36. + JRST [ FWRITE TYOC,[[Byte size ],N9,A,[ illegal with TYPE I, not between 1 and 36],CRLF,,] + JRST ERRTR1 ] + MOVE D,A + MOVEI A,36. + IDIV A,D + FWRITE TYOC,[[Will transfer ],N9,DCBYTE,[-bit bytes packed ],N9,A,[ per pdp-10 word, left-justified.],CRLF,,] + LSH D,9 + POPJ P, + +APUT1: PUSHJ P,CONTST ;Make sure we have a server set up. + PUSHJ P,DCSEND ;Make sure server knows about data type etc. + PUSHJ P,ARG + [ASCIZ/local file: /] + MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR + SKIPLE TT,DCTYPE + JRST [ MOVE TT,DCBYTE ; If logical-byte being used, + CAIE TT,36. ; Then if not 36-bit bytes + TDZA TT,TT ; we must use unit-mode for SIOT + SETO TT, ; otherwise hack block image for 36-bit xfers + JRST .+1] + SYSCAL OPEN,[ (TT)1+[.BII,,DC ? .UAI,,DC] + FILDEV ? FILFN1 ? FILFN2 ? FILDIR ] + JRST FILERR + POPJ P, + +;Debugging version of PUT. +ADBPUT: TLNE F,%LTCP + JRST ERRCTX + PUSHJ P,APUT1 + PUSHJ P,ARG + [ASCIZ/protocol command: /] + PUSHJ P,NETWLS + FWRITE NETO,[TZ,ARGBUF,CRLF,,] + JRST APRIN1 + + +;PUT command for TCP +PUTTCP: PUSHJ P,CONTST ;Make sure we have a server set up. + PUSHJ P,DCSEND ;Make sure server knows about data type etc. + PUSHJ P,ARG + [ASCIZ/From local file: /] + MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR ;Read desired source file name. + SKIPLE TT,DCTYPE + JRST [ MOVE TT,DCBYTE ; If logical-byte being used, + CAIE TT,36. ; Then if not 36-bit bytes + TDZA TT,TT ; we must use unit-mode for SIOT + SETO TT, ; otherwise hack block image for 36-bit xfers + JRST .+1] + SYSCAL OPEN,[(TT)1+[.BII,,DC ? .UAI,,DC] + FILDEV ? FILFN1 ? FILFN2 ? FILDIR] + JRST FILERR ;Eh? cant open source file? + PUSHJ P,ARG + [ASCIZ/to foreign file: /] + PUSHJ P,TCPLSN ;Do a listen on the data socket. + FWRITE NETO,[[STOR ],TS,(A),CRLF,,] + .NETS NETO, ;Send the transfer command. + PUSHJ P,TCPWRI ;Transfer the file. + PUSHJ P,FRATE ;Print out statistics. + JRST POPJ1 + + +;Send file over data socket (for TCP). + +;This routine assumes we are listening for a data connection, and that +;we have given the storage command. Waits for the server to connect to +;us, and writes the file from channel DC to channel NETDO. + +TCPWRI: PUSH P,A + PUSH P,B + MOVEI A,125. ;Make sure he is ready to send receive it. + PUSHJ P,REPLY ;This should be a "Socket to me". + JRST NETCLS + MOVEI A,%NSLSN ;Initial state to hang on. + MOVEI T,TIMOUT +TCPWR0: JUMPE T,DCBORE + SYSCAL NETBLK,[%CLIMM,,NETDO ? A ? T ? %CLOUT,,A ? %CLOUT,,TT] + JRST DCNERR + MOVE T,TT + CAIN A,%NSRFC ; If in SYN-RECEIVED state + JRST TCPWR0 ; then it's OK to keep waiting. + CAIE A,%NSOPN ; Else should be open now. + CAIN A,%NSRFN + CAIA + JRST TCPWR0 + PUSHJ P,REPDIS ;Tell user transfer started successfully. + SETZM NBITS + .RDTIME TT, + MOVEM TT,NTIME + SETOM XFRDIR ; Outputting to network + MOVEI A,DC ;Source file open on this channel. + MOVEI B,NETDO ;Data connection open on this channel. + PUSHJ P,XFR ;Do the transfer. +TCPWR9: .CLOSE DC, ;Close file. + SYSCAL FINISH,[MOVEI NETDO] + JFCL + .CLOSE NETDO, ;Close data socket. + .CLOSE NETDI, ; Close unused reverse direction channel + MOVEI A,226. ;Look for 226 Finis reply. + PUSHJ P,REPLY + JRST NETCLS + POP P,B + POP P,A + POPJ P, + +;GET command +AGET: PUSHJ P,CONTST ;Make sure we have a server set up. + PUSHJ P,DCSEND ;Make sure server knows about data type etc. + PUSHJ P,ARG + [ASCIZ/from foreign file: /] + MOVE A,[ARGBUF,,ALTARG] + BLT A,ALTARG+JCLBFL-1 ;Save it away. + PUSHJ P,ARG + [ASCIZ/into local file: /] + MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR ;Read desired local name. + SKIPLE TT,DCTYPE + JRST [ MOVE TT,DCBYTE ; If logical-byte being used, + CAIE TT,36. ; Then if not 36-bit bytes + TDZA TT,TT ; we must use unit-mode for SIOT + SETO TT, ; otherwise hack block image for 36-bit xfers + JRST .+1] + SYSCAL OPEN,[(TT)1+[.BIO,,DC ? .UAO,,DC] + FILDEV ? FTPOF1 ? FTPOF2 ? FILDIR] + JRST FILERR ;Eh? cant open temporary output file? + PUSHJ P,NETRLS ;Do a listen on the data socket. +ATRGET: FWRITE NETO,[[RETR ],TZ,ALTARG,CRLF,,] +ADBGT1: .NETS NETO, + MOVEI B,DC ;For GET, send output to Disk. + PUSHJ P,NETREAD ;Read the whole file and write it to DC. + MOVE B,FILDEV + CAMN B,[SIXBIT/TTY/] ;If outputting to the TTY + JRST AGET90 ; do not renaming. + SYSCAL RENMWO,[%CLIMM,,DC ? FILFN1 ? FILFN2] + JRST FILERR +AGET90: .CLOSE DC, ;Close file. + PUSHJ P,FRATE ;Print out statistics. + JRST POPJ1 + + +;Listen for data connection we want to receieve. + +;For NCP, do a listen on our input data socket. +;For TCP, use the PORT command for the "Quiet-Time" SYN hackery first. +;For both, we complete and accept the connection later. +;This routine returns always. + +NETRLS: PUSH P,A + PUSH P,B + TLNN F,%LTCP + JRST NCPRLS ;If NCP FTPing, things are not necessarily ASCII. +TCPRLS: PUSHJ P,TCPLSN ;Offer and listen for a data connection. + JRST RLSDUN ;We are ready for the transferring command. + +NCPRLS: SKIPE DCTYPE ;Ascii? + JRST NETRL1 ;Image or logical-byte + MOVEI D,160+.UAI ;THIS ROUTINE SMASHES D! + MOVE A,DCBYTE + CAIN A,8 + JRST NETRL2 + FWRITE TYOC,[[Byte size ],N9,A,[ illegal with TYPE A; use BYTE 8],CRLF,,] + JRST ERRTR1 +NETRL1: MOVE A,DCBYTE + MOVEI D,44160+.BII + CAIN A,36. + JRST NETRL2 + PUSHJ P,BSETUP + IORI D,160+.UII +NETRL2: MOVEI A,NETDI + MOVE B,FDHST + HRLI D,400000 + PUSHJ P,NETWRK"ARPCON + JRST NETERR ;lossage + +RLSDUN: POP P,B + POP P,A + POPJ P, + + + +SUBTTL TCP Listen for data connection + +;Start listening for a data connection from the foreign server on some port. +;When we have receieved the reply to the PORT command, return. + +TCPLSN: PUSH P,A + MOVE A,ICPSOC ;Take the FTP server port number. + SUBI A,1 ;Subtract one. + SYSCAL TCPOPN,[%CLBIT,,%NOLSN ;Say we want to listen. + %CLIMM,,NETDI ;Data Receive channel. + %CLIMM,,NETDO ;Data Transmit channel. + [-1] ;Gensym a local listening port + A ;Try this foreign port. + FDHST] ;Frn host to listen for. + JRST NTERDI + SYSCAL RFNAME,[ %CLIMM,,NETDI ? %CLOUT,,JUNK + %CLOUT,,LPORT] ;This port is where we are listening. + .LOSE %LSSYS + OUT(NETO,("PORT ")) ;Need to tell server where to connect to. + MOVSI TT,-4 ;There are four fields in the address. + MOVE T,[401000,,OWNHST] ;Each field is 8. bits long. +TCPLS1: ILDB A,T ;Get the field. + OUT(NETO,D(A),(",")) ;Print that part as a decimal number. + AOBJN TT,TCPLS1 ;Print the entire address this way. + MOVE T,[201000,,LPORT] ;Now we want the port number. + ILDB A,T ;Get high eight bits of the port number. + OUT(NETO,D(A),(",")) ;Print them. + ILDB A,T ;Get low eight bits of th port number. + OUT(NETO,D(A),EOL) ;Print them, and wrap up the command. + .NETS NETO, + PUSHJ P,SOCK ;Wait for a reply that we are winning. + JRST [ OUT(TYOC,("Negative reply to PORT command."),CRLF) + JRST NETCLS] + POP P,A + POPJ P, ;Return, ready for transferring command. + +SUBTTL Wait for 255 SOCK COMMAND. + +;Skip return on success. + +SOCK: PUSH P,A + PUSH P,B + PUSH P,C + MOVEI A,255. ;If NCP, look for 255 "SOCK mumble". + TLNE F,%LTCP ;If TCP, + MOVEI A,200. ; Look for 200 "PORT Ok". + PUSHJ P,REPLY + JRST [ POP P,C ? POP P,B ? POP P,A ? JRST CPOPJ ] + POP P,C + POP P,B + POP P,A + JRST POPJ1 + +;We used to store the argument to the SOCK reply into FDSOC; kludge,kludge. +IFN 0,[ MOVEI A,REPLYS + MOVEI B,40 + PUSHJ P,PRSWRD ;255 + MOVEI B,40 + PUSHJ P,PRSWRD ;SOCK + HRRZ C,(B) + CAIE C,4 + JRST SCKLOS + IRPC CH,,SOCK + ILDB C,1(B) + CAIE C,"CH + JRST SCKLOS + TERMIN + MOVEI B,0 ;Now get the decimal number +SOCK1: ILDB C,REPLYS+1 + CAIL C,"0 + CAILE C,"9 + JRST SOCK2 + IMULI B,10. + ADDI B,-"0(C) + JRST SOCK1 + +SOCK2: MOVEM B,FDSOC + POPJ P, +SCKLOS: OUTZ TYOC,[ASCIZ/Host did not send proper "255 SOCK nnnn" reply. +/] + JRST ERRTR1 +] ;End IFN 0. + + + +SUBTTL Read file over data socket + +;This routine assumes we are listening on NETDI for a data connection, +;and that we have given the retreival command. Waits for the server to +;connect to us, and writes the file to the channel in B. +;Closes the data connection when done, and returns. + +NETREAD:PUSH P,A ;Save an AC. + PUSH P,B ;Save channel to write to here. + TLNN F,%LTCP + JRST NETRE1 ;If NCP, go do ICP. + + MOVEI A,125. ;For TCP, wait for positive "Here Comes" + PUSHJ P,REPLY ;reply before doing the listen, + JRST NETCLS ; since the file might not be there. + MOVEI A,%NSLSN ; Initial state to hang on. + MOVEI T,TIMOUT +TCPRD0: JUMPE T,DCBORE + SYSCAL NETBLK,[%CLIMM,,NETDO ? A ? T ? %CLOUT,,A ? %CLOUT,,TT] + JRST DCNERR + MOVE T,TT ; Boredom sets in eventually. + CAIN A,%NSRFC ; If in SYN-RECEIVED state + JRST TCPRD0 ; then it's OK to keep waiting. + CAIE A,%NSOPN ; Else should be open now. + CAIN A,%NSRFN + CAIA + JRST TCPRD0 ;If not OPEN or RFNM, keep waiting. + JRST NETRE2 ;When connected, go read data. + + +NETRE1: PUSHJ P,SOCK ;NCP needs a 255 SOCK mumble. + JRST [ OUT(TYOC,("Unexpected reply, should have been SOCK."),EOL) + JRST NETCLS ] + MOVEI A,NETDI + PUSHJ P,NETWRK"CONFIN ;NCP needs messy ICP too! + JRST DCNERR ; lossage + .NETAC NETDI, ;Accept the connection we were listening for. + JRST DCNERR + MOVEI A,250. + TLNE F,%LTCP + MOVEI A,125. ;Look for 125. Here it comes. + PUSHJ P,REPLY + JRST NETCLS + +NETRE2: SETZM NBITS + .RDTIME TT, + MOVEM TT,NTIME + MOVEI A,NETDI + POP P,B ;Get back channel to write to (DC or TYOC). + SETZM XFRDIR + PUSHJ P,XFR ;Do the transfer (looks at DCTYPE, closes NETDI). + .CLOSE NETDO, ; TCP: make sure reverse chan closed too. + MOVEI A,252. ;If NCP, look for 252 "FINIS". + TLNE F,%LTCP ;If TCP, + MOVEI A,226. ; look for 226 "Transfer Complete". + PUSHJ P,REPLY + JRST [ OUT(TYOC,("Unexpected reply, should have been FINIS."),EOL) + JRST .+1 ] + POP P,A ;Pop saved ACs back off. (B already popped). + POPJ P, + +;Debugging version of GET. +ADBGET: TLNE F,%LTCP + JRST ERRCTX + PUSHJ P,CONTST + PUSHJ P,ARG + [ASCIZ/into local file: /] + MOVE B,[FILDEV,,FILDEV] ;Read desired local filename + PUSHJ P,FILPAR + MOVE TT,FILDEV ;Output to TTY means use text mode + CAMN TT,[SIXBIT/TTY/] + JRST [ SKIPE DCSENT ;If server knows that we are in image mode + SKIPN DCTYPE + JRST [SETOM DCSENT + JRST .+1 ] + PUSHJ P,ATEXT ;then tell it to use ascii + JFCL + JRST .+1 ] + PUSHJ P,DCSEND + SKIPLE TT,DCTYPE + JRST [ MOVE TT,DCBYTE ; If logical-byte being used, + CAIE TT,36. ; Then if not 36-bit bytes + TDZA TT,TT ; we must use unit-mode for SIOT + SETO TT, ; otherwise hack block image for 36-bit xfers + JRST .+1] + SYSCAL OPEN,[ (TT)1+[.BIO,,DC ? .UAO,,DC] + FILDEV ? FTPOF1 ? FTPOF2 ? FILDIR ] + JRST FILERR + PUSHJ P,ARG + [ASCIZ/protocol command: /] + PUSHJ P,NETRLS ;Do listen on data socket before sending the command. + FWRITE NETO,[TZ,ARGBUF,CRLF,,] + MOVE B,FILDEV ;Output to TTY is special case + CAME B,[SIXBIT/TTY/] + JRST ADBGT1 ;Go join regular GET command + .CLOSE DC, + MOVEI B,TYOC + PUSHJ P,NETREAD + JRST POPJ1 + + +SUBTTL TRAN Command + +ATRAN: MOVE B,JCLP + ILDB B,B + SKIPN B ;If there's no input on same line as TRAN, prompt. + OUTZ TYOC,[ASCIZ /to-hostfile = from-hostfile: +/] + PUSHJ P,THOSTN ;Read the To-host. + JRST ERRTR1 + LDB B,[4300,,A] ;All but sign + CAME B,OWNHST ;If to-host is us, this TRAN is a GET. + JRST ATRPUT + PUSHJ P,ARGTRN ;So read in the to-filenames, + [ASCIZ /To-filename: /] + MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR ;and parse them + PUSHJ P,THOSTN ;Read the From-host. + JRST ERRTR1 + LDB B,[4300,,A] ;All but sign + SKIPE CNECTD + CAME B,FDHST ;If not already connected to it, connect. + CAIA + JRST ATRGE1 + PUSHJ P,CONN + JRST ERRTR1 +ATRGE1: PUSHJ P,DCSEND + MOVEI A,ARGCT + MOVE B,JCLP + ILDB B,B + CAIN B,^M ;If the from-file is null, default to the to-file. + JRST [ PUSHJ P,FLSLIN ;READ PAST THE CR. + JRST ATRGE2] + MOVE C,ARGCT + PUSHJ P,ARG ;Else read the from-file. + [ASCIZ/from foreign file: /] + MOVE B,[FILDEV,,FILDEV] + SKIPN C ;If the to-file was null, default to from-file. + PUSHJ P,FILPAR +ATRGE2: SKIPLE TT,DCTYPE ;Now open the local (to-) file. + JRST [ MOVE TT,DCBYTE ; If logical-byte being used, + CAIE TT,36. ; Then if not 36-bit bytes + TDZA TT,TT ; we must use unit-mode for SIOT + SETO TT, ; otherwise hack block image for 36-bit xfers + JRST .+1] + SYSCAL OPEN,[ (TT)1+[.BIO,,DC ? .UAO,,DC] + FILDEV ? FTPOF1 ? FTPOF2 ? FILDIR ] + JRST FILERR + FWRITE NETO,[[RETR ],TS,(A),CRLF,,] + + +ATRPUT: SKIPE CNECTD ;Here if to-host isn't us. This TRAN is a PUT. + CAME B,FDHST ;If not already connected to it, connect. + CAIA + JRST ATRPU1 + PUSHJ P,CONN + JRST ERRTR1 +ATRPU1: PUSHJ P,DCSEND ;If it's a PDP10, switch to TYPE I BYTE 36. + PUSHJ P,ARGTRN ;Read in the To-filename. + [ASCIZ /to foreign file: /] + MOVE A,[ARGBUF,,ALTARG] + BLT A,ALTARG+JCLBFL-1 ;Save it away. + ;Will send after we read rest of command. + PUSHJ P,THOSTN ;Read the From-host. + JRST ERRTR1 + LDB B,[4300,,A] ;All but sign + CAME B,OWNHST ;It must be us, if this is to be a PUT. + JRST [ OUTZ TYOC,[ASCIZ /TRAN must be either to or from the local host. +/] + JRST ERRTR1] + MOVE B,JCLP + ILDB B,B + MOVEI A,ARGCT + CAIN B,^M ;If the from-filename is null, default it to the + JRST [ PUSHJ P,FLSLIN + JRST ATRPU2] ; to-filename. + MOVE C,ARGCT + PUSHJ P,ARG + [ASCIZ/from local file: /] + JUMPN C,ATRPU2 ;If the to-file was null, use the from-file for it. + MOVE C,[ARGBUF,,ALTARG] + BLT C,ALTARG+JCLBFL-1 ;Save it away. + ;Will send after we read rest of command. +ATRPU2: MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR + SKIPLE TT,DCTYPE + JRST [ MOVE TT,DCBYTE ; If logical-byte being used, + CAIE TT,36. ; Then if not 36-bit bytes + TDZA TT,TT ; we must use unit-mode for SIOT + SETO TT, ; otherwise hack block image for 36-bit xfers + JRST .+1] + SYSCAL OPEN,[ (TT)1+[.BII,,DC ? .UAI,,DC] + FILDEV ? FILFN1 ? FILFN2 ? FILDIR ] + JRST FILERR + PUSHJ P,NETWLS + FWRITE NETO,[[STOR ],TZ,ALTARG,CRLF,,] + JRST APRIN1 + +;HOSTNM for TRAN command - if there is no Altmode, we assume the host name +;was not specified, and default it to the local host. +;For TCP, I think this breaks. +THOSTN: MOVE B,JCLP ;Look ahead. See if next filespec preceded by altmode. + MOVE A,[440700,,THOSTB] +TSYMGL: ILDB T,B + CAIN T,^Q + JRST TSYMGQ ;^Q'd _'s, 's, and ='s don't count. + CAIE T,"= + CAIN T,"_ ;Reached the end of the next filename with no altmode + JRST TSYMDF ; => default the hostname. + CAIN T," + JRST TSYMDF +TSYMG1: CAIE T,^C ;If end of jcl, stop + CAIN T,^M + JRST TSYMDF + CAIN T,^_ ;I bet you didn't know this ends JCL + JRST TSYMDF + JUMPE T,TSYMDF + CAIE T,33 ;Reached an altmode => host name explicitly spec'd, + JRST [ IDPB T,A + JRST TSYMGL] + MOVEM B,JCLP ;Mark it (and altmode) gobbled so filename doesn't + SETZ T, ;include them. + IDPB T,A + MOVEI A,THOSTB + JRST NHOSTN ;Read the host name and convert to number. + +TSYMGQ: ILDB T,B + JRST TSYMG1 + +TSYMDF: MOVE A,OWNHST + TLO A,400000 ;Can lose if not running on a PDP10! + JRST POPJ1 + +SUBTTL Directory Listing Commands + +ALSTL: PUSHJ P,ARG ;LISTL - list local directory + [ASCIZ /Directory: /] + MOVE B,[FILDEV,,FILDEV] + PUSHJ P,FILPAR ;Parse the directory specified. + ;It becomes our default too. + SYSCAL OPEN,[ [.UAI,,DC] + FILDEV ? ['.FILE.] ? [SIXBIT /(DIR)/] ? FILDIR] + JRST FILERR + MOVEI A,DC + MOVEI B,TYOC + PUSHJ P,XFRASC ;Read whole file off DC and write to TYOC, + ;flushing padding. + JRST POPJ1 + +;LISTF - list foreign directory +ALSTF: SKIPA A,[[ASCIZ /LIST /]] +ALSTB: MOVEI A,[ASCIZ /NLST /] ;LISTB - brief (names only) listing of directory. + PUSH P,DCBYTE + PUSH P,DCTYPE + PUSH P,DCSENT ;Save current connection status + PUSH P,A ;Save away the command type (FTP command to use). + PUSHJ P,CONTST ;If not connected yet, ask for host and connect. + MOVE A,DCBYTE + CAIN A,8 ;Switch to TYPE A BYTE 8 (if not there already). + SKIPE DCTYPE + JRST [ PUSHJ P,ATEXT + JRST ERRTR1 + JRST .+1] + PUSHJ P,ARG ;Read in directory name, send to server. + [ASCIZ /Directory: /] + POP P,B ;Recover FTP command (LIST or NLST). + PUSHJ P,NETRLS + FWRITE NETO,[TZ,(B),TS,(A),CRLF,,] + .NETS NETO, + MOVEI B,TYOC + PUSHJ P,NETREAD ;Read what the LIST command sends us, and type on TTY. + POP P,C ;Now restore the old status. + JUMPE C,[ MOVEM C,DCSENT + SUB P,[2,,2] ;If DCSENT was 0, just restore it - thats all! + JRST POPJ1] + POP P,B ;Otherwise restore the TYPE, then the BYTE. + MOVE A,(P) ;If restoring to TYPE A, BYTE 8, don't bother + CAIN A,8 + JUMPE B,[ MOVEM A,DCBYTE + MOVEM B,DCTYPE + SETOM DCSENT + POP P,A + JRST POPJ1 ] + MOVEI D,[ASCIZ /A/] + SKIPGE B + MOVEI D,[ASCIZ /I/] + SKIPLE B + JRST [ MOVEI D,[ASCIZ /L 36/] + CAIE A,36. + MOVEI D,[ASCIZ /L 8/] + JRST .+1] + PUSHJ P,ATYPE3 + JRST ERRTR1 + POP P,A + TLNE F,%LTCP + JRST POPJ1 + PUSHJ P,ABYTE2 + JFCL + JRST POPJ1 + +SUBTTL Type and Byte Commands. + +;If have just connected, to a PDP10, try negotiating 36 bit image mode. +DCSEND: SKIPE DCSENT + POPJ P, + PUSHJ P,ATEN ;Specify TYPE I, BYTE 36. + POPJ P, ;He doesn't like them => proceed, using ASCII mode. + POPJ P, + +;Set the transfer TYPE, and possibly the byte size. +ATYPE: TLNE F,%LTCP + JRST [ CALL ARGCON + [ASCIZ /A for ASCII, or L for LOGICAL: /] + JRST ATYPE1 ] + PUSHJ P,ARGCON + [ASCIZ /A for ASCII, I for IMAGE: /] +ATYPE1: HRRZ D,(A) + MOVE D,1(A) + ILDB D,D ;Check the type he specified. + CAIL D,140 ;Uppercasify. + SUBI D,40 + CAIE D,"L ;Logical type is hairy. + JRST ATYPE2 + TLNN F,%LTCP ;Only allowed if doing TCP. + JRST ATYPEL + MOVE D,[ASCIZ "L 36"] + MOVEM D,ALTARG + MOVEI D,ALTARG ;Actual argument string for server. + HRLZI T,260700 + HRR T,D ;Bp to byte size in it. + MOVE B,1(A) ;Bp to user's string. +ATYPL1: ILDB C,B + JUMPE C,[ OUT(TYOC,("Defaulting logical byte size to 36 bits."),EOL) + JRST ATYPE3 ] + CAIL C,60 ;Look for a number. + CAILE C,71 + JRST ATYPL1 + IDPB C,T ;Deposit first digit. + ILDB C,B ;There may be a second digit. + JUMPE C,ATYPL2 + CAIL C,60 + CAILE C,71 +ATYPL2: SETZ C, + IDPB C,T ;Deposit second (and last) digit. + JRST ATYPE3 + +ATYPE2: CAIN D,"A + JRST [ MOVEI D,[ASCIZ /A/] + JRST ATYPE3 ] + CAIN D,"I + JRST [ TLNE F,%LTCP ;If doing NCP, allow type "I". + JRST ATYPEL + MOVEI D,[ASCIZ /I/] + JRST ATYPE3 ] +ATYPEL: FWRITE TYOC,[[? "],TS,(A),[" is not a type that I understand.],CRLF,,] + JRST ERRTR1 + +;Select TYPE according to ASCIZ string in D (e.g. "L 36"). +ATYPE3: SETOM DCSENT ;Override defaults now. + FWRITE NETO,[[TYPE ],TZ,(D),CRLF,,] + PUSH P,D + MOVEI A,200. ;See whether server it likes it. + PUSHJ P,REPLY + JRST POPAJ + POP P,D ;Accepted. + SETOM DCTYPE ;DCTYPE gets 0 for ASCII, -1 for image. + HRLI D,350700 + LDB T,D ;Get 1st char + CAIN T,"A + SETZM DCTYPE + CAIN T,"L + MOVMS DCTYPE ;Logical byte, set 1 + JRST POPJ1 + +;Set data connection byte size. We only handle 8, 32 or 36-bit bytes. +ABYTE: TLNN F,%LTCP + JRST [ CALL ARGCON + [ASCIZ /Byte size (8 or 36): /] + CALL RDDEC + JRST ABYTE1] + PUSHJ P,ARGCON + [ASCIZ /Byte Size (8, 32 or 36): /] + PUSHJ P,RDDEC ;Now convert arg to binary in A. + CAIN A,32. + JRST ABYTE2 ;Is the byte size ok with us? +ABYTE1: CAIE A,8. + CAIN A,36. + JRST ABYTE2 +ABYTEL: FWRITE TYOC,[[? "],N9,A,[" is not a byte size I can handle.],CRLF,,] + JRST ERRTR1 + + ;Select BYTE size in A. +ABYTE2: TLNE F,%LTCP + JRST [ FWRITE NETO,[[TYPE L ],N9,A,CRLF,,] + JRST ABYTE3 ] + FWRITE NETO,[[BYTE ],N9,A,CRLF,,] +ABYTE3: SETOM DCSENT ;No need to send him our defaults - they are overridden now. + PUSH P,A + MOVEI A,200. ;Yes, send it to server and see if ok with him. + PUSHJ P,REPLY + JRST POPAJ + POP P,DCBYTE ;If so, remember it as the one we are using. + JRST POPJ1 + + +;Select 36-bit Image mode. +ATEN: PUSHJ P,CONTST + MOVEI D,[ASCIZ /L 36/] ;TCP says it this way. + TLNN F,%LTCP + MOVEI D,[ASCIZ /I/] ;NCP says it this way. + PUSHJ P,ATYPE3 + POPJ P, + TLNE F,%LTCP + JRST [ MOVEI A,36. + MOVEM A,DCBYTE + JRST POPJ1] + MOVEI A,36. ;If it wins, do the BYTE 36. + JRST ABYTE2 + +;Select 8-bit ASCII mode. Shorthand for TYPE A, BYTE 8. +ATEXT: PUSHJ P,CONTST + MOVEI D,[ASCIZ /A/] + PUSHJ P,ATYPE3 ;Try the TYPE A. + POPJ P, + TLNE F,%LTCP + JRST POPJ1 + MOVEI A,8 + JRST ABYTE2 ;If it wins, do the BYTE 8. + +SUBTTL Script Files and Command Files + +ASCRIP: PUSHJ P,ARG + [ASCIZ/Script file: /] + MOVE B,[SCRIPF,,SCRIPF] + PUSHJ P,FILPAR + SETZM SCRIPT + SYSCAL OPEN,[ [.UAO,,SCRIPC] + SCRIPF ? SCRIP1 ? SCRIP2 ? SCRIPS] + JRST FILERR + SETOM SCRIPT + JRST POPJ1 + +AESCRI: PUSHJ P,FLSLIN ;ESCRIPT - close script file. Flush the rest of the line. + SKIPN TYOTTY ;Closing script and can't type on tty => + OUTZ TYOC,[ASCIZ /Note: committing suicide since can't type on TTY +/] + .CLOSE SCRIPC, + SETZM SCRIPT + JRST POPJ1 + +AXFILE: PUSHJ P,ARG + [ASCIZ/Command file: /] + MOVE B,[COMDEV,,COMDEV] + PUSHJ P,FILPAR + SETZM COMFIL + SYSCAL OPEN,[ [.UAI,,COMC] + COMDEV ? COMFN1 ? COMFN2 ? COMDIR] + JRST FILERR + SETOM COMFIL + JRST POPJ1 + +SUBTTL Reply Processing + +;Call here with A containing the decimal number of expected reply. +;Skips if success reply seen, non-skip return if error reply seen, +;Handles intermediate conditions, requests for password, printing of replies, etc. +;Returns with B containing reply code found. +;The reply will be in the string variable REPLYS + +REPLY: .NETS NETO, ;just in case +REPLY0: BCONC + PUSHJ P,REPLIN ;get a line, number prefix in RH(B), hyphen flag in SIGN(B) + JUMPGE B,REPLY2 ;jump if single-line + HRRZ C,B + AOJE B,[ECONC REPLYS ;Line with no reply code! Show it to user + SKIPN JCLTRN + OUTS TYOC,REPLYS + JRST REPLY0] ;and then ignore it. + PUSH P,C ;multi-line, gobble rest of it, concatenating all together. +REPLY1: PUSHJ P,REPLIN + JUMPL B,REPLY1 ;no number, get more + POP P,B +REPLY2: ECONC REPLYS ;REPLYS := reply string + SKIPE PRREP + OUTS TYOC,REPLYS + CAMN B,A ;expected reply? + JRST POPJ1 ;Yes, winning + CAILE B,999. ;range check reply code + JRST REPTY9 ;Anything over 999 is considered to be in the 900's + MOVE C,B ;No, get type of reply + IDIVI C,100. ; which is the hundreds digit +REPLY3: JRST @.+1(C) ;Jump to reply handler based on code first digit. + REPTY0 + REPTY1 + REPTY2 + REPTY3 + REPTY4 + REPTY5 + REPTY6 + REPTY7 + REPTY8 + REPTY9 + +;0xx useless information. [Old protocol only.] Might be interesting, type it out. +REPTY0: PUSHJ P,REPDIS + JRST REPLY + +;1xx positive preliminary reply. Might be interesting, type it out. +REPTY1: PUSHJ P,REPDIS + CAIL A,100. ; If expected reply was in 1xx range, + CAILE A,199. + JRST REPLY + JRST POPJ1 ; then take win return anyway... + +;2xx positive completion reply. +;Indicates winnage, except not same code as expected so print. +REPTY2: PUSHJ P,REPDIS + JRST POPJ1 + +;4xx temporary error, 5xx permanent error, 6xx, 7xx, 8xx, 9xx undefined. +REPTY4: REPTY5: REPTY6: REPTY7: REPTY8: REPTY9: +REPTYE: SKIPN PRREP ;If PRREP, we already printed it, so don't do it again. + OUTS TYOC,REPLYS ;error message - print it including reply code. + POPJ P, ;lose + +;3xx User action required. +;Special cases are 330 give password, 331 give account, 332 login please +;Others handled by caller saying e.g. 354 is what I expect. +REPTY3: TLNE F,%LTCP + JRST [ CAIN B,331. + JRST REP3PA + CAIN B,332. + JRST REP3AC + JRST REPTYE] + CAIN B,330. + JRST REP3PA + CAIN B,331. + JRST REP3AC + CAIN B,332. + JRST REP3LO + JRST REPTYE ;Unexpected 300 code - treat it as an error. + +REP3PA: SETOM INHIDE ; Don't echo next input line. TYILIN resets. + JSP E,REP3GT + [ASCIZ/Password (safety of this password not guaranteed): /] + [ASCIZ/PASS/] + +REP3AC: JSP E,REP3GT + [ASCIZ/Account: /] + [ASCIZ/ACCT/] + +REP3LO: JSP E,REP3GT + [ASCIZ/Login Name: /] + [ASCIZ/USER/] + +REP3GT: OUTZ TYOC,@(E) + PUSHJ P,ARG ;read the password or whatever. + [0] + OUTZ NETO,@1(E) ;send command the server wanted + OUTI NETO,40 + OUTS NETO,(A) ;with the arg we read. + CRLF NETO, + JRST REPLY ;try again + +;Routine to display a non-error reply. Doesn't print the reply code. +REPDIS: SKIPN JCLTRN ;Don't show it for :FTP FOO=BAR. + SKIPE PRREP ;or if it was already typed out. + POPJ P, + PUSHAE P,[A,B] + HRRZ A,REPLYS ;byte count + MOVE B,REPLYS+1 ;byte pointer +REPDS0: SOJL A,REPDS9 + ILDB T,B ;flush reply code number and space or hyphen following it + CAIL T,"0 + CAILE T,"9 + CAIA + JRST REPDS0 + CAIE T,40 + CAIN T,"- + CAIA +REPDS1: PUSHJ P,TYO + CAIN T,^J + JRST REPDS0 + SOJL A,REPDS9 + ILDB T,B + JRST REPDS1 + +REPDS9: POPAE P,[B,A] + POPJ P, + +;Routine to read in a line of reply. +;Returns in B: -1 if no reply code, reply code for single-line reply, +;400000,,reply code for first line of multi-line reply. +;If connection gets closed, returns via POP1J with -1 in B +REPLIN: SETO B, +REPLN0: .IOT NETI,TT + JUMPL TT,POP1J ;EOF + CAIN TT,^G ;rumor that BBN sends bells + JRST REPLN0 + CAIN TT,177 ;Ignore random rubouts from Multics + JRST REPLN0 + CAIN TT,377 + JRST [ .IOT NETI,TT ;Ignore new-TELNET control codes from Multics. + JRST REPLN0] + CAIL TT,"0 + CAILE TT,"9 + JRST REPLN1 + SKIPGE B + TDZA B,B + IMULI B,10. + ADDI B,-"0(TT) + OUTI STRC,(TT) + JRST REPLN0 + +REPLN1: CAIN TT,"- + HRLI B,(SETZ) +REPLN2: OUTI STRC,(TT) + JUMPL TT,POP1J ;EOF + CAIN TT,^J + POPJ P, + .IOT NETI,TT + JRST REPLN2 + +SUBTTL TTY Line Input + +;Reads a line from the TTY or command file into JCLBUF (or wherever JCLBFP points). +;Clobbers no ACs + +TYILIN: PUSHAE P,[A,B,C,E,T] + PUSH P,READIN ;For now, echo only on the TTY. After rubout processing + SETOM READIN ;is finished, we echo the edited command line on script file. +TYIOVR: SKIPE COMFIL + JRST TYILN4 + SYSCAL RCPOS,[MOVEI TYOC ? MOVEM E] + .LOSE 1000 +TYILN4: MOVE B,JCLBFP + MOVEM B,JCLP ;B is B.P. to store chars through. +TYILN0: SKIPN COMFIL + JRST TYILN2 + .IOT COMC,A ;IF HAVE COMMAND FILE, READ FROM IT, + JUMPGE A,TYILN3 + OUTZ TYOC,[ASCIZ /End of Command file +/] + .CLOSE COMC, ;(EOF => IT'S NOT OPEN ANY MORE) + SETZM COMFIL + SKIPN TRITTY ;If disowned and tty not input-translated, we can't read anything. + .LOGOUT + JRST TYILN9 ;Now pretend to read a null command, so we make the main loop prompt. + +TYILN2: SETZM SILENT + SKIPN TYITTY ;ELSE IF HAVE TTY INPUT, READ FROM IT, ELSE BARF. + JRST NOTTY + .IOT TYIC,A +TYILN3: CAIE A,177 + CAIGE A,40 + JRST TYIRUB ;Jump if control +TYILN1: MOVE T,B + SUB T,JCLBFP + HRRES T + CAIL T,JCLBFL-1 + JRST [ OUTI TYOC,^G ;Buffer full? Complain, don't store character. + JRST TYILN0] + SKIPE INHIDE ; Hiding input? + JRST TYILND ; Yes, don't echo. + SKIPE HDXTTY + SKIPE COMFIL + OUTI TYOC,(A) ;echo, if reading from TTY and it is full duplex. +TYILND: IDPB A,B ;stash away. + JRST TYILN0 + +TYIRUB: SKIPN COMFIL ;Don't recognize Rubout from command files. + CAIE A,177 + JRST TYICTL + MOVE A,B + MOVE C,JCLBFP + IBP A + IBP C + CAMN A,C ;Rubout when buffer empty types a CRLF. + JRST [ CRLF TYOC, ? JRST TYIOVR ] + LDB A,B ;char getting rubbed + D7BPT B ;officially remove it from buffer. + SKIPE INHIDE ; If hiding input, + JRST TYILN0 ; needn't hack cursor. + SKIPN DISTTY + JRST TYIRUP ;jump if printing terminal + CAIL A,40 + JRST [ OUTI TYOC,^P ? OUTI TYOC,"X ? JRST TYILN0 ] +TYIRDS: OUTI TYOC,^P + OUTI TYOC,"H + OUTI TYOC,10(E) + HLRZ A,E + OUTI TYOC,^P + OUTI TYOC,"V + OUTI TYOC,10(A) + OUTI TYOC,^P + OUTI TYOC,"L +TYILN8: SETZ A, + MOVE T,B + IDPB A,T ;Make the string ASCIZ. + SKIPN INHIDE ; Don't output if hiding it. + OUTZ TYOC,@JCLBFP + JRST TYILN0 + +TYIRUP: SKIPN INHIDE + .IOT TYOC,A + JRST TYILN0 + +TYICTL: CAIE A,33 ;altmode and tab are printing characters + CAIN A,11 + JRST TYILN1 + CAIN A,10 ;so is backspace + JRST TYILN1 + CAIN A,^Q ;^Q is needed for quoting chars in filenames. + JRST TYILN1 + CAIE A,^N ;^N also ends line (for JCL from DDT). + CAIN A,15 ;CR ends the line + JRST TYILN9 + CAIN A,^J ;Ignore line feed + JRST TYILN0 + SKIPE COMFIL ;Input editing controls not recognized in command files. + JRST [ CAIN A,^C + JRST TYILN0 ;Ignore ^C in command files. + JRST TYILN1] + CAIN A,^L ;^L redisplays input + JRST TYIFF + CAIN A,^U + JRST TYIKIL + CAIE A,^G ;^D and ^G flush input buffer + CAIN A,^D + JRST TYIKIL + CAIN A,^C ;^C ends input and requests suicide after command. + JRST TYICTC + JRST TYILN1 ;Other controls taken as ordinary characters. This really sucks, + ;the right way to do this is to make ^Q quote the next character, + ;unfortunately this code is too bad for me to fix it easily. + ;This mainly for Tenex control-V. + +TYIKIL: SKIPN DISTTY ; if printing tty, + JRST [ MOVE B,JCLP ? JRST TYIRS0 ] ; flush buffer, reprompt + MOVE A,B ; else, display terminal, wipe all chars + MOVE C,JCLBFP ; one at a time + IBP A + IBP C + CAMN A,C + JRST TYILN0 + LDB A,B ;char getting rubbed + D7BPT B ;officially remove it from buffer. + SKIPE INHIDE ; If hiding input, + JRST TYIKIL ; needn't hack cursor. + CAIL A,40 ; else erase char from screen + JRST [ OUTI TYOC,^P ? OUTI TYOC,"X ? JRST .+1 ] + JRST TYIKIL + + +TYIRST: MOVE B,JCLP ;flush input we got so far. +TYIFF: SKIPE DISTTY + JRST [ OUTI TYOC,^P ;On display tty, + OUTI TYOC,"C ; set horzontial position to + MOVEI E,0 ;Change display-point to top-left corner + JRST TYIRDS ] ;and redisplay input +TYIRS0: SKIPN HDXTTY + .IOT TYOC,A ;echo the mumble + CRLF TYOC, ;redisplay on printing tty + JRST TYILN8 + +TYICTC: SETOM SUICID ;^C - say we should suicide soon. + SKIPN HDXTTY + .IOT TYOC,A ;Echo the ^C, then end the command. +TYILN9: SETZ A, ;Make input line end with null, for sake of outputting to SCRIPC. + IDPB A,B + POP P,READIN + SKIPN INHIDE + JRST [ SKIPE SCRIPT ;Output the line to the script file if any. + OUTPZ SCRIPC,JCLP + JRST .+1] + CRLF TYOC, ;This CRLF goes to TTY and to script file. + MOVEI A,^M ;Now make input line end properly, with CR-Null + DPB A,B + SETZ A, + IDPB A,B + SETZM INHIDE ; Crock, always reset after each call. + POPAE P,[T,E,C,B,A] + POPJ P, + +SUBTTL Interrupt Level + +TSINT: 0 ? 0 + PUSHAE P,[T,TT,A] + SKIPGE A,TSINT + JRST TSINT2 ;I/O interrupts + TRNN A,%PIIOC + .VALUE ;non-enabled interrupt + .SUSET [.RBCHN,,A] + CAIL A,NETI + CAILE A,NETDO + JRST TSINT1 ;Not network + .DISMIS [NETERR] ;Network, inform user + +TSINT1: HRLZ A,TSINT+1 ;Give error to DDT + HRRI A,1+.LZ %PIIOC ;and allow it to be continued + MOVEM A,TSINT + POPAE P,[A,TT,T] + .CALL [ SETZ ? 'DISMIS ? MOVEI ? TSINT+1 ? MOVEI ? MOVEI ? SETZ TSINT ] + .LOSE %LSSYS + +TSINT2: TRNN A,1_TYIC + .VALUE + MOVEI A,TYIC + .ITYIC A, + JRST TSINT3 + CAIE A,^G + JRST TSINT3 + OUTZ TYOC,[ASCIZ/ +QUIT +/] + .DISMISS [ERRTR1] + +TSINT3: POPAE P,[A,TT,T] + .DISMISS TSINT+1 + +SUBTTL Data Transfer Routines + +;Transfer the file open on the channel in A to the channel in B, +;using whichever mode is appropriate. Closes the input channel, +;but not the output. If the output channel specified is TYOC, we +;output via TYO to the TTY and/or script file. +; TCP transfers always use 8-bit bytes. The storage format to use +; is determined by DCBYTE and DCTYPE and the server is told which +; to use with the TYPE command. +; Svr cmd DCTYPE DCBYTE Description +; TYPE A 0 8 ASCII text. User stores as 7-bit bytes +; TYPE I -1 8, 36 Image. User stores as packed 36-bit words +; TYPE L 8 1 8 Logical byte 8. User stores as 8-bit bytes. +; TYPE L 36 1 36 Logical byte 36. Same as Image, but the right +; thing for PDP-10 binary file xfers. + +XFR: SETZM NBITS + SETZM BUFFER ;Clear buffer - else, an ascii xfr after an image one + MOVE C,[BUFFER,,BUFFER+1] ;might set some low bits. + BLT C,BUFFER+BUFFL-1 + SKIPE DCTYPE + JRST XFRIMG + +;Transfer the file open on channel in A to the channel in B, in ASCII mode. +XFRASC: MOVEI D,BUFFL*5-5 ;Compute buffer size + CAIN B,TYOC + MOVEI D,20. + MOVEM D,XFRLBV + MOVEI D,BUFFER+BUFFL-1 ;And last-word pointer + CAIN B,TYOC + MOVEI D,BUFFER+4 + MOVEM D,XFRLWP + MOVE C,[440700,,BUFFER] + MOVEI D,5 ;First read ahead one word. + SYSCAL SIOT,[A ? C ? D] ;When we output the buffer we always save 1 word, + .LOSE 1400 ;so that we can always flush up to 5 chars + ;of padding (^C's or ^@'s). + JUMPG D,XFRAS2 ;Didn't get even 1 word => at EOF. +XFRASL: MOVE C,[440700,,BUFFER+1] ;Try to fill up buffer. + MOVE D,XFRLBV + SYSCAL SIOT,[A ? C ? D] + .LOSE 1400 + JUMPG D,XFRAS1 ;Didn't fill it all up => at EOF, flush some padding. + MOVE C,[440700,,BUFFER] + MOVE D,XFRLBV ;Did fill it => output it, but save the last word, + PUSHJ P,XFRASO + MOVEI D,*40.;8-bit ASCII, remember? 1 word is 5 bytes = 40 bits. + CAIN B,TYOC + MOVEI D,20.*8 + ADDM D,NBITS + MOVE C,@XFRLWP ;Move last word down into first word. + MOVEM C,BUFFER + JRST XFRASL + +XFRAS2: ADD D,XFRLBV +XFRAS1: MOVNS D + ADD D,XFRLBV + ADDI D,5 ;# chars we have in buffer now. + SYSCAL CLOSE,[A] ; Close empty input chan + .LOSE %LSFIL + SETZ A, + PTSKIP A,C ; Make BP canonical (can be 440700 from SIOT...) +XFRAS4: JUMPE D,CPOPJ ;Discard any number of ^@'s or ^C's, then one ^L. + LDB T,C + CAIE T,^C + JUMPN T,XFRAS3 + D7BPT C + SOJA D,XFRAS4 + +XFRAS3: CAIE T,^L + JRST XFRAS5 + D7BPT C + SOJE D,CPOPJ +XFRAS5: MOVE C,[440700,,BUFFER] ;Output what's left after flushing padding. + MOVE T,D + IMULI T,8 + ADDM T,NBITS +;Output c(D) chars from b.p. in C to channel in B, handling TYOC specially. +XFRASO: CAIN B,TYOC + JRST XFRTTY + SYSCAL SIOT,[B ? C ? D] + .LOSE 1400 + POPJ P, + +XFRTTY: ILDB T,C + PUSHJ P,TYO + SOJG D,XFRTTY + POPJ P, + +; Image transfer from channel in A to channel in B. +XFRIMG: TLNE F,%LTCP + JRST XFRIT ; Hack TCP local/image transfer + SKIPLE DCTYPE + JRST XFRLCL ; Logical-byte transfer + MOVE C,DCBYTE + CAIE C,36. + JRST XFRIM1 ; Go transfer bytes, not words +XFRIM4: MOVE C,[-BUFFL,,BUFFER] ; Read a bufferfull. + SYSCAL IOT,[A ? C] + .LOSE %LSFIL + JUMPGE C,[MOVE C,[-BUFFL,,BUFFER] ; Restore AOBJN ptr + SYSCAL IOT,[B ? C] ; And use to output buffer. + .LOSE %LSFIL + MOVEI C,36.*BUFFL + ADDM C,NBITS + JRST XFRIM4] + HRLOI C,-BUFFER-1(C) ; Put <#wds-1> in LH, -1 in RH + EQVI C,BUFFER ; And convert to AOBJN pointing to buffer. + MOVE D,C + SYSCAL IOT,[B ? C] ; And output rest of stuff. + .LOSE %LSFIL + SUBI C,(D) ; C gets number of words IOTed + IMULI C,36. + ADDM C,NBITS +XFRIM9: SYSCAL CLOSE,[A] ; Aha, got it all. Close empty input chan. + .LOSE %LSFIL + POPJ P, + +XFRIM1: MOVEI C,36. ;Get bytes per word + IDIV C,DCBYTE + MOVEM C,XFRBPW + MOVE T,DCBYTE ;Get byte pointer to buffer + MOVE D,[440000,,BUFFER] + DPB T,[300600,,D] + SKIPL XFRDIR + JRST XFRIM2 ; Reading from net + MOVE C,[-BUFFL,,BUFFER] ; Read a bufferfull from disk + SYSCAL IOT,[A ? C] + .LOSE %LSFIL + MOVEI C,-BUFFER(C) ; Number of words read + IMUL C,XFRBPW ; Number of bytes to send + JUMPE C,XFRIM9 ; EOF + IMUL T,C + ADDM T,NBITS + SYSCAL SIOT,[B ? D ? C] ;Output them to net + .LOSE %LSFIL + JRST XFRIM1 + +XFRIM2: MOVEI C,BUFFL ;Read a bufferfull from net + IMUL C,XFRBPW + MOVE E,C + SYSCAL SIOT,[A ? D ? C] + .LOSE %LSFIL + SUBB E,C ;Number of bytes read + JUMPE E,XFRIM9 ;EOF + IMUL T,E + ADDM T,NBITS + IDIV C,XFRBPW + SKIPE D + ADDI C,1 ;Part word possible at EOF + MOVNS C + HRLZS C + HRRI C,BUFFER + SYSCAL IOT,[B ? C] ;Write to disk + .LOSE %LSFIL + JRST XFRIM1 + + ; Local-byte Transfer. +XFRLCL: PUSHAE P,[C,D,E] + MOVEI C,BUFFER + MOVE D,DCBYTE ; Get byte-size + DPB D,[$SFLD,,C] ; Stick into size field of BP + TLO C,440000 ; Start at beg of word + MOVEI D,36. + IDIV D,DCBYTE ; Find # bytes in a word + MOVEM D,XFRBPW ; Save + IMULI D,XFRBFL ; Find # bytes in buffer + MOVE E,D ; Save cnt + PUSH P,C ; Save BP +XFRLC2: MOVE D,E ; Get # bytes max to read + MOVE C,(P) ; Restore BP + SKIPE XFRDIR + JRST [ MOVEI D,XFRBFL ; Nope, DSK... set # wds + HRLI C,444400 ; and use word-size bytes. + JRST .+1] ; + SYSCAL SIOT,[A ? C ? D] ; Slurp up + JSR AUTPSY + SKIPE XFRDIR + IMUL D,XFRBPW ; convert count to # bytes. + SUBM E,D ; Get # bytes read in D + MOVE T,D ; Stat cruft + IMUL T,DCBYTE + ADDM T,NBITS + JUMPLE D,XFRLC9 + SKIPN XFRDIR + JRST [ PUSH P,E ; Pad out. + IDIV D,XFRBPW ; Find # words + CAILE E, ; Round up + AOS D + CAILE E, ; Pad out with zeros + PUSHJ P,[PUSH P,D + SETZ D, + IDPB D,C + POP P,D + SOS (P) + SOS (P) ; Call again til done. + SOJA E,APOPJ ] + POP P,E + JRST .+1] + MOVE C,(P) ; Restore BP + SKIPN XFRDIR + HRLI C,444400 ; use word-size bytes. + SYSCAL SIOT,[B ? C ? D] ; Output them + JSR AUTPSY + JRST XFRLC2 +XFRLC9: POP P,C + POPAE P,[E,D,C] + POPJ P, + + +; XFRIT - TCP Image transfer. Network 8-bit bytes are packed into +; disk 36-bit words, and vice versa. +; A/ input channel +; B/ output channel +; XFRDIR/ -1 if outputting to net + +XFRIT: SKIPLE DCTYPE ; Do a test of logical byte mode + JRST [ MOVE T,DCBYTE + CAIN T,36. ; Currently must be 36 + JRST .+1 + CAIN T,8. + JRST XFRLCL ; Hmm, try to hack this bytesize (shd be 8) + OUT(TYOC,("Cannot handle TYPE L "),D(DCBYTE),(", using TYPE L 8."),EOL) + JRST XFRLCL] + PUSHAE P,[C,D,E,R] +; TRNE F,%NTDIR + SKIPE XFRDIR + JRST XFRITO ; Output, from disk to net. + + ; TCP Image Input, network 8-bit bytes must be packed into + ; 36-bit words. +XFR8BL==<<+7>/8.> ; # words in 8-bit byte buffer +; UAROPN [%ARTZM,,BUFFAR ? [XFRBFL]] +; UAROPN [%ARTZM,,TMPAR ? [XFR8BL]] +; MOVE E,$ARLOC+BUFFAR + MOVEI E,BUFFER + HRLI E,-XFRBFL ; Set up initial AOBJN to word buffer + MOVEI R,0 ; Point to beginning of cycle + +XFRIT2: MOVEI D,4*XFR8BL ; # bytes to slurp from net + PUSH P,D +; MOVE C,$ARLOC+TMPAR + MOVEI C,TMPBUF + HRLI C,441000 + SYSCAL SIOT,[A ? C ? D] ; Get input + JSR AUTPSY +; AOS ALIVEC ; Say we're still active + TRZ F,%TMP + CAILE D, + TRO F,%TMP ; Set flag if last slurp. + POP P,C ; Restore # bytes we asked for + SUBI C,(D) ; Find # bytes we got + + MOVE D,C ; Stat cruft + LSH D,3 + ADDM D,NBITS + + IDIVI C,4 ; Get # words (rem in D) + JUMPE C,[ +; HRR C,$ARLOC+TMPAR ; If no full words, skip stuff. + HRRI C,TMPBUF + JRST XFRIT4] + MOVN C,C + HRLZS C +; HRR C,$ARLOC+TMPAR ; Now have AOBJN to the fullwords we got + HRRI C,TMPBUF + JRST @XFITCT(R) ; Re-enter cycle at right place + + ; C has AOBJN to full words we received (4 8-bit bytes) + ; D has # remaining bytes in last word + ; E has AOBJN to disk output buffer + ; R has # nibbles needed to fill out word in T. If 0, nothing in T. +XFITC0: + MOVE T,(C) ; Get word with 4 bytes left justified + LSH T,-4 ; Right-justify it. + AOBJP C,[MOVEI R,1 ; Jump if no more words + JRST XFRIT4] ; Handle wrapup stuff +IRP CNT,,[1,2,3,4,5,6,7,8] +XFITC!CNT: MOVE TT,(C) ; Get next one + LSHC T,CNT*4 ; Shift in to fill up word in T + MOVEM T,(E) ; Deposit word in buff + AOBJN E,.+2 ; Increment ptr, skip unless full + CALL XFITCB ; Force out word buff, reset E +IFN CNT-8,[ LSHC T,<32.-> ; Shift in unused portion + AOBJP C,[MOVEI R,CNT+1 ; Jump if no more input + JRST XFRIT4] ; Go handle wrapup stuff +] ; all but last subcycle +TERMIN + AOBJN C,XFITC0 ; Back to start of cycle + MOVEI R,0 ; No more data. Say no nibbles needed + ; Drop through + + ; No more 32-bit full words from input buffer. + ; T contains partial data, right-justified. + ; TT is empty, awaiting the next input word. + ; D contains the # of bytes in the next input word. + ; R has the # of nibbles left to fill out word in T (0-8) + +XFRIT4: JUMPE D,XFRIT5 ; If no remaining data, just get new entry point! + MOVE TT,(C) ; Get last data word + LSH D,1 ; Turn # bytes into # nibbles + JUMPE R,XFRIT3 ; If nothing currently in T, must skip some stuff. + MOVEI C,(R) ; Assume enough data to fill last word + CAIG D,(R) + MOVEI C,(D) ; Not enough data nibbles, just shift in all + LSH C,2 ; 4 bits per nibble + LSHC T,(C) ; Shift in desired amount + CAIGE D,(R) ; Did we have enough to fill out the word? + JRST XFRIT3 ; Nope, don't deposit anything. + MOVEM T,(E) ; Have full word for deposit + AOBJN E,.+2 + CALL XFITCB ; Output buff full, force out. + + ; Now shift in unused portion of data +XFRIT3: SUBI R,(D) ; Get new # nibbles needed + JUMPGE R,XFRIT5 ; If zero or positive, easy to set up. + MOVE C,R ; Negative, has # of data nibbles left in TT + IMUL C,[-4] ; 4 bits per nibble (make positive) + LSHC T,(C) ; Right-justify remaining data in T + ADDI R,9. ; Find # nibbles needed to fill out word + +XFRIT5: TRNN F,%TMP ; Last slurp? + JRST XFRIT2 ; Nope, go get another slurp. + + ; Last slurp, so must left-justify any remaining data and deposit it. + ; This code applies a heuristic to determine whether the remaining + ; data should actually be written or not. Normally if the user + ; FTP isn't buggy, R will either be 0 (no nibbles left) or + ; 8 (1 nibble left over, since end fell in middle of an octet). + ; If R isn't one of these, there was at least one full data byte + ; that shouldn't have been sent. In that case we pad out the word + ; and write it anyway. + JUMPN R,[ + CAIN R,8. ; If only 1 nibble left (partial byte) + JRST .+1 ; then ignore and assume all's well. + LSH R,2 ; 4 bits per nibble + LSH T,(R) ; Note pad with zeros! + MOVEM T,(E) ; Store last (partial) word. + AOBJN E,.+1 + JRST .+1] + CALL XFITCB ; Always force out. + JRST XFRIT9 + +XFITCT: XFITC0 ? XFITC1 ? XFITC2 ? XFITC3 + XFITC4 ? XFITC5 ? XFITC6 ? XFITC7 ? XFITC8 + + + ; Force out word buffer, and reset write pointer in E +XFITCB: HRRZS E +; SUB E,$ARLOC+BUFFAR ; Find # words deposited + SUBI E,BUFFER + MOVNS E + HRLZS E +; HRR E,$ARLOC+BUFFAR ; Make it an AOBJN pointer + HRRI E,BUFFER + SYSCAL IOT,[B ? E] ; Image output (E has AOBJN) + JSR AUTPSY +; MOVE E,$ARLOC+BUFFAR ; Now initialize write ptr again + MOVEI E,BUFFER + HRLI E,-XFRBFL + RET + + + ; XFR TCP Image Output, Disk to Net +XFRITO: +; UAROPN [%ARTZM,,BUFFAR ? [XFRBFL]] +; UAROPN [%ARTZM,,TMPAR ? [XFR8BL]] + +XFRIT6: MOVSI C,-XFRBFL +; HRR C,$ARLOC+BUFFAR + HRRI C,BUFFER + MOVE D,C + SYSCAL IOT,[A ? C] ; Slurp stuff up + JSR AUTPSY +; AOS ALIVEC + TRZ F,%TMP + CAIGE C, + TRO F,%TMP ; Not counted out, this is last slurp. + HLRES C + HRLOI C,XFRBFL-1(C) + EQVI C,(D) ; Now have AOBJN to words we read in. + JUMPGE C,XFRIT9 + + HLRE D,C + IMUL D,[-9.] ; Find # of 4-bit nibbles + ADDI D,1 + IDIVI D,2. ; Find # of 8-bit bytes. + + MOVE T,D ; Stat cruft + LSH T,3 + ADDM T,NBITS + + PUSH P,D +; HRRZ E,$ARLOC+TMPAR + MOVEI E,TMPBUF + SUBI E,1 ; Allow for increment of first PUSH + TLO E,(SETZ) ; Make PDL ptr + +XFRIT7: MOVE TT,(C) ; Get word 0 + LSHC T,32. ; Get 1st 32 bits right justified + LSH T,4. ; Left justify it + PUSH E,T ; Store bytes 0-3 + AOBJP C,XFRIT8 ; If counted out, must store last 4 bits. + +REPEAT 7,[ + LSHC T,4*<.RPCNT+1> ; Get low 4 bits of wd 0 + MOVE TT,(C) ; Glom onto wd 1 + LSHC T,<32.-<4*<.RPCNT+1>>> ; Fill out to 32 bits from wd 1 + LSH T,4 ; Make left justified + PUSH E,T ; Store bytes 4-7 + AOBJP C,XFRIT8 ; If counted out, store last 8 bits. +] + PUSH E,TT ; Reached alignment, store last wd directly + JRST XFRIT7 ; then repeat the cycle + +XFRIT8: PUSH E,TT + POP P,D +; MOVE C,$ARLOC+TMPAR + MOVEI C,TMPBUF + HRLI C,441000 + SYSCAL SIOT,[B ? C ? D] + JSR AUTPSY + + TRNN F,%TMP + JRST XFRIT6 + +XFRIT9: +; UARCLS TMPAR + SYSCAL CLOSE,[A] ; Close empty input chan + .LOSE %LSFIL +; UARCLS BUFFAR + POPAE P,[R,E,D,C] + RET + +SUBTTL String hacking rtns + +UUODEF EQUSTR,UEQSTR ;extra UUO for easy string comparision + +UEQSTR: MOVE U1,40 + LDB U2,[$ACFLD,,U1] + MOVE U2,(U2) ;get addr of string AC points to + HRRZ U3,(U1) ;GET CNT 1 + HRRZ U4,(U2) ;AND 2 + CAIE U3,(U4) + JRST UUORET ;NOT EQUAL, DIFFERENT LENGTHS + MOVE U1,1(U1) + MOVE U2,1(U2) + PUSH P,U3 ; Save cnt on stack. +UEQST2: SOSGE (P) + JRST UEQST5 + ILDB U3,U1 + ILDB U4,U2 + CAIN U3,(U4) + JRST UEQST2 + SUB P,[1,,1] + JRST UUORET +UEQST5: SUB P,[1,,1] + AOS UUOH + JRST UUORET + + +; Parse a word off string pointed to by A, leaves ptr to word in +; B and updates string read from. B furnishes char to break on. +PRSWRD: PUSHAE P,[C,D] + MOVE D,B ; Save desired break char in D. + BCONC + HRRZ C,(A) ;make sure something there + JUMPG C,PRSW5 + JRST PRSW6 +PRSW2: ILDB B,1(A) + CAIN B,(D) + JRST PRSW6 + OUTI STRC,(B) ; Collect string. +PRSW5: SOJGE C,PRSW2 + SETZ C, +PRSW6: ECONC WRDSTR + HRRM C,(A) + MOVEI B,WRDSTR + POPAE P,[D,C] + POPJ P, + +; CVSIX - converts a string in A to 6bit wd in A +; stops when reach 0 or get 6 chars, or hit blank and previous +; chars were nonblank + +CVSIX: PUSHAE P,[B,C,D,E] + MOVE C,1(A) + HRRZ B,(A) + CAILE B,6 + MOVEI B,6 +CVT760: SETZ A, + MOVE D,[440600,,A] +CVT761: ILDB E,C + CAIN E,40 + JUMPN A,CVT762 ;if hit blank, stop only if something already accumulated + JUMPE E,CVT762 + CAIL E,141 ;convert to uppercase + CAILE E,172 + CAIA + SUBI E,40 + SUBI E,40 ;convert to 6bit + IDPB E,D + SOJG B,CVT761 +CVT762: POPAE P,[E,D,C,B] + POPJ P, + +CVSUPR: PUSHAE P,[B,C,D] + MOVE B,1(A) + HRRZ C,(A) + JUMPG C,CVSUP5 + JRST CVSUP7 +CVSUP2: ILDB D,B + CAIL D,"a + CAILE D,"z + JRST CVSUP5 + SUBI D,40 + DPB D,B +CVSUP5: SOJGE C,CVSUP2 +CVSUP7: POPAE P,[D,C,B] + POPJ P, + + +;Convert the decimal digit string ARG to a number in A. +;Clobbers B and T and TT. +RDDEC: SKIPA TT,[10.] +;Similar, but reads an octal number. +RDOCT: MOVEI TT,10 + SETZ A, + MOVE B,ARGPT +RDDEC2: ILDB T,B + CAIL T,"0 + CAILE T,"9 + POPJ P, + IMUL A,TT + ADDI A,-"0(T) + JRST RDDEC2 + +; A - ptr to string descriptor +; B - [default file block],,[result file block] +; However, default FN2 is always > if only a FN1 was given. + +FILPAR: PUSHAE P,[(A),1(A),A,B,C,D,E] + HRRZ E,B ;get result addr + BLT B,3(E) ;zap default values into result block + PUSHJ P,FNPARD ;parse string as filename, DDT style + CAIE A, + MOVEM A,(E) ;device + CAIE B, + MOVEM B,1(E) ;dir + CAIN E,FILDEV + .SUSET [.SSNAM,,B] ;If main default SNAME changed, show it in who-line. + CAIE C, + MOVEM C,2(E) ;fn1 + MOVSI B,(SIXBIT/>/) + CAIN C, + MOVEM B,3(E) ;Default FN2 is > if no FN1. + CAIE D, + MOVEM D,3(E) ;fn2 + POPAE P,[E,D,C,B,A,1(A),(A)] + POPJ P, + + +;;; String Vars + +IFE @, REPLYS: WRDSTR: +STRNAM REPLYS ;Reply from server +STRNAM WRDSTR ;Used by PRSWRD + +STRNGS: SBLOCK + NSTRS==<.-STRNGS>/2 + +CONSTANTS +VARIABLES + +ARPAGS: ,,LSTPAG ; Define free area to be everything above this. + ; Note that we gobble from here to call HSTMAP + ; before we initialize the storage allocator. +LSTPAG==<.+1777>/2000 + +END GO