Changeset 235

Show
Ignore:
Timestamp:
08/18/11 06:04:02 (3 years ago)
Author:
rjs
Message:

Update.

Location:
trunk/lisp/lmio
Files:
21 modified

Legend:

Unmodified
Added
Removed
  • trunk/lisp/lmio/chsaux.lisp

    r234 r235  
    650650               HOST (NSUBSTRING DESTINATION (1+ HOST) (STRING-LENGTH DESTINATION)))) 
    651651        (T (SETQ PERSON "anyone"  HOST DESTINATION))) 
    652   (SI:FORCE-USER-TO-LOGIN) 
     652  (FS:FORCE-USER-TO-LOGIN) 
    653653  (COND ((NULL MSG) 
    654654         (FORMAT T "~%Message: (terminate with End)~%") 
     
    704704                          (// IDLE 60.) 
    705705                          (\ IDLE 60.) 
    706                           SI:USER-PERSONAL-NAME-FIRST-NAME-FIRST 
    707                           SI:USER-GROUP-AFFILIATION)))) 
     706                          FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST 
     707                          FS:USER-GROUP-AFFILIATION)))) 
    708708  (FAST-ANSWER-STRING "FINGER" GIVE-FINGER-SAVED-STRING)) 
    709709 
     
    720720           "~6A ~C ~22A ~6A ~:[    ~3*~;~:[~D:~2,48D~;  ~*~D~]~]     ~A" 
    721721           USER-ID 
    722            SI:USER-GROUP-AFFILIATION 
    723            SI:USER-PERSONAL-NAME-FIRST-NAME-FIRST 
     722           FS:USER-GROUP-AFFILIATION 
     723           FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST 
    724724           MY-NAME-STRING 
    725725           (NOT (ZEROP IDLE)) 
  • trunk/lisp/lmio/chsncp.lisp

    r234 r235  
    640640  ;; This process runs all Time response actions such as PROBEs and Retransmission. 
    641641        BACKGROUND  (PROCESS-CREATE "Chaos Background") 
    642         RECEIVER (PROCESS-CREATE "Chaos Reciever" ':SIMPLE-P T) 
     642        RECEIVER (PROCESS-CREATE "Chaos Receiver" ':SIMPLE-P T) 
    643643 
    644644        ) 
     
    16371637    (COND (RESERVED-INT-PKT 
    16381638            (FERROR NIL "Int PKT about to be lost!"))) ;Hopefully this will get printed 
     1639    (SI:SET-PROCESS-WAIT CURRENT-PROCESS #'(LAMBDA () (NOT (OR (NULL ENABLE) 
     1640                                                               (NULL (INT-RECEIVE-LIST))))) 
     1641                         NIL) 
     1642    (SETF (SI:PROCESS-WHOSTATE CURRENT-PROCESS) "Chaos Packet") 
    16391643    )) 
    16401644 
  • trunk/lisp/lmio/chstbl.lisp

    r234 r235  
    6060                       (415 . "936 Lisp Machine Factory x6703")         ;LM16 
    6161                       (416 . "936 Lisp Machine Factory x6703")         ;LM15 
    62                        (417 . "936 Lisp Machine Factory x6703")         ;LM14 
    63                        (421 . "936 Lisp Machine Factory x6703")         ;LM13 
     62                       (417 . "38-301 EE-CS Machine Room x5624")        ;LM14 
     63                       (421 . "38-301 EE-CS Machine Room x5624")        ;LM13 
    6464                       (422 . "36-626 Speech Lab x4672")                ;LM12 
    6565                       (423 . "38-350 EE-CS Terminal Room x4650")       ;LM11 
     
    8181                                 (415 MIT-NE43 9)       ;LM16 
    8282                                 (416 MIT-NE43 9)       ;LM15 
    83                                  (417 MIT-NE43 9)       ;LM14 
    84                                  (421 MIT-NE43 9)       ;LM13 
     83                                 (417 MIT-38 3)         ;LM14 
     84                                 (421 MIT-38 3)         ;LM13 
    8585                                 (422 MIT-36 6)         ;LM12 
    8686                                 (423 MIT-38 3)         ;LM11 
  • trunk/lisp/lmio/comlnk.lisp

    r234 r235  
    155155            (COND ((NOT (STRINGP CONN))         ;Connection Succeeded. 
    156156                   ;The main loop, read, echo, and send characters. 
    157                    (DO ((CHAR 0.)(QUITTING-A-CONNECTION NIL)) 
    158                        (QUITTING-A-CONNECTION) 
    159                      (SETQ CHAR (COM-LINK-READ LOCAL-STREAM 'LOCAL-STREAM SELF CONN)) 
    160                      (COND ((EQ CHAR #\BREAK) 
    161                             (SETQ QUITTING-A-CONNECTION 
    162                                   (COM-LINK-HANDLE-BREAK-OR-HELP 
    163                                    'BREAK LOCAL-STREAM REMOTE-HOST-STREAM SELF CONN))) 
    164                            ((EQ CHAR #\HELP) 
    165                             (SETQ QUITTING-A-CONNECTION 
    166                                   (COM-LINK-HANDLE-BREAK-OR-HELP 
    167                                    'HELP LOCAL-STREAM REMOTE-HOST-STREAM SELF CONN))) 
    168                            (T (COM-LINK-PROCESS-CHAR LOCAL-STREAM CHAR) 
    169                               (FUNCALL REMOTE-HOST-STREAM ':TYO CHAR) 
    170                               (FUNCALL REMOTE-HOST-STREAM ':FORCE-OUTPUT))))) 
     157                   (DO ((CHAR (COM-LINK-READ LOCAL-STREAM 'LOCAL-STREAM SELF CONN) 
     158                              (COM-LINK-READ LOCAL-STREAM 'LOCAL-STREAM SELF CONN))) 
     159                       (NIL) 
     160                     (IF (MEMQ CHAR '(#\BREAK #\HELP)) 
     161                         (IF (COM-LINK-HANDLE-BREAK-OR-HELP 
     162                               (IF (EQ CHAR #\BREAK) 'BREAK 'HELP) 
     163                               LOCAL-STREAM REMOTE-HOST-STREAM SELF CONN) 
     164                             NIL 
     165                             (RETURN NIL)) 
     166                         (PROGN (COM-LINK-PROCESS-CHAR LOCAL-STREAM CHAR) 
     167                                (FUNCALL REMOTE-HOST-STREAM ':TYO CHAR) 
     168                                (FUNCALL REMOTE-HOST-STREAM ':FORCE-OUTPUT))))) 
    171169                  ;Openning of connection failed... 
    172170                  (T 
     
    178176                                  (<- SELF ':MAKE-CONNECTION)) 
    179177                                 (T (*THROW 'NUKE-THE-WORLD NIL)))) 
     178                          ((Y-OR-N-P "Connect to another CADR? " LOCAL-STREAM) 
     179                           (LET ((NEW-CADR (<- CADR-MENU ':CHOOSE))) 
     180                             ; Sometimes using the menu changes the selected window.... 
     181                             ; (shouldn't be this way) 
     182                             (IF (NEQ SELF SELECTED-WINDOW) (WINDOW-SELECT SELF)) 
     183                             (COND (NEW-CADR        
     184                                     (FUNCALL SELF ':MAKE-CONNECTION NEW-CADR) 
     185                                     (<- (FUNCALL SELF ':REMOTE-LISTEN-PROCESS) ':RESET)) 
     186                                   ((*THROW 'NUKE-THE-WORLD NIL))))) 
    180187                          (T (*THROW 'NUKE-THE-WORLD NIL))))))) 
    181188  (<- SELF ':DEACTIVATE))                       ;If you gotta go, you gotta go... 
     
    236243        (CHAOS:CLOSE CONN) 
    237244        (LET ((NEW-CADR (<- CADR-MENU ':CHOOSE))) 
     245          ; Sometimes using the menu changes the selected window.... (shouldn't be this way) 
     246          (IF (NEQ WINDOW SELECTED-WINDOW) (WINDOW-SELECT WINDOW)) 
    238247          (COND (NEW-CADR           
    239                   (AND (NOT (STRINGP (<- WINDOW ':MAKE-CONNECTION NEW-CADR))) 
    240                        (<- (<- WINDOW ':REMOTE-LISTEN-PROCESS) ':RESET)) 
     248                  (<- WINDOW ':MAKE-CONNECTION NEW-CADR) 
     249                  (<- (<- WINDOW ':REMOTE-LISTEN-PROCESS) ':RESET) 
    241250                  (RETURN NIL)) 
    242251                ((*THROW 'NUKE-THE-WORLD NIL))))) 
  • trunk/lisp/lmio/disk.lisp

    r234 r235  
    957957                  (UPDATE-PARTITION-COMMENT 
    958958                       PART 
    959                        (LET ((PATHNAME (FILE-SPREAD-PATHNAME (FUNCALL FILE ':NAME)))) 
    960                          (FORMAT NIL "~A ~D" (THIRD PATHNAME) 
    961                                  (FUNCALL FILE ':GET ':VERSION))) 
     959                       (LET ((FILE-NAME (FUNCALL FILE ':NAME))) 
     960                         (FORMAT NIL "~A ~D" 
     961                                 (FUNCALL FILE-NAME ':NAME) (FUNCALL FILE ':GET ':VERSION))) 
    962962                       UNIT) 
    963963                  (CLOSE FILE) 
  • trunk/lisp/lmio/dledit.lisp

    r234 r235  
    341341  (LE-DISPLAY-LABEL LE-RQB LE-UNIT)) 
    342342 
    343 (DEFUN LE-COM-CONTROL-D ()      ;Delete this partition 
     343(DEFUN LE-COM-CONTROL-K ()      ;Delete this partition 
    344344  (LET ((PLOC (LE-CURRENT-PARTITION))) 
    345345    (FORMAT T "~&Delete the ~S partition? " (GET-DISK-STRING LE-RQB PLOC 4)) 
     
    438438R read label from disk, W write label to disk, I initialize the label 
    439439E edit selected item 
    440 O add partition, D delete partition, S sort partitions 
     440O add partition, K delete partition, S sort partitions 
    441441<END> exit")) 
  • trunk/lisp/lmio/dribbl.lisp

    r234 r235  
    1  ;;; Dribble Files                              -*- LISP -*- 
     1;;; -*-mode:lisp; package:system-internals; lowercase:t-*- 
    22 
    3 ;       ** (c) Copyright 1980 Massachusetts Institute of Technology ** 
     3;This binds STANDARD-OUTPUT and STANDARD-INPUT and enters a new read-eval-print 
     4;loop.  SETQ'ing them would be global for all processes and would leave you 
     5;totally shafted if the file connection broke. 
    46 
    5 (DECLARE (SPECIAL DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT 
    6                   DRIBBLE-IO-PREVIOUS-STANDARD-INPUT 
    7                   DRIBBLE-IO-UNRCHF DRIBBLE-FILE)) 
     7(defun dribble-start (filename &optional editor-p) 
     8  "Copy input and output to a file, or an editor buffer with second arg of T" 
     9  (let* ((standard-input (make-dribble-stream terminal-io 
     10                           (if (not editor-p) (open filename '(:write)) 
     11                               (zwei:make-file-buffer-stream filename)))) 
     12         (standard-output standard-input)) 
     13    (*catch 'dribble-end 
     14            (lisp-top-level1 terminal-io)))) 
    815 
    9 (DEFUN DRIBBLE-START (FILE-NAME) 
    10   (COND ((BOUNDP 'DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT) 
    11          "ALREADY ATTACHED") 
    12         (T (SETQ DRIBBLE-FILE (OPEN FILE-NAME '(WRITE))) 
    13            (SETQ DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT 
    14                  STANDARD-OUTPUT) 
    15            (SETQ DRIBBLE-IO-PREVIOUS-STANDARD-INPUT 
    16                  STANDARD-INPUT) 
    17            (SETQ DRIBBLE-IO-UNRCHF 
    18                  NIL) 
    19            (SETQ STANDARD-OUTPUT 
    20                  'DRIBBLE-IO) 
    21            (SETQ STANDARD-INPUT     
    22                  'DRIBBLE-IO) 
    23            NIL))) 
     16(defun dribble-end () 
     17  (*throw 'dribble-end (funcall standard-input ':dribble-end))) 
    2418 
    25 (DEFUN DRIBBLE-END () 
    26   (COND ((BOUNDP 'DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT) 
    27          (SETQ STANDARD-OUTPUT 
    28                DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT) 
    29          (SETQ STANDARD-INPUT 
    30                DRIBBLE-IO-PREVIOUS-STANDARD-INPUT) 
    31          (MAKUNBOUND 'DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT) 
    32          (CLOSE DRIBBLE-FILE) 
    33          NIL) 
    34         ("NOT ATTACHED"))) 
     19(local-declare ((special *unrchf* *tv-stream* *file-stream* *rubout-handler-buffer*)) 
     20(defun make-dribble-stream (*tv-stream* *file-stream*) 
     21  (let ((*unrchf* nil) 
     22        (*rubout-handler-buffer* (make-array nil 'art-string 100. nil '(0)))) 
     23    (closure '(*unrchf* *tv-stream* *file-stream* *rubout-handler-buffer*) 
     24             'dribble-stream-io))) 
    3525 
    36 (DEFPROP DRIBBLE-IO T IO-STREAM-P) 
    37  
    38 (DEFUN DRIBBLE-IO (OP &OPTIONAL ARG1 &REST REST) 
    39   (SELECTQ OP 
    40     (:TYO 
    41       (FUNCALL DRIBBLE-FILE ':TYO ARG1) 
    42       (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-OUTPUT OP ARG1)) 
    43     (:TYI 
    44       (COND (DRIBBLE-IO-UNRCHF 
    45              (PROG1 DRIBBLE-IO-UNRCHF (SETQ DRIBBLE-IO-UNRCHF NIL))) 
    46             (T 
    47              (AND (SETQ ARG1 (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT OP ARG1)) 
    48                   (FUNCALL DRIBBLE-FILE ':TYO ARG1)) 
    49              ARG1))) 
    50     (:UNTYI 
    51       (SETQ DRIBBLE-IO-UNRCHF ARG1)) 
    52     (:RUBOUT-HANDLER            ;Handling this is a bit of a kludge, needed to get echoing 
    53       (MULTIPLE-VALUE-CALL      ;If the user rubs out, funny stuff will get in the file... 
    54           (LEXPR-FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT OP ARG1 REST))) 
    55     (:READ-CURSORPOS            ;Handling this is a bit of a kludge, mostly for FORMAT. 
    56       (MULTIPLE-VALUE-CALL 
    57           (LEXPR-FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT OP ARG1 REST))) 
    58     (:WHICH-OPERATIONS 
    59      (LET ((OPS (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT ':WHICH-OPERATIONS))) 
    60        (COND ((MEMQ ':RUBOUT-HANDLER OPS) 
    61               (COND ((MEMQ ':READ-CURSORPOS OPS) 
    62                      '(:TYI :TYO :UNTYI :RUBOUT-HANDLER :READ-CURSORPOS)) 
    63                     (T '(:TYI :TYO :UNTYI :RUBOUT-HANDLER)))) 
    64              ((MEMQ ':READ-CURSORPOS OPS) 
    65               '(:TYI :TYO :UNTYI :READ-CURSORPOS)) 
    66              (T '(:TYI :TYO :UNTYI))))) 
    67     (:PC-PPR (FUNCALL DRIBBLE-IO-PREVIOUS-STANDARD-INPUT ':PC-PPR)) 
    68     (OTHERWISE 
    69      (MULTIPLE-VALUE-CALL (STREAM-DEFAULT-HANDLER 'DRIBBLE-IO OP ARG1 REST))))) 
     26(defun dribble-stream-io (op &rest args) 
     27  (selectq op 
     28    ((:tyo :string-out :line-out :fresh-line) 
     29     (lexpr-funcall *tv-stream* op args) 
     30     (lexpr-funcall *file-stream* op args)) 
     31    (:tyi 
     32     (if *unrchf* 
     33         (prog1 *unrchf* (setq *unrchf* nil)) 
     34         (prog () 
     35           (*catch (if rubout-handler 'rubout-handler 'dummy-tag) 
     36             (let ((ch (funcall *tv-stream* op))) 
     37               (and rubout-handler (array-push-extend *rubout-handler-buffer* ch)) 
     38               (return ch))) 
     39           ;;get here if someone threw to rubout-handler 
     40           ;;reset our buffer and continue the throw 
     41           (store-array-leader 0 *rubout-handler-buffer* 0) 
     42           (*throw 'rubout-handler nil)))) 
     43    (:untyi 
     44     (setq *unrchf* (car args))) 
     45    (:listen 
     46     (or *unrchf* (funcall *tv-stream* op))) 
     47    (:rubout-handler 
     48     (store-array-leader 0 *rubout-handler-buffer* 0)   ;reset the buffer 
     49     (prog (vals) 
     50       (setq vals (multiple-value-list (lexpr-funcall *tv-stream* op args))) 
     51       (funcall *file-stream* ':string-out *rubout-handler-buffer*) 
     52       (return-list vals))) 
     53    (:dribble-end 
     54     (close *file-stream*) 
     55     (and (memq ':get (funcall *file-stream* ':which-operations)) 
     56          (funcall *file-stream* ':get ':unique-id))) 
     57    (otherwise 
     58     (lexpr-funcall *tv-stream* op args)))) 
     59);local-declare 
  • trunk/lisp/lmio/fnutil.lisp

    r234 r235  
    1919(DEFUN FILE-PARSE-NAME (NAMESTRING &OPTIONAL WITH-RESPECT-TO (DEFAULT T) DEFAULT-TYPE) 
    2020  (COND ((TYPEP NAMESTRING 'FILENAME) NAMESTRING) 
    21         ((STRINGP NAMESTRING) 
     21        (T 
     22         (SETQ NAMESTRING (STRING NAMESTRING)) 
    2223         (LET ((COLON-IDX (DO ((IDX 0 (1+ IDX)) 
    2324                               (CHAR)) 
     
    6667                                                       (SUBSTRING NAMESTRING (1+ COLON-IDX)) 
    6768                                                       NAMESTRING) 
     69                                 ':HOST-SPECIFIED (NOT (NULL COLON-IDX)) 
    6870                                 ':DEFAULT-FILENAME DEFAULT 
    69                                  ':DEFAULT-TYPE DEFAULT-TYPE))) 
    70         (T (FERROR NIL "~S is not a valid namestring" NAMESTRING)))) 
     71                                 ':DEFAULT-TYPE DEFAULT-TYPE))))) 
    7172 
    7273;(DEFVAR FILE-HOST-DEFAULTS-ALIST NIL) 
     
    8889          (T (PUSH (CONS HOST FILENAME) FILE-HOST-DEFAULTS-ALIST))))) 
    8990 
     91(DEFMACRO FILE-BIND-DEFAULTS BODY 
     92  `(LET ((FILE-HOST-DEFAULTS-ALIST (COPYALIST FILE-HOST-DEFAULTS-ALIST))) 
     93     . ,BODY)) 
     94 
    9095(DEFUN FILE-CREATE-FILENAME (HOST &REST ARGS &AUX HOST-FLAVOR) 
    9196  (SETQ HOST-FLAVOR (CDR (ASSOC HOST HOST-FILENAME-FLAVOR-ALIST))) 
     
    101106  :GETTABLE-INSTANCE-VARIABLES 
    102107  (:INITABLE-INSTANCE-VARIABLES HOST) 
    103   (:INIT-KEYWORDS :NAMESTRING :DEFAULT-FILENAME :DEFAULT-TYPE :SPECIAL-TYPE) 
     108  (:INIT-KEYWORDS :NAMESTRING :DEFAULT-FILENAME :DEFAULT-TYPE :SPECIAL-TYPE :HOST-SPECIFIED) 
    104109  (:DEFAULT-INIT-PLIST :NAMESTRING "") 
    105110  (:REQUIRED-METHODS :DIRECTORY :NAME :TYPE :VERSION :STRING-FOR-HOST 
     
    164169    ;; Use the currently existing functions to parse an ITS filename 
    165170    (SETQ NAMELIST (FILE-SPREAD-ITS-PATHNAME FILENAME)) 
    166     (SETQ DEVICE (IF (NULL-S (FIRST NAMELIST)) 
    167                      (FUNCALL DEFAULT-FILENAME ':DEVICE) 
    168                      (FIRST NAMELIST))) 
     171    (SETQ DEVICE (IF (GET PLIST ':HOST-SPECIFIED) 
     172                     "DSK" 
     173                     (IF (NULL-S (FIRST NAMELIST)) 
     174                         (FUNCALL DEFAULT-FILENAME ':DEVICE) 
     175                         (FIRST NAMELIST)))) 
    169176    (AND (OR (STRING-EQUAL DEVICE "DSK") (STRING-EQUAL DEVICE "")) 
    170177         ;; Device is host name if DSK specified 
  • trunk/lisp/lmio/format.lisp

    r234 r235  
    524524                             (RETURN (AREF SI:KBD-TRANSLATE-TABLE 1 I)))))) 
    525525        ((SETQ CHNAME (DOTIMES (I 200) 
    526                         (AND (= CHAR (AREF SI:KBD-NEW-TABLE 3 I)) 
     526                        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 2 I)) 
    527527                             (RETURN (AREF SI:KBD-NEW-TABLE 1 I))))) 
    528528         (SETQ NAME " (Top-")) 
    529529        ((SETQ CHNAME (DOTIMES (I 200) 
     530                        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 3 I)) 
     531                             (RETURN (AREF SI:KBD-NEW-TABLE 0 I))) 
    530532                        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 4 I)) 
    531                              (RETURN (AREF SI:KBD-NEW-TABLE 0 I))) 
    532                         (AND (= CHAR (AREF SI:KBD-NEW-TABLE 5 I)) 
    533533                             (RETURN (AREF SI:KBD-NEW-TABLE 1 I))))) 
    534534         (SETQ NAME (IF (OR (AND ( 
  • trunk/lisp/lmio/grind.lisp

    r234 r235  
    333333 
    334334(DEFUN GRIND-FORM (EXP LOC &AUX TEM) 
    335   (COND ((NLISTP EXP)                                   ;Atoms print very simply 
     335  (COND ((ATOM EXP)                                     ;Atoms print very simply 
    336336         (GRIND-PRIN1 EXP GRIND-IO LOC)) 
    337337        ((EQ (CAR EXP) GRIND-DISPLACED) 
    338338         (GRIND-FORM (CADR EXP) (LOCF (CADR EXP)))) 
    339339        ((AND (SYMBOLP (CAR EXP))                       ;Check for GRIND-MACRO 
     340              (OR (NULL (CDR EXP)) (NOT (ATOM (CDR EXP)))) ; but try not to get faked out 
    340341              (SETQ TEM (GET (CAR EXP) 'GRIND-MACRO))) 
    341342         (AND (*CATCH 'GRIND-MACRO-FAILED 
  • trunk/lisp/lmio/mini.lisp

    r234 r235  
    258258         )))) 
    259259 
     260;;; Filename-parsing utilities which need to be in the cold load. 
     261 
     262;; Given a file name, return two symbols, first for the specific file 
     263;; and second for the group of files with that FN1, (FN2 will be ">") 
     264;; Must work both before and after packages exist. 
     265;; Must work if STRING or flavors not loaded, we use some kludges. 
     266(DEFUN GET-FILE-SYMBOLS (FILE-NAME) 
     267  (AND (STRINGP FILE-NAME) 
     268       (SETQ FILE-NAME (FILE-PARSE-NAME FILE-NAME))) 
     269  (FUNCALL FILE-NAME ':FILE-SYMBOLS)) 
     270 
     271;Convert a pathname string into a path list: (dev dir fn1 fn2). 
     272;The elements of a path list are strings, or NIL for an 
     273;unspecified position. 
     274;Slash and control-Q () are quoting characters.  Colon, semicolon, space 
     275;and tab separate filename components. 
     276(DEFUN FILE-SPREAD-ITS-PATHNAME (PATHNAME &AUX DEV DEV-A DIR FN1 FN2) 
     277  (COND ((SYMBOLP PATHNAME) 
     278         (SETQ PATHNAME (GET-PNAME PATHNAME)))) 
     279  (PROG () 
     280    (COND ((STRINGP PATHNAME) 
     281           (DO ((I 0) (CH) (TEM) (NEXT) (LEN (STRING-LENGTH PATHNAME)) (J 0 (1+ J))) 
     282               ((> J LEN)) 
     283             (SETQ CH (COND ((= J LEN) #\SP) 
     284                            (T (AR-1 PATHNAME J)))) 
     285             (COND ((STRING-SEARCH-CHAR CH "//") 
     286                    (SETQ J (1+ J))) 
     287                   ;; Last two characters of the string are space and tab. 
     288                   ((SETQ TEM (STRING-SEARCH-CHAR CH ":;        ")) 
     289                    (SETQ NEXT (STRING-UPCASE (SUBSTRING PATHNAME I J))) 
     290                    (COND ((NOT (ZEROP (STRING-LENGTH NEXT))) 
     291                           (SELECTQ TEM 
     292                             (0 (AND DEV (SETQ DEV-A DEV)) 
     293                                (SETQ DEV NEXT)) 
     294                             (1 (SETQ DIR NEXT)) 
     295                             ((2 3) (COND (FN2) 
     296                                          (FN1 (SETQ FN2 NEXT)) 
     297                                          (T (SETQ FN1 NEXT))))))) 
     298                    (SETQ I (1+ J))))) 
     299           (RETURN (LIST DEV DIR FN1 FN2) (OR DEV-A DEV))) 
     300          ((LISTP PATHNAME)                     ;MACLISP FILE-LISTS 
     301           (RETURN 
     302             (MAPCAR #'(LAMBDA (X) (AND X (STRING X))) ;LEAVE NILS FOR UNSPECIFIED COMPONENTS 
     303                     (COND ((LISTP (CAR PATHNAME)) 
     304                            (COND ((CDAR PATHNAME) 
     305                                   (LIST (CAAR PATHNAME) (CADAR PATHNAME)  ;BOTH DEV AND DIR 
     306                                         (CADR PATHNAME) (CADDR PATHNAME))) 
     307                                  (T (LIST NIL (CAAR PATHNAME)  ;JUST DIR 
     308                                           (CADR PATHNAME) (CADDR PATHNAME))))) 
     309                           (T (LIST (CADDR PATHNAME) (CADDDR PATHNAME)     ;N1 N2 DEV DIR 
     310                                    (CAR PATHNAME) (CADR PATHNAME))))) 
     311             NIL)) 
     312          (T (FERROR NIL "~S is not an acceptable pathname" PATHNAME))))) 
     313 
     314;;; Temporary definition, only work for ITS, no defaulting, etc. 
     315(LOCAL-DECLARE ((SPECIAL THE-FILE-NAME)) 
     316(DEFUN FILE-PARSE-NAME (THE-FILE-NAME &REST IGNORE) 
     317  (IF (NOT (STRINGP THE-FILE-NAME)) THE-FILE-NAME 
     318      (CLOSURE '(THE-FILE-NAME) 'COLD-PARSE-FILE-NAME-INTERNAL))) 
     319 
     320(DEFUN COLD-PARSE-FILE-NAME-INTERNAL (OP &REST REST) 
     321  (SELECTQ OP 
     322    (:TYPE (FOURTH (FILE-SPREAD-ITS-PATHNAME THE-FILE-NAME))) 
     323    ((:STRING-FOR-PRINTING :STRING-FOR-HOST :STRING-FOR-WHOLINE) THE-FILE-NAME) 
     324    (:OPEN  
     325     (LEXPR-FUNCALL #'FS:OPEN-CHAOS (FIRST (FILE-SPREAD-ITS-PATHNAME THE-FILE-NAME)) 
     326                    'COLD-PARSE-FILE-NAME-INTERNAL REST)) 
     327    (:FILE-SYMBOLS 
     328     (PROG (FILE-SYMBOL FILE-GROUP-SYMBOL) 
     329       (SETQ FILE-GROUP-SYMBOL (COND ((FBOUNDP 'NSUBSTRING) 
     330                                      (LET ((PATH (FILE-SPREAD-ITS-PATHNAME THE-FILE-NAME))) 
     331                                        (STRING-APPEND (FIRST PATH) ": " 
     332                                                       (SECOND PATH) "; " 
     333                                                       (THIRD PATH) " >"))) 
     334                                     ((STRING-EQUAL THE-FILE-NAME "AI: LISPM; QFCTNS QFASL") 
     335                                      "AI: LISPM; QFCTNS >") 
     336                                     ((STRING-EQUAL THE-FILE-NAME "AI: LISPM2; STRING QFASL") 
     337                                      "AI: LISPM2; STRING >") 
     338                                     (T (FERROR NIL "File not known" THE-FILE-NAME)))) 
     339       (COND ((FBOUNDP 'INTERN-LOCAL) 
     340              (SETQ FILE-SYMBOL (INTERN-LOCAL THE-FILE-NAME PKG-FILE-PACKAGE)) 
     341              (SETQ FILE-GROUP-SYMBOL (INTERN-LOCAL FILE-GROUP-SYMBOL PKG-FILE-PACKAGE))) 
     342             (T 
     343              (SETQ FILE-SYMBOL (INTERN THE-FILE-NAME)) 
     344              (SETQ FILE-GROUP-SYMBOL (INTERN FILE-GROUP-SYMBOL)) 
     345              (RPLACA (PACKAGE-CELL-LOCATION FILE-SYMBOL) 'FILES) 
     346              (RPLACA (PACKAGE-CELL-LOCATION FILE-GROUP-SYMBOL) 'FILES))) 
     347       (RETURN FILE-SYMBOL FILE-GROUP-SYMBOL))))) 
     348);LOCAL-DECLARE 
     349 
    260350 ;Note that SETQ may not be used in the below 
    261351(ADD-INITIALIZATION "MINI" '(SET' MINI-OPEN-P NIL) '(WARM FIRST)) 
  • trunk/lisp/lmio/ofnuti.lisp

    r234 r235  
    1111;;; FILE-SET-FN2. 
    1212 
    13 (EVAL-WHEN (COMPILE) (SPECIAL FILE-LAST-DEVICE FILE-LAST-DIRECTORY FILE-LAST-FN1 
    14                               FILE-DSK-DEVICE-NAME)) 
    15 (SETQ FILE-LAST-DEVICE "DSK" FILE-LAST-DIRECTORY "LISPM" 
    16       FILE-LAST-FN1 "FOO" FILE-DSK-DEVICE-NAME "AI") 
     13(DEFVAR FILE-LAST-DEVICE "DSK") 
     14(DEFVAR FILE-LAST-DIRECTORY "LISPM") 
     15(DEFVAR FILE-LAST-FN1 "FOO") 
     16(DEFVAR FILE-DSK-DEVICE-NAME "AI") 
    1717 
    1818;; Given a file name, return two symbols, first for the specific file 
  • trunk/lisp/lmio/print.lisp

    r234 r235  
    9090               (SYMBOLP (SETQ NSS (NAMED-STRUCTURE-SYMBOL EXP)))) 
    9191          (COND ((AND (FBOUNDP NSS) 
    92                       (MEMQ ':PRINT (NAMED-STRUCTURE-INVOKE EXP ':WHICH-OPERATIONS))) 
    93                  (NAMED-STRUCTURE-INVOKE EXP ':PRINT STREAM I-PRINDEPTH SLASHIFY-P)) 
     92                      (MEMQ ':PRINT-SELF (NAMED-STRUCTURE-INVOKE EXP ':WHICH-OPERATIONS))) 
     93                 (NAMED-STRUCTURE-INVOKE EXP ':PRINT-SELF STREAM I-PRINDEPTH SLASHIFY-P)) 
    9494                (T      ;Named structure that doesn't print itself 
    9595                  (PRINT-RAW-STRING (PTTBL-OPEN-RANDOM READTABLE) STREAM FASTP) 
     
    9999                  (PRINT-RAW-STRING (PTTBL-CLOSE-RANDOM READTABLE) STREAM FASTP)))) 
    100100         ((AND (OR (= DATA-TYPE DTP-ENTITY) (= DATA-TYPE DTP-INSTANCE)) 
    101                (ERRSET (<- EXP ':PRINT STREAM I-PRINDEPTH SLASHIFY-P) NIL)))           
     101               (ERRSET (FUNCALL EXP ':PRINT-SELF STREAM I-PRINDEPTH SLASHIFY-P) NIL)))         
    102102         ((ARRAYP EXP) 
    103103          (PRINT-RAW-STRING (PTTBL-OPEN-RANDOM READTABLE) STREAM FASTP) 
  • trunk/lisp/lmio/qfile.lisp

    r234 r235  
    10251025  (FORMAT T "~&Retrying file operation.~%")) 
    10261026 
    1027 (DEFUN FORCE-USER-TO-LOGIN () 
     1027(DEFUN FORCE-USER-TO-LOGIN (&OPTIONAL (HOST USER-LOGIN-MACHINE)) 
    10281028  (COND ((OR (NULL USER-ID) (STRING-EQUAL USER-ID "")) 
    1029          (FORMAT QUERY-IO "~&Login name: ") 
    1030          (LOGIN (READLINE QUERY-IO))))) 
     1029         (FORMAT QUERY-IO "~&Host is ~A, login name or host:? " HOST) 
     1030         (LET ((INPUT (READLINE QUERY-IO))) 
     1031           (COND ((= (AREF INPUT (1- (ARRAY-ACTIVE-LENGTH INPUT))) #/:) 
     1032                  (SETQ HOST (SUBSTRING INPUT 0 (- (ARRAY-ACTIVE-LENGTH INPUT) 2))) 
     1033                  (FORMAT QUERY-IO "~&Login name? ") 
     1034                  (SETQ INPUT (READLINE QUERY-IO)))) 
     1035           (LOGIN INPUT HOST))))) 
    10311036 
    10321037;;; Connection management 
     
    11411146    (LEXPR-FUNCALL FUNCTION UNIT ARGS))) 
    11421147 
     1148;;; Setup a user-id for the specified host.  Knows about ITS specially, as they 
     1149;;; are one big happy family... 
     1150(DEFVAR USER-UNAMES NIL) 
     1151(DEFUN FILE-HOST-USER-ID (USER-ID HOST) 
     1152  (AND (EQ (CDR (ASSOC USER-ID HOST-FILENAME-FLAVOR-ALIST)) 'ITS-FILENAME) 
     1153       ;; All ITS' are the same 
     1154       (SETQ HOST 'ITS 
     1155             USER-ID (SUBSTRING USER-ID 0 6)))    
     1156  (LET ((AE (ASSOC HOST USER-UNAMES))) 
     1157       (IF AE 
     1158           (RPLACD AE USER-ID) 
     1159           (PUSH (CONS HOST USER-ID) USER-UNAMES)))) 
     1160 
    11431161;Send a LOGIN command to all open host units.  Called every time a user logs in or out. 
    11441162(DEFUN FILE-LOGIN (USER-ID) 
     1163  (OR USER-ID (SETQ USER-UNAMES NIL)) 
    11451164  (DOLIST (ALIST-ENTRY FILE-HOST-ALIST) 
    11461165    (HOST-UNIT-MAP-FUNCTION (SI:INIT-FORM ALIST-ENTRY) 
     
    11991218         (LET ((PKT (CHAOS:GET-PKT)) 
    12001219               (ID (FILE-MAKE-TRANSACTION-ID))) 
     1220           (COND ((AND USER-ID 
     1221                       ;; This is really a login 
     1222                       (NULL (SETQ USER-ID (CDR (ASSOC 'ITS USER-UNAMES))))) 
     1223                  ;; We don't know about USER-ID for this host, so must ask 
     1224                  (FORMAT QUERY-IO "~&ITS uname? ") 
     1225                  (SETQ USER-ID (READLINE)) 
     1226                  (FILE-HOST-USER-ID USER-ID (HOST-UNIT-HOST UNIT)))) 
    12011227           (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " (IF USER-ID 
    12021228                                                       (STRING-UPCASE USER-ID) 
     
    12991325                   (PASSWORD) 
    13001326                   (ID (FILE-MAKE-TRANSACTION-ID))) 
    1301                (MULTIPLE-VALUE (USER-ID PASSWORD) (FILE-GET-TOPS20-PASSWORD USER-ID)) 
     1327               (MULTIPLE-VALUE (USER-ID PASSWORD) 
     1328                               (FILE-GET-TOPS20-PASSWORD USER-ID (HOST-UNIT-HOST UNIT))) 
    13021329               ;; LOGIN <UID> <PASS> <NULL ACCOUNT STRING> 
    13031330               (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " USER-ID " " PASSWORD "  ") 
     
    13251352                   (SETF (HOST-UNIT-MAX-DATA-CONNECTIONS UNIT) 8.)) ) 
    13261353 
    1327 (DEFUN FILE-GET-TOPS20-PASSWORD (UID) 
     1354(DEFUN FILE-GET-TOPS20-PASSWORD (UID HOST) 
    13281355  (DO-NAMED EXIT 
    13291356            () (()) 
    1330     (FORMAT QUERY-IO "~&Current login name is ~A. 
    1331 Type either password or loginname<space>password: " UID) 
     1357    (SETQ UID (OR (CDR (ASSOC HOST USER-UNAMES)) UID)) 
     1358    (FORMAT QUERY-IO "~&Current login name is ~A for host ~A. 
     1359Type either password or loginname<space>password: " UID HOST) 
    13321360    (DO ((LINE (MAKE-ARRAY NIL 'ART-STRING 30 NIL '(0))) 
    13331361         (CHAR)) 
     
    13461374             (SETQ CHAR (FUNCALL QUERY-IO ':TYI))) 
    13471375            ((= CHAR #\CR) 
     1376             (FILE-HOST-USER-ID UID HOST) 
    13481377             (RETURN-FROM EXIT UID LINE))) 
    13491378      (ARRAY-PUSH-EXTEND LINE CHAR)))) 
  • trunk/lisp/lmio/qio.lisp

    r234 r235  
    262262                         (NULL TEM)) 
    263263                      (ARRAY-PUSH-EXTEND BUF TEM))))) 
    264         (:TRIGGER-MORE NIL) 
     264;       (:HANDLE-EXCEPTIONS NIL) 
    265265        (OTHERWISE 
    266266         (RETURN (FERROR NIL "The stream operation ~S is not supported by ~S" 
  • trunk/lisp/lmio/rddefs.lisp

    r234 r235  
    55;;; but you may have to recompile LMIO;RTC > as well (using QC and QCMP), and you may have 
    66;;; to recompile LMIO;RDTBL > (using RTC). 
     7;;; Sorry, Alan, this defstruct needs colons which means it probably won't work in Maclisp 
    78 
    8 (DEFSTRUCT (RDTBL ARRAY-LEADER 
    9                   (CONSTRUCTOR MAKE-RDTBL) 
     9(DEFSTRUCT (RDTBL :ARRAY-LEADER 
     10                  (:CONSTRUCTOR MAKE-RDTBL) 
    1011                  (MAKE-ARRAY (NIL 'ART-16B (RDTBL-ARRAY-DIMS))) 
    11                   (DEFAULT-POINTER RDTBL) 
    12                   (SIZE-MACRO RDTBL-SIZE)) 
     12                  (:DEFAULT-POINTER RDTBL) 
     13                  (:SIZE-MACRO RDTBL-SIZE)) 
    1314           RDTBL-FSM                                    ;sacred 
    1415           RDTBL-NAMED-STRUCTURE-SYMBOL 
  • trunk/lisp/lmio/rdtbl.lisp

    r234 r235  
    11;;; -*-LISP-*- 
     2 
     3;       ** (c) Copyright 1980 Massachusetts Institute of Technology ** 
    24 
    35(DECLARE (ERROR '|If you are compiling this, and not using RTC, you are losing|)) 
  • trunk/lisp/lmio/read.lisp

    r234 r235  
    263263 
    264264;This is like READ, but ignores extra closeparens and eofs. 
    265 (DEFUN READ-FOR-TOP-LEVEL (&AUX CH W-O) 
     265(DEFUN READ-FOR-TOP-LEVEL (&AUX W-O) 
    266266  (COND ((MEMQ ':READ (SETQ W-O (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))) 
    267267         (FUNCALL STANDARD-INPUT ':READ)) 
     
    270270         (FUNCALL STANDARD-INPUT ':RUBOUT-HANDLER '() #'READ-FOR-TOP-LEVEL)) 
    271271        ((PROG (THING TYPE SPLICEP XR-SHARP-ARGUMENT) 
    272            A (MULTIPLE-VALUE (THING TYPE) (XR-READ-THING STANDARD-INPUT)) 
     272            A (MULTIPLE-VALUE (THING TYPE) (XR-READ-THING STANDARD-INPUT)) 
    273273              (COND ((EQ TYPE 'READER-MACRO) 
    274274                     (MULTIPLE-VALUE (THING TYPE SPLICEP) 
     
    281281                            (FERROR NIL  
    282282                                    "The special token ~S was read in at top level" THING))))) 
    283                (RETURN THING TYPE))))) 
     283              (RETURN THING TYPE))))) 
    284284 
    285285;READ is almost like XR-READ-THING except READER-MACROs are invoked and SPECIAL-TOKENS 
  • trunk/lisp/lmio/rtc.lisp

    r234 r235  
    10161016            (SETQ FSM (RTC-MAKE-FSM LIST)) 
    10171017             (SETQ RDTBL (MAKE-RDTBL)) 
    1018              (DO X 0 (1+ X) (= X (RDTBL-ARRAY-SIZE)) 
     1018             (DO X 0 (1+ X) (= X RDTBL-ARRAY-SIZE) 
    10191019                 (SETF (RDTBL-BITS RDTBL X) 0) 
    10201020                 (SETF (RDTBL-CODE RDTBL X) 0) 
     
    11991199             (ZERID NIL) 
    12001200             (LEADER-SIZE (RDTBL-SIZE)) 
    1201              (LEN (RDTBL-ARRAY-SIZE)) 
     1201             (LEN RDTBL-ARRAY-SIZE) 
    12021202             (FILENAME (MERGEF '((* *) * QFASL) INFILENAME))) 
    12031203            (FASD-OPEN FILENAME) 
  • trunk/lisp/lmio/rtcmac.lisp

    r234 r235  
    4343           (PTTBL-PACKAGE-CHAR          #/:     ) 
    4444           RDTBL-/#-MACRO-ALIST 
    45            (RDTBL-ARRAY (CREATE-ARRAY 3 (RDTBL-ARRAY-SIZE)))) 
     45           (RDTBL-ARRAY (CREATE-ARRAY 3 RDTBL-ARRAY-SIZE))) 
    4646 
    47 (DEFMACRO RDTBL-ARRAY-SIZE () '220) 
     47(DECLARE (SPECIAL RDTBL-ARRAY-SIZE)) 
     48(SETQ RDTBL-ARRAY-SIZE 240) 
    4849 
    4950(DEFMACRO RDTBL-SIZE () `',(1- (RDTBL-SIZE+1))) 
     
    6364(DEFMACRO IF-FOR-LISPM (&REST FOO) 
    6465    `(COMMENT THIS IS MACLISP)) 
     66 
  • trunk/lisp/lmio/unibus.lisp

    r234 r235  
    4747    (%P-DPB-OFFSET BUFFER-START %%Q-POINTER CHAN %UNIBUS-CHANNEL-BUFFER-IN-PTR) 
    4848    (%P-DPB-OFFSET BUFFER-START %%Q-POINTER CHAN %UNIBUS-CHANNEL-BUFFER-OUT-PTR)) 
    49   (DO () ((%CHANGE-PAGE-STATUS CHAN %PHT-SWAP-STATUS-WIRED NIL)) 
    50     (%P-LDB 1 CHAN)) 
     49  (WIRE-PAGE CHAN) 
    5150  (WITHOUT-INTERRUPTS 
    5251       (%P-DPB-OFFSET (SYSTEM-COMMUNICATION-AREA %SYS-COM-UNIBUS-INTERRUPT-LIST) 
     
    5857  (AND CHAN 
    5958       (WITHOUT-INTERRUPTS 
    60             (%CHANGE-PAGE-STATUS CHAN %PHT-SWAP-STATUS-NORMAL NIL) 
     59            (UNWIRE-PAGE CHAN) 
    6160            (DO ((X (%POINTER (SYSTEM-COMMUNICATION-AREA %SYS-COM-UNIBUS-INTERRUPT-LIST)) 
    6261                    (%P-LDB %%Q-POINTER (+ X %UNIBUS-CHANNEL-LINK)))