Changeset 235

Timestamp:

08/18/11 06:04:02 (22 months ago)

Author:

rjs

Message:

Update.

Location:

trunk/lisp/lmio

Files:

• chsaux.lisp (modified) (3 diffs)
• chsncp.lisp (modified) (2 diffs)
• chstbl.lisp (modified) (2 diffs)
• comlnk.lisp (modified) (3 diffs)
• disk.lisp (modified) (1 diff)
• dledit.lisp (modified) (2 diffs)
• dribbl.lisp (modified) (1 diff)
• fnutil.lisp (modified) (5 diffs)
• format.lisp (modified) (1 diff)
• grind.lisp (modified) (1 diff)
• mini.lisp (modified) (1 diff)
• ofnuti.lisp (modified) (1 diff)
• print.lisp (modified) (2 diffs)
• qfile.lisp (modified) (6 diffs)
• qio.lisp (modified) (1 diff)
• rddefs.lisp (modified) (1 diff)
• rdtbl.lisp (modified) (1 diff)
• read.lisp (modified) (3 diffs)
• rtc.lisp (modified) (2 diffs)
• rtcmac.lisp (modified) (2 diffs)
• unibus.lisp (modified) (2 diffs)

trunk/lisp/lmio/chsaux.lisp

@@ -650 +650 @@
                HOST (NSUBSTRING DESTINATION (1+ HOST) (STRING-LENGTH DESTINATION))))
         (T (SETQ PERSON "anyone"  HOST DESTINATION)))
-  (SI:FORCE-USER-TO-LOGIN)
+  (FS:FORCE-USER-TO-LOGIN)
   (COND ((NULL MSG)
          (FORMAT T "~%Message: (terminate with End)~%")
@@ -704 +704 @@
                           (// IDLE 60.)
                           (\ IDLE 60.)
-                          SI:USER-PERSONAL-NAME-FIRST-NAME-FIRST
-                          SI:USER-GROUP-AFFILIATION))))
+                          FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
+                          FS:USER-GROUP-AFFILIATION))))
   (FAST-ANSWER-STRING "FINGER" GIVE-FINGER-SAVED-STRING))
 
@@ -720 +720 @@
            "~6A ~C ~22A ~6A ~:[    ~3*~;~:[~D:~2,48D~;  ~*~D~]~]     ~A"
            USER-ID
-           SI:USER-GROUP-AFFILIATION
-           SI:USER-PERSONAL-NAME-FIRST-NAME-FIRST
+           FS:USER-GROUP-AFFILIATION
+           FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
            MY-NAME-STRING
            (NOT (ZEROP IDLE))

trunk/lisp/lmio/chsncp.lisp

@@ -640 +640 @@
   ;; This process runs all Time response actions such as PROBEs and Retransmission.
         BACKGROUND  (PROCESS-CREATE "Chaos Background")
-        RECEIVER (PROCESS-CREATE "Chaos Reciever" ':SIMPLE-P T)
+        RECEIVER (PROCESS-CREATE "Chaos Receiver" ':SIMPLE-P T)
 
         )
@@ -1637 +1637 @@
     (COND (RESERVED-INT-PKT
             (FERROR NIL "Int PKT about to be lost!"))) ;Hopefully this will get printed
+    (SI:SET-PROCESS-WAIT CURRENT-PROCESS #'(LAMBDA () (NOT (OR (NULL ENABLE)
+                                                               (NULL (INT-RECEIVE-LIST)))))
+                         NIL)
+    (SETF (SI:PROCESS-WHOSTATE CURRENT-PROCESS) "Chaos Packet")
     ))
 

trunk/lisp/lmio/chstbl.lisp

@@ -60 +60 @@
                        (415 . "936 Lisp Machine Factory x6703")         ;LM16
                        (416 . "936 Lisp Machine Factory x6703")         ;LM15
-                       (417 . "936 Lisp Machine Factory x6703")         ;LM14
-                       (421 . "936 Lisp Machine Factory x6703")         ;LM13
+                       (417 . "38-301 EE-CS Machine Room x5624")        ;LM14
+                       (421 . "38-301 EE-CS Machine Room x5624")        ;LM13
                        (422 . "36-626 Speech Lab x4672")                ;LM12
                        (423 . "38-350 EE-CS Terminal Room x4650")       ;LM11
@@ -81 +81 @@
                                  (415 MIT-NE43 9)       ;LM16
                                  (416 MIT-NE43 9)       ;LM15
-                                 (417 MIT-NE43 9)       ;LM14
-                                 (421 MIT-NE43 9)       ;LM13
+                                 (417 MIT-38 3)         ;LM14
+                                 (421 MIT-38 3)         ;LM13
                                  (422 MIT-36 6)         ;LM12
                                  (423 MIT-38 3)         ;LM11

trunk/lisp/lmio/comlnk.lisp

@@ -155 +155 @@
             (COND ((NOT (STRINGP CONN))         ;Connection Succeeded.
                    ;The main loop, read, echo, and send characters.
-                   (DO ((CHAR 0.)(QUITTING-A-CONNECTION NIL))
-                       (QUITTING-A-CONNECTION)
-                     (SETQ CHAR (COM-LINK-READ LOCAL-STREAM 'LOCAL-STREAM SELF CONN))
-                     (COND ((EQ CHAR #\BREAK)
-                            (SETQ QUITTING-A-CONNECTION
-                                  (COM-LINK-HANDLE-BREAK-OR-HELP
-                                   'BREAK LOCAL-STREAM REMOTE-HOST-STREAM SELF CONN)))
-                           ((EQ CHAR #\HELP)
-                            (SETQ QUITTING-A-CONNECTION
-                                  (COM-LINK-HANDLE-BREAK-OR-HELP
-                                   'HELP LOCAL-STREAM REMOTE-HOST-STREAM SELF CONN)))
-                           (T (COM-LINK-PROCESS-CHAR LOCAL-STREAM CHAR)
-                              (FUNCALL REMOTE-HOST-STREAM ':TYO CHAR)
-                              (FUNCALL REMOTE-HOST-STREAM ':FORCE-OUTPUT)))))
+                   (DO ((CHAR (COM-LINK-READ LOCAL-STREAM 'LOCAL-STREAM SELF CONN)
+                              (COM-LINK-READ LOCAL-STREAM 'LOCAL-STREAM SELF CONN)))
+                       (NIL)
+                     (IF (MEMQ CHAR '(#\BREAK #\HELP))
+                         (IF (COM-LINK-HANDLE-BREAK-OR-HELP
+                               (IF (EQ CHAR #\BREAK) 'BREAK 'HELP)
+                               LOCAL-STREAM REMOTE-HOST-STREAM SELF CONN)
+                             NIL
+                             (RETURN NIL))
+                         (PROGN (COM-LINK-PROCESS-CHAR LOCAL-STREAM CHAR)
+                                (FUNCALL REMOTE-HOST-STREAM ':TYO CHAR)
+                                (FUNCALL REMOTE-HOST-STREAM ':FORCE-OUTPUT)))))
                   ;Openning of connection failed...
                   (T
@@ -178 +176 @@
                                   (<- SELF ':MAKE-CONNECTION))
                                  (T (*THROW 'NUKE-THE-WORLD NIL))))
+                          ((Y-OR-N-P "Connect to another CADR? " LOCAL-STREAM)
+                           (LET ((NEW-CADR (<- CADR-MENU ':CHOOSE)))
+                             ; Sometimes using the menu changes the selected window....
+                             ; (shouldn't be this way)
+                             (IF (NEQ SELF SELECTED-WINDOW) (WINDOW-SELECT SELF))
+                             (COND (NEW-CADR       
+                                     (FUNCALL SELF ':MAKE-CONNECTION NEW-CADR)
+                                     (<- (FUNCALL SELF ':REMOTE-LISTEN-PROCESS) ':RESET))
+                                   ((*THROW 'NUKE-THE-WORLD NIL)))))
                           (T (*THROW 'NUKE-THE-WORLD NIL)))))))
   (<- SELF ':DEACTIVATE))                       ;If you gotta go, you gotta go...
@@ -236 +243 @@
         (CHAOS:CLOSE CONN)
         (LET ((NEW-CADR (<- CADR-MENU ':CHOOSE)))
+          ; Sometimes using the menu changes the selected window.... (shouldn't be this way)
+          (IF (NEQ WINDOW SELECTED-WINDOW) (WINDOW-SELECT WINDOW))
           (COND (NEW-CADR          
-                  (AND (NOT (STRINGP (<- WINDOW ':MAKE-CONNECTION NEW-CADR)))
-                       (<- (<- WINDOW ':REMOTE-LISTEN-PROCESS) ':RESET))
+                  (<- WINDOW ':MAKE-CONNECTION NEW-CADR)
+                  (<- (<- WINDOW ':REMOTE-LISTEN-PROCESS) ':RESET)
                   (RETURN NIL))
                 ((*THROW 'NUKE-THE-WORLD NIL)))))

trunk/lisp/lmio/disk.lisp

@@ -957 +957 @@
                   (UPDATE-PARTITION-COMMENT
                        PART
-                       (LET ((PATHNAME (FILE-SPREAD-PATHNAME (FUNCALL FILE ':NAME))))
-                         (FORMAT NIL "~A ~D" (THIRD PATHNAME)
-                                 (FUNCALL FILE ':GET ':VERSION)))
+                       (LET ((FILE-NAME (FUNCALL FILE ':NAME)))
+                         (FORMAT NIL "~A ~D"
+                                 (FUNCALL FILE-NAME ':NAME) (FUNCALL FILE ':GET ':VERSION)))
                        UNIT)
                   (CLOSE FILE)

trunk/lisp/lmio/dledit.lisp

@@ -341 +341 @@
   (LE-DISPLAY-LABEL LE-RQB LE-UNIT))
 
-(DEFUN LE-COM-CONTROL-D ()      ;Delete this partition
+(DEFUN LE-COM-CONTROL-K ()      ;Delete this partition
   (LET ((PLOC (LE-CURRENT-PARTITION)))
     (FORMAT T "~&Delete the ~S partition? " (GET-DISK-STRING LE-RQB PLOC 4))
@@ -438 +438 @@
 R read label from disk, W write label to disk, I initialize the label
 E edit selected item
-O add partition, D delete partition, S sort partitions
+O add partition, K delete partition, S sort partitions
 <END> exit"))

trunk/lisp/lmio/dribbl.lisp

@@ -1 @@
- ;;; Dribble Files                              -*- LISP -*-
+;;; -*-mode:lisp; package:system-internals; lowercase:t-*-
 
-;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
+;This binds STANDARD-OUTPUT and STANDARD-INPUT and enters a new read-eval-print
+;loop.  SETQ'ing them would be global for all processes and would leave you
+;totally shafted if the file connection broke.
 
-(DECLARE (SPECIAL DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT
-                  DRIBBLE-IO-PREVIOUS-STANDARD-INPUT
-                  DRIBBLE-IO-UNRCHF DRIBBLE-FILE))
+(defun dribble-start (filename &optional editor-p)
+  "Copy input and output to a file, or an editor buffer with second arg of T"
+  (let* ((standard-input (make-dribble-stream terminal-io
+                           (if (not editor-p) (open filename '(:write))
+                               (zwei:make-file-buffer-stream filename))))
+         (standard-output standard-input))
+    (*catch 'dribble-end
+            (lisp-top-level1 terminal-io))))
 
-(DEFUN DRIBBLE-START (FILE-NAME)
-  (COND ((BOUNDP 'DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT)
-         "ALREADY ATTACHED")
-        (T (SETQ DRIBBLE-FILE (OPEN FILE-NAME '(WRITE)))
-           (SETQ DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT
-                 STANDARD-OUTPUT)
-           (SETQ DRIBBLE-IO-PREVIOUS-STANDARD-INPUT
-                 STANDARD-INPUT)
-           (SETQ DRIBBLE-IO-UNRCHF
-                 NIL)
-           (SETQ STANDARD-OUTPUT
-                 'DRIBBLE-IO)
-           (SETQ STANDARD-INPUT    
-                 'DRIBBLE-IO)
-           NIL)))
+(defun dribble-end ()
+  (*throw 'dribble-end (funcall standard-input ':dribble-end)))
 
-(DEFUN DRIBBLE-END ()
-  (COND ((BOUNDP 'DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT)
-         (SETQ STANDARD-OUTPUT
-               DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT)
-         (SETQ STANDARD-INPUT
-               DRIBBLE-IO-PREVIOUS-STANDARD-INPUT)
-         (MAKUNBOUND 'DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT)
-         (CLOSE DRIBBLE-FILE)
-         NIL)
-        ("NOT ATTACHED")))
+(local-declare ((special *unrchf* *tv-stream* *file-stream* *rubout-handler-buffer*))
+(defun make-dribble-stream (*tv-stream* *file-stream*)
+  (let ((*unrchf* nil)
+        (*rubout-handler-buffer* (make-array nil 'art-string 100. nil '(0))))
+    (closure '(*unrchf* *tv-stream* *file-stream* *rubout-handler-buffer*)
+             'dribble-stream-io)))
 
-(DEFPROP DRIBBLE-IO T IO-STREAM-P)
-
-(DEFUN DRIBBLE-IO (OP &OPTIONAL ARG1 &REST REST)
-  (SELECTQ OP
-    (:TYO
-      (FUNCALL DRIBBLE-FILE ':TYO ARG1)
-      (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT OP ARG1))
-    (:TYI
-      (COND (DRIBBLE-IO-UNRCHF
-             (PROG1 DRIBBLE-IO-UNRCHF (SETQ DRIBBLE-IO-UNRCHF NIL)))
-            (T
-             (AND (SETQ ARG1 (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT OP ARG1))
-                  (FUNCALL DRIBBLE-FILE ':TYO ARG1))
-             ARG1)))
-    (:UNTYI
-      (SETQ DRIBBLE-IO-UNRCHF ARG1))
-    (:RUBOUT-HANDLER            ;Handling this is a bit of a kludge, needed to get echoing
-      (MULTIPLE-VALUE-CALL      ;If the user rubs out, funny stuff will get in the file...
-          (LEXPR-FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT OP ARG1 REST)))
-    (:READ-CURSORPOS            ;Handling this is a bit of a kludge, mostly for FORMAT.
-      (MULTIPLE-VALUE-CALL
-          (LEXPR-FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT OP ARG1 REST)))
-    (:WHICH-OPERATIONS
-     (LET ((OPS (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT ':WHICH-OPERATIONS)))
-       (COND ((MEMQ ':RUBOUT-HANDLER OPS)
-              (COND ((MEMQ ':READ-CURSORPOS OPS)
-                     '(:TYI :TYO :UNTYI :RUBOUT-HANDLER :READ-CURSORPOS))
-                    (T '(:TYI :TYO :UNTYI :RUBOUT-HANDLER))))
-             ((MEMQ ':READ-CURSORPOS OPS)
-              '(:TYI :TYO :UNTYI :READ-CURSORPOS))
-             (T '(:TYI :TYO :UNTYI)))))
-    (:PC-PPR (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT ':PC-PPR))
-    (OTHERWISE
-     (MULTIPLE-VALUE-CALL (STREAM-DEFAULT-HANDLER 'DRIBBLE-IO OP ARG1 REST)))))
+(defun dribble-stream-io (op &rest args)
+  (selectq op
+    ((:tyo :string-out :line-out :fresh-line)
+     (lexpr-funcall *tv-stream* op args)
+     (lexpr-funcall *file-stream* op args))
+    (:tyi
+     (if *unrchf*
+         (prog1 *unrchf* (setq *unrchf* nil))
+         (prog ()
+           (*catch (if rubout-handler 'rubout-handler 'dummy-tag)
+             (let ((ch (funcall *tv-stream* op)))
+               (and rubout-handler (array-push-extend *rubout-handler-buffer* ch))
+               (return ch)))
+           ;;get here if someone threw to rubout-handler
+           ;;reset our buffer and continue the throw
+           (store-array-leader 0 *rubout-handler-buffer* 0)
+           (*throw 'rubout-handler nil))))
+    (:untyi
+     (setq *unrchf* (car args)))
+    (:listen
+     (or *unrchf* (funcall *tv-stream* op)))
+    (:rubout-handler
+     (store-array-leader 0 *rubout-handler-buffer* 0)   ;reset the buffer
+     (prog (vals)
+       (setq vals (multiple-value-list (lexpr-funcall *tv-stream* op args)))
+       (funcall *file-stream* ':string-out *rubout-handler-buffer*)
+       (return-list vals)))
+    (:dribble-end
+     (close *file-stream*)
+     (and (memq ':get (funcall *file-stream* ':which-operations))
+          (funcall *file-stream* ':get ':unique-id)))
+    (otherwise
+     (lexpr-funcall *tv-stream* op args))))
+);local-declare

trunk/lisp/lmio/fnutil.lisp

@@ -19 +19 @@
 (DEFUN FILE-PARSE-NAME (NAMESTRING &OPTIONAL WITH-RESPECT-TO (DEFAULT T) DEFAULT-TYPE)
   (COND ((TYPEP NAMESTRING 'FILENAME) NAMESTRING)
-        ((STRINGP NAMESTRING)
+        (T
+         (SETQ NAMESTRING (STRING NAMESTRING))
          (LET ((COLON-IDX (DO ((IDX 0 (1+ IDX))
                                (CHAR))
@@ -66 +67 @@
                                                        (SUBSTRING NAMESTRING (1+ COLON-IDX))
                                                        NAMESTRING)
+                                 ':HOST-SPECIFIED (NOT (NULL COLON-IDX))
                                  ':DEFAULT-FILENAME DEFAULT
-                                 ':DEFAULT-TYPE DEFAULT-TYPE)))
-        (T (FERROR NIL "~S is not a valid namestring" NAMESTRING))))
+                                 ':DEFAULT-TYPE DEFAULT-TYPE)))))
 
 ;(DEFVAR FILE-HOST-DEFAULTS-ALIST NIL)
@@ -88 +89 @@
           (T (PUSH (CONS HOST FILENAME) FILE-HOST-DEFAULTS-ALIST)))))
 
+(DEFMACRO FILE-BIND-DEFAULTS BODY
+  `(LET ((FILE-HOST-DEFAULTS-ALIST (COPYALIST FILE-HOST-DEFAULTS-ALIST)))
+     . ,BODY))
+
 (DEFUN FILE-CREATE-FILENAME (HOST &REST ARGS &AUX HOST-FLAVOR)
   (SETQ HOST-FLAVOR (CDR (ASSOC HOST HOST-FILENAME-FLAVOR-ALIST)))
@@ -101 +106 @@
   :GETTABLE-INSTANCE-VARIABLES
   (:INITABLE-INSTANCE-VARIABLES HOST)
-  (:INIT-KEYWORDS :NAMESTRING :DEFAULT-FILENAME :DEFAULT-TYPE :SPECIAL-TYPE)
+  (:INIT-KEYWORDS :NAMESTRING :DEFAULT-FILENAME :DEFAULT-TYPE :SPECIAL-TYPE :HOST-SPECIFIED)
   (:DEFAULT-INIT-PLIST :NAMESTRING "")
   (:REQUIRED-METHODS :DIRECTORY :NAME :TYPE :VERSION :STRING-FOR-HOST
@@ -164 +169 @@
     ;; Use the currently existing functions to parse an ITS filename
     (SETQ NAMELIST (FILE-SPREAD-ITS-PATHNAME FILENAME))
-    (SETQ DEVICE (IF (NULL-S (FIRST NAMELIST))
-                     (FUNCALL DEFAULT-FILENAME ':DEVICE)
-                     (FIRST NAMELIST)))
+    (SETQ DEVICE (IF (GET PLIST ':HOST-SPECIFIED)
+                     "DSK"
+                     (IF (NULL-S (FIRST NAMELIST))
+                         (FUNCALL DEFAULT-FILENAME ':DEVICE)
+                         (FIRST NAMELIST))))
     (AND (OR (STRING-EQUAL DEVICE "DSK") (STRING-EQUAL DEVICE ""))
          ;; Device is host name if DSK specified

trunk/lisp/lmio/format.lisp

@@ -524 +524 @@
                              (RETURN (AREF SI:KBD-TRANSLATE-TABLE 1 I))))))
         ((SETQ CHNAME (DOTIMES (I 200)
-                        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 3 I))
+                        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 2 I))
                              (RETURN (AREF SI:KBD-NEW-TABLE 1 I)))))
          (SETQ NAME " (Top-"))
         ((SETQ CHNAME (DOTIMES (I 200)
+                        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 3 I))
+                             (RETURN (AREF SI:KBD-NEW-TABLE 0 I)))
                         (AND (= CHAR (AREF SI:KBD-NEW-TABLE 4 I))
-                             (RETURN (AREF SI:KBD-NEW-TABLE 0 I)))
-                        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 5 I))
                              (RETURN (AREF SI:KBD-NEW-TABLE 1 I)))))
          (SETQ NAME (IF (OR (AND (

trunk/lisp/lmio/grind.lisp

@@ -333 +333 @@
 
 (DEFUN GRIND-FORM (EXP LOC &AUX TEM)
-  (COND ((NLISTP EXP)                                   ;Atoms print very simply
+  (COND ((ATOM EXP)                                     ;Atoms print very simply
          (GRIND-PRIN1 EXP GRIND-IO LOC))
         ((EQ (CAR EXP) GRIND-DISPLACED)
          (GRIND-FORM (CADR EXP) (LOCF (CADR EXP))))
         ((AND (SYMBOLP (CAR EXP))                       ;Check for GRIND-MACRO
+              (OR (NULL (CDR EXP)) (NOT (ATOM (CDR EXP)))) ; but try not to get faked out
               (SETQ TEM (GET (CAR EXP) 'GRIND-MACRO)))
          (AND (*CATCH 'GRIND-MACRO-FAILED

trunk/lisp/lmio/mini.lisp

@@ -258 +258 @@
          ))))
 
+;;; Filename-parsing utilities which need to be in the cold load.
+
+;; Given a file name, return two symbols, first for the specific file
+;; and second for the group of files with that FN1, (FN2 will be ">")
+;; Must work both before and after packages exist.
+;; Must work if STRING or flavors not loaded, we use some kludges.
+(DEFUN GET-FILE-SYMBOLS (FILE-NAME)
+  (AND (STRINGP FILE-NAME)
+       (SETQ FILE-NAME (FILE-PARSE-NAME FILE-NAME)))
+  (FUNCALL FILE-NAME ':FILE-SYMBOLS))
+
+;Convert a pathname string into a path list: (dev dir fn1 fn2).
+;The elements of a path list are strings, or NIL for an
+;unspecified position.
+;Slash and control-Q () are quoting characters.  Colon, semicolon, space
+;and tab separate filename components.
+(DEFUN FILE-SPREAD-ITS-PATHNAME (PATHNAME &AUX DEV DEV-A DIR FN1 FN2)
+  (COND ((SYMBOLP PATHNAME)
+         (SETQ PATHNAME (GET-PNAME PATHNAME))))
+  (PROG ()
+    (COND ((STRINGP PATHNAME)
+           (DO ((I 0) (CH) (TEM) (NEXT) (LEN (STRING-LENGTH PATHNAME)) (J 0 (1+ J)))
+               ((> J LEN))
+             (SETQ CH (COND ((= J LEN) #\SP)
+                            (T (AR-1 PATHNAME J))))
+             (COND ((STRING-SEARCH-CHAR CH "//")
+                    (SETQ J (1+ J)))
+                   ;; Last two characters of the string are space and tab.
+                   ((SETQ TEM (STRING-SEARCH-CHAR CH ":;        "))
+                    (SETQ NEXT (STRING-UPCASE (SUBSTRING PATHNAME I J)))
+                    (COND ((NOT (ZEROP (STRING-LENGTH NEXT)))
+                           (SELECTQ TEM
+                             (0 (AND DEV (SETQ DEV-A DEV))
+                                (SETQ DEV NEXT))
+                             (1 (SETQ DIR NEXT))
+                             ((2 3) (COND (FN2)
+                                          (FN1 (SETQ FN2 NEXT))
+                                          (T (SETQ FN1 NEXT)))))))
+                    (SETQ I (1+ J)))))
+           (RETURN (LIST DEV DIR FN1 FN2) (OR DEV-A DEV)))
+          ((LISTP PATHNAME)                     ;MACLISP FILE-LISTS
+           (RETURN
+             (MAPCAR #'(LAMBDA (X) (AND X (STRING X))) ;LEAVE NILS FOR UNSPECIFIED COMPONENTS
+                     (COND ((LISTP (CAR PATHNAME))
+                            (COND ((CDAR PATHNAME)
+                                   (LIST (CAAR PATHNAME) (CADAR PATHNAME)  ;BOTH DEV AND DIR
+                                         (CADR PATHNAME) (CADDR PATHNAME)))
+                                  (T (LIST NIL (CAAR PATHNAME)  ;JUST DIR
+                                           (CADR PATHNAME) (CADDR PATHNAME)))))
+                           (T (LIST (CADDR PATHNAME) (CADDDR PATHNAME)     ;N1 N2 DEV DIR
+                                    (CAR PATHNAME) (CADR PATHNAME)))))
+             NIL))
+          (T (FERROR NIL "~S is not an acceptable pathname" PATHNAME)))))
+
+;;; Temporary definition, only work for ITS, no defaulting, etc.
+(LOCAL-DECLARE ((SPECIAL THE-FILE-NAME))
+(DEFUN FILE-PARSE-NAME (THE-FILE-NAME &REST IGNORE)
+  (IF (NOT (STRINGP THE-FILE-NAME)) THE-FILE-NAME
+      (CLOSURE '(THE-FILE-NAME) 'COLD-PARSE-FILE-NAME-INTERNAL)))
+
+(DEFUN COLD-PARSE-FILE-NAME-INTERNAL (OP &REST REST)
+  (SELECTQ OP
+    (:TYPE (FOURTH (FILE-SPREAD-ITS-PATHNAME THE-FILE-NAME)))
+    ((:STRING-FOR-PRINTING :STRING-FOR-HOST :STRING-FOR-WHOLINE) THE-FILE-NAME)
+    (:OPEN 
+     (LEXPR-FUNCALL #'FS:OPEN-CHAOS (FIRST (FILE-SPREAD-ITS-PATHNAME THE-FILE-NAME))
+                    'COLD-PARSE-FILE-NAME-INTERNAL REST))
+    (:FILE-SYMBOLS
+     (PROG (FILE-SYMBOL FILE-GROUP-SYMBOL)
+       (SETQ FILE-GROUP-SYMBOL (COND ((FBOUNDP 'NSUBSTRING)
+                                      (LET ((PATH (FILE-SPREAD-ITS-PATHNAME THE-FILE-NAME)))
+                                        (STRING-APPEND (FIRST PATH) ": "
+                                                       (SECOND PATH) "; "
+                                                       (THIRD PATH) " >")))
+                                     ((STRING-EQUAL THE-FILE-NAME "AI: LISPM; QFCTNS QFASL")
+                                      "AI: LISPM; QFCTNS >")
+                                     ((STRING-EQUAL THE-FILE-NAME "AI: LISPM2; STRING QFASL")
+                                      "AI: LISPM2; STRING >")
+                                     (T (FERROR NIL "File not known" THE-FILE-NAME))))
+       (COND ((FBOUNDP 'INTERN-LOCAL)
+              (SETQ FILE-SYMBOL (INTERN-LOCAL THE-FILE-NAME PKG-FILE-PACKAGE))
+              (SETQ FILE-GROUP-SYMBOL (INTERN-LOCAL FILE-GROUP-SYMBOL PKG-FILE-PACKAGE)))
+             (T
+              (SETQ FILE-SYMBOL (INTERN THE-FILE-NAME))
+              (SETQ FILE-GROUP-SYMBOL (INTERN FILE-GROUP-SYMBOL))
+              (RPLACA (PACKAGE-CELL-LOCATION FILE-SYMBOL) 'FILES)
+              (RPLACA (PACKAGE-CELL-LOCATION FILE-GROUP-SYMBOL) 'FILES)))
+       (RETURN FILE-SYMBOL FILE-GROUP-SYMBOL)))))
+);LOCAL-DECLARE
+
  ;Note that SETQ may not be used in the below
 (ADD-INITIALIZATION "MINI" '(SET' MINI-OPEN-P NIL) '(WARM FIRST))

trunk/lisp/lmio/ofnuti.lisp

@@ -11 +11 @@
 ;;; FILE-SET-FN2.
 
-(EVAL-WHEN (COMPILE) (SPECIAL FILE-LAST-DEVICE FILE-LAST-DIRECTORY FILE-LAST-FN1
-                              FILE-DSK-DEVICE-NAME))
-(SETQ FILE-LAST-DEVICE "DSK" FILE-LAST-DIRECTORY "LISPM"
-      FILE-LAST-FN1 "FOO" FILE-DSK-DEVICE-NAME "AI")
+(DEFVAR FILE-LAST-DEVICE "DSK")
+(DEFVAR FILE-LAST-DIRECTORY "LISPM")
+(DEFVAR FILE-LAST-FN1 "FOO")
+(DEFVAR FILE-DSK-DEVICE-NAME "AI")
 
 ;; Given a file name, return two symbols, first for the specific file

trunk/lisp/lmio/print.lisp

@@ -90 +90 @@
                (SYMBOLP (SETQ NSS (NAMED-STRUCTURE-SYMBOL EXP))))
           (COND ((AND (FBOUNDP NSS)
-                      (MEMQ ':PRINT (NAMED-STRUCTURE-INVOKE EXP ':WHICH-OPERATIONS)))
-                 (NAMED-STRUCTURE-INVOKE EXP ':PRINT STREAM I-PRINDEPTH SLASHIFY-P))
+                      (MEMQ ':PRINT-SELF (NAMED-STRUCTURE-INVOKE EXP ':WHICH-OPERATIONS)))
+                 (NAMED-STRUCTURE-INVOKE EXP ':PRINT-SELF STREAM I-PRINDEPTH SLASHIFY-P))
                 (T      ;Named structure that doesn't print itself
                   (PRINT-RAW-STRING (PTTBL-OPEN-RANDOM READTABLE) STREAM FASTP)
@@ -99 +99 @@
                   (PRINT-RAW-STRING (PTTBL-CLOSE-RANDOM READTABLE) STREAM FASTP))))
          ((AND (OR (= DATA-TYPE DTP-ENTITY) (= DATA-TYPE DTP-INSTANCE))
-               (ERRSET (<- EXP ':PRINT STREAM I-PRINDEPTH SLASHIFY-P) NIL)))          
+               (ERRSET (FUNCALL EXP ':PRINT-SELF STREAM I-PRINDEPTH SLASHIFY-P) NIL)))        
          ((ARRAYP EXP)
           (PRINT-RAW-STRING (PTTBL-OPEN-RANDOM READTABLE) STREAM FASTP)

trunk/lisp/lmio/qfile.lisp

@@ -1025 +1025 @@
   (FORMAT T "~&Retrying file operation.~%"))
 
-(DEFUN FORCE-USER-TO-LOGIN ()
+(DEFUN FORCE-USER-TO-LOGIN (&OPTIONAL (HOST USER-LOGIN-MACHINE))
   (COND ((OR (NULL USER-ID) (STRING-EQUAL USER-ID ""))
-         (FORMAT QUERY-IO "~&Login name: ")
-         (LOGIN (READLINE QUERY-IO)))))
+         (FORMAT QUERY-IO "~&Host is ~A, login name or host:? " HOST)
+         (LET ((INPUT (READLINE QUERY-IO)))
+           (COND ((= (AREF INPUT (1- (ARRAY-ACTIVE-LENGTH INPUT))) #/:)
+                  (SETQ HOST (SUBSTRING INPUT 0 (- (ARRAY-ACTIVE-LENGTH INPUT) 2)))
+                  (FORMAT QUERY-IO "~&Login name? ")
+                  (SETQ INPUT (READLINE QUERY-IO))))
+           (LOGIN INPUT HOST)))))
 
 ;;; Connection management
@@ -1141 +1146 @@
     (LEXPR-FUNCALL FUNCTION UNIT ARGS)))
 
+;;; Setup a user-id for the specified host.  Knows about ITS specially, as they
+;;; are one big happy family...
+(DEFVAR USER-UNAMES NIL)
+(DEFUN FILE-HOST-USER-ID (USER-ID HOST)
+  (AND (EQ (CDR (ASSOC USER-ID HOST-FILENAME-FLAVOR-ALIST)) 'ITS-FILENAME)
+       ;; All ITS' are the same
+       (SETQ HOST 'ITS
+             USER-ID (SUBSTRING USER-ID 0 6)))   
+  (LET ((AE (ASSOC HOST USER-UNAMES)))
+       (IF AE
+           (RPLACD AE USER-ID)
+           (PUSH (CONS HOST USER-ID) USER-UNAMES))))
+
 ;Send a LOGIN command to all open host units.  Called every time a user logs in or out.
 (DEFUN FILE-LOGIN (USER-ID)
+  (OR USER-ID (SETQ USER-UNAMES NIL))
   (DOLIST (ALIST-ENTRY FILE-HOST-ALIST)
     (HOST-UNIT-MAP-FUNCTION (SI:INIT-FORM ALIST-ENTRY)
@@ -1199 +1218 @@
          (LET ((PKT (CHAOS:GET-PKT))
                (ID (FILE-MAKE-TRANSACTION-ID)))
+           (COND ((AND USER-ID
+                       ;; This is really a login
+                       (NULL (SETQ USER-ID (CDR (ASSOC 'ITS USER-UNAMES)))))
+                  ;; We don't know about USER-ID for this host, so must ask
+                  (FORMAT QUERY-IO "~&ITS uname? ")
+                  (SETQ USER-ID (READLINE))
+                  (FILE-HOST-USER-ID USER-ID (HOST-UNIT-HOST UNIT))))
            (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " (IF USER-ID
                                                        (STRING-UPCASE USER-ID)
@@ -1299 +1325 @@
                    (PASSWORD)
                    (ID (FILE-MAKE-TRANSACTION-ID)))
-               (MULTIPLE-VALUE (USER-ID PASSWORD) (FILE-GET-TOPS20-PASSWORD USER-ID))
+               (MULTIPLE-VALUE (USER-ID PASSWORD)
+                               (FILE-GET-TOPS20-PASSWORD USER-ID (HOST-UNIT-HOST UNIT)))
                ;; LOGIN <UID> <PASS> <NULL ACCOUNT STRING>
                (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " USER-ID " " PASSWORD "  ")
@@ -1325 +1352 @@
                    (SETF (HOST-UNIT-MAX-DATA-CONNECTIONS UNIT) 8.)) )
 
-(DEFUN FILE-GET-TOPS20-PASSWORD (UID)
+(DEFUN FILE-GET-TOPS20-PASSWORD (UID HOST)
   (DO-NAMED EXIT
             () (())
-    (FORMAT QUERY-IO "~&Current login name is ~A.
-Type either password or loginname<space>password: " UID)
+    (SETQ UID (OR (CDR (ASSOC HOST USER-UNAMES)) UID))
+    (FORMAT QUERY-IO "~&Current login name is ~A for host ~A.
+Type either password or loginname<space>password: " UID HOST)
     (DO ((LINE (MAKE-ARRAY NIL 'ART-STRING 30 NIL '(0)))
          (CHAR))
@@ -1346 +1374 @@
              (SETQ CHAR (FUNCALL QUERY-IO ':TYI)))
             ((= CHAR #\CR)
+             (FILE-HOST-USER-ID UID HOST)
              (RETURN-FROM EXIT UID LINE)))
       (ARRAY-PUSH-EXTEND LINE CHAR))))

trunk/lisp/lmio/qio.lisp

@@ -262 +262 @@
                          (NULL TEM))
                       (ARRAY-PUSH-EXTEND BUF TEM)))))
-        (:TRIGGER-MORE NIL)
+;       (:HANDLE-EXCEPTIONS NIL)
         (OTHERWISE
          (RETURN (FERROR NIL "The stream operation ~S is not supported by ~S"

trunk/lisp/lmio/rddefs.lisp

@@ -5 +5 @@
 ;;; but you may have to recompile LMIO;RTC > as well (using QC and QCMP), and you may have
 ;;; to recompile LMIO;RDTBL > (using RTC).
+;;; Sorry, Alan, this defstruct needs colons which means it probably won't work in Maclisp
 
-(DEFSTRUCT (RDTBL ARRAY-LEADER
-                  (CONSTRUCTOR MAKE-RDTBL)
+(DEFSTRUCT (RDTBL :ARRAY-LEADER
+                  (:CONSTRUCTOR MAKE-RDTBL)
                   (MAKE-ARRAY (NIL 'ART-16B (RDTBL-ARRAY-DIMS)))
-                  (DEFAULT-POINTER RDTBL)
-                  (SIZE-MACRO RDTBL-SIZE))
+                  (:DEFAULT-POINTER RDTBL)
+                  (:SIZE-MACRO RDTBL-SIZE))
            RDTBL-FSM                                    ;sacred
            RDTBL-NAMED-STRUCTURE-SYMBOL

trunk/lisp/lmio/rdtbl.lisp

@@ -1 +1 @@
 ;;; -*-LISP-*-
+
+;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
 
 (DECLARE (ERROR '|If you are compiling this, and not using RTC, you are losing|))

trunk/lisp/lmio/read.lisp

@@ -263 +263 @@
 
 ;This is like READ, but ignores extra closeparens and eofs.
-(DEFUN READ-FOR-TOP-LEVEL (&AUX CH W-O)
+(DEFUN READ-FOR-TOP-LEVEL (&AUX W-O)
   (COND ((MEMQ ':READ (SETQ W-O (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)))
          (FUNCALL STANDARD-INPUT ':READ))
@@ -270 +270 @@
          (FUNCALL STANDARD-INPUT ':RUBOUT-HANDLER '() #'READ-FOR-TOP-LEVEL))
         ((PROG (THING TYPE SPLICEP XR-SHARP-ARGUMENT)
-           A (MULTIPLE-VALUE (THING TYPE) (XR-READ-THING STANDARD-INPUT))
+            A (MULTIPLE-VALUE (THING TYPE) (XR-READ-THING STANDARD-INPUT))
               (COND ((EQ TYPE 'READER-MACRO)
                      (MULTIPLE-VALUE (THING TYPE SPLICEP)
@@ -281 +281 @@
                             (FERROR NIL 
                                     "The special token ~S was read in at top level" THING)))))
-               (RETURN THING TYPE)))))
+              (RETURN THING TYPE)))))
 
 ;READ is almost like XR-READ-THING except READER-MACROs are invoked and SPECIAL-TOKENS

trunk/lisp/lmio/rtc.lisp

@@ -1016 +1016 @@
             (SETQ FSM (RTC-MAKE-FSM LIST))
              (SETQ RDTBL (MAKE-RDTBL))
-             (DO X 0 (1+ X) (= X (RDTBL-ARRAY-SIZE))
+             (DO X 0 (1+ X) (= X RDTBL-ARRAY-SIZE)
                  (SETF (RDTBL-BITS RDTBL X) 0)
                  (SETF (RDTBL-CODE RDTBL X) 0)
@@ -1199 +1199 @@
              (ZERID NIL)
              (LEADER-SIZE (RDTBL-SIZE))
-             (LEN (RDTBL-ARRAY-SIZE))
+             (LEN RDTBL-ARRAY-SIZE)
              (FILENAME (MERGEF '((* *) * QFASL) INFILENAME)))
             (FASD-OPEN FILENAME)

trunk/lisp/lmio/rtcmac.lisp

@@ -43 +43 @@
            (PTTBL-PACKAGE-CHAR          #/:     )
            RDTBL-/#-MACRO-ALIST
-           (RDTBL-ARRAY (CREATE-ARRAY 3 (RDTBL-ARRAY-SIZE))))
+           (RDTBL-ARRAY (CREATE-ARRAY 3 RDTBL-ARRAY-SIZE)))
 
-(DEFMACRO RDTBL-ARRAY-SIZE () '220)
+(DECLARE (SPECIAL RDTBL-ARRAY-SIZE))
+(SETQ RDTBL-ARRAY-SIZE 240)
 
 (DEFMACRO RDTBL-SIZE () `',(1- (RDTBL-SIZE+1)))
@@ -63 +64 @@
 (DEFMACRO IF-FOR-LISPM (&REST FOO)
     `(COMMENT THIS IS MACLISP))
+

trunk/lisp/lmio/unibus.lisp

@@ -47 +47 @@
     (%P-DPB-OFFSET BUFFER-START %%Q-POINTER CHAN %UNIBUS-CHANNEL-BUFFER-IN-PTR)
     (%P-DPB-OFFSET BUFFER-START %%Q-POINTER CHAN %UNIBUS-CHANNEL-BUFFER-OUT-PTR))
-  (DO () ((%CHANGE-PAGE-STATUS CHAN %PHT-SWAP-STATUS-WIRED NIL))
-    (%P-LDB 1 CHAN))
+  (WIRE-PAGE CHAN)
   (WITHOUT-INTERRUPTS
        (%P-DPB-OFFSET (SYSTEM-COMMUNICATION-AREA %SYS-COM-UNIBUS-INTERRUPT-LIST)
@@ -58 +57 @@
   (AND CHAN
        (WITHOUT-INTERRUPTS
-            (%CHANGE-PAGE-STATUS CHAN %PHT-SWAP-STATUS-NORMAL NIL)
+            (UNWIRE-PAGE CHAN)
             (DO ((X (%POINTER (SYSTEM-COMMUNICATION-AREA %SYS-COM-UNIBUS-INTERRUPT-LIST))
                     (%P-LDB %%Q-POINTER (+ X %UNIBUS-CHANNEL-LINK)))