Changeset 235


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

Update.

Location:
trunk/lisp/lmio
Files:
21 edited

Legend:

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

    r234 r235  
    658658               HOST (NSUBSTRING DESTINATION (1+ HOST) (STRING-LENGTH DESTINATION))))
    659659        (T (SETQ PERSON "anyone"  HOST DESTINATION)))
    660   (SI:FORCE-USER-TO-LOGIN)
     660  (FS:FORCE-USER-TO-LOGIN)
    661661  (COND ((NULL MSG)
    662662         (FORMAT T "~%Message: (terminate with End)~%")
     
    713713                          (// IDLE 60.)
    714714                          (\ IDLE 60.)
    715                           SI:USER-PERSONAL-NAME-FIRST-NAME-FIRST
    716                           SI:USER-GROUP-AFFILIATION))))
     715                          FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
     716                          FS:USER-GROUP-AFFILIATION))))
    717717  (FAST-ANSWER-STRING "FINGER" GIVE-FINGER-SAVED-STRING))
    718718
     
    729729           "~6A ~C ~22A ~6A ~:[    ~3*~;~:[~D:~2,48D~;  ~*~D~]~]     ~A"
    730730           USER-ID
    731            SI:USER-GROUP-AFFILIATION
    732            SI:USER-PERSONAL-NAME-FIRST-NAME-FIRST
     731           FS:USER-GROUP-AFFILIATION
     732           FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
    733733           MY-NAME-STRING
    734734           (NOT (ZEROP IDLE))
  • trunk/lisp/lmio/chsncp.lisp

    r234 r235  
    649649  ;; This process runs all Time response actions such as PROBEs and Retransmission.
    650650        BACKGROUND  (PROCESS-CREATE "Chaos Background")
    651         RECEIVER (PROCESS-CREATE "Chaos Reciever" ':SIMPLE-P T)
     651        RECEIVER (PROCESS-CREATE "Chaos Receiver" ':SIMPLE-P T)
    652652
    653653        )
     
    16581658    (COND (RESERVED-INT-PKT
    16591659            (FERROR NIL "Int PKT about to be lost!"))) ;Hopefully this will get printed
     1660    (SI:SET-PROCESS-WAIT CURRENT-PROCESS #'(LAMBDA () (NOT (OR (NULL ENABLE)
     1661                                                               (NULL (INT-RECEIVE-LIST)))))
     1662                         NIL)
     1663    (SETF (SI:PROCESS-WHOSTATE CURRENT-PROCESS) "Chaos Packet")
    16601664    ))
    16611665
  • 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  
    963963                  (UPDATE-PARTITION-COMMENT
    964964                       PART
    965                        (LET ((PATHNAME (FILE-SPREAD-PATHNAME (FUNCALL FILE ':NAME))))
    966                          (FORMAT NIL "~A ~D" (THIRD PATHNAME)
    967                                  (FUNCALL FILE ':GET ':VERSION)))
     965                       (LET ((FILE-NAME (FUNCALL FILE ':NAME)))
     966                         (FORMAT NIL "~A ~D"
     967                                 (FUNCALL FILE-NAME ':NAME) (FUNCALL FILE ':GET ':VERSION)))
    968968                       UNIT)
    969969                  (CLOSE FILE)
  • trunk/lisp/lmio/dledit.lisp

    r234 r235  
    342342  (LE-DISPLAY-LABEL LE-RQB LE-UNIT))
    343343
    344 (DEFUN LE-COM-CONTROL-D ()      ;Delete this partition
     344(DEFUN LE-COM-CONTROL-K ()      ;Delete this partition
    345345  (LET ((PLOC (LE-CURRENT-PARTITION)))
    346346    (FORMAT T "~&Delete the ~S partition? " (GET-DISK-STRING LE-RQB PLOC 4))
     
    439439R read label from disk, W write label to disk, I initialize the label
    440440E edit selected item
    441 O add partition, D delete partition, S sort partitions
     441O add partition, K delete partition, S sort partitions
    442442<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  
    339339
    340340(DEFUN GRIND-FORM (EXP LOC &AUX TEM)
    341   (COND ((NLISTP EXP)                                   ;Atoms print very simply
     341  (COND ((ATOM EXP)                                     ;Atoms print very simply
    342342         (GRIND-PRIN1 EXP GRIND-IO LOC))
    343343        ((EQ (CAR EXP) GRIND-DISPLACED)
    344344         (GRIND-FORM (CADR EXP) (LOCF (CADR EXP))))
    345345        ((AND (SYMBOLP (CAR EXP))                       ;Check for GRIND-MACRO
     346              (OR (NULL (CDR EXP)) (NOT (ATOM (CDR EXP)))) ; but try not to get faked out
    346347              (SETQ TEM (GET (CAR EXP) 'GRIND-MACRO)))
    347348         (AND (*CATCH 'GRIND-MACRO-FAILED
  • trunk/lisp/lmio/mini.lisp

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

    r234 r235  
    10301030  (FORMAT T "~&Retrying file operation.~%"))
    10311031
    1032 (DEFUN FORCE-USER-TO-LOGIN ()
     1032(DEFUN FORCE-USER-TO-LOGIN (&OPTIONAL (HOST USER-LOGIN-MACHINE))
    10331033  (COND ((OR (NULL USER-ID) (STRING-EQUAL USER-ID ""))
    1034          (FORMAT QUERY-IO "~&Login name: ")
    1035          (LOGIN (READLINE QUERY-IO)))))
     1034         (FORMAT QUERY-IO "~&Host is ~A, login name or host:? " HOST)
     1035         (LET ((INPUT (READLINE QUERY-IO)))
     1036           (COND ((= (AREF INPUT (1- (ARRAY-ACTIVE-LENGTH INPUT))) #/:)
     1037                  (SETQ HOST (SUBSTRING INPUT 0 (- (ARRAY-ACTIVE-LENGTH INPUT) 2)))
     1038                  (FORMAT QUERY-IO "~&Login name? ")
     1039                  (SETQ INPUT (READLINE QUERY-IO))))
     1040           (LOGIN INPUT HOST)))))
    10361041
    10371042
     
    11471152    (LEXPR-FUNCALL FUNCTION UNIT ARGS)))
    11481153
     1154;;; Setup a user-id for the specified host.  Knows about ITS specially, as they
     1155;;; are one big happy family...
     1156(DEFVAR USER-UNAMES NIL)
     1157(DEFUN FILE-HOST-USER-ID (USER-ID HOST)
     1158  (AND (EQ (CDR (ASSOC USER-ID HOST-FILENAME-FLAVOR-ALIST)) 'ITS-FILENAME)
     1159       ;; All ITS' are the same
     1160       (SETQ HOST 'ITS
     1161             USER-ID (SUBSTRING USER-ID 0 6)))   
     1162  (LET ((AE (ASSOC HOST USER-UNAMES)))
     1163       (IF AE
     1164           (RPLACD AE USER-ID)
     1165           (PUSH (CONS HOST USER-ID) USER-UNAMES))))
     1166
    11491167;Send a LOGIN command to all open host units.  Called every time a user logs in or out.
    11501168(DEFUN FILE-LOGIN (USER-ID)
     1169  (OR USER-ID (SETQ USER-UNAMES NIL))
    11511170  (DOLIST (ALIST-ENTRY FILE-HOST-ALIST)
    11521171    (HOST-UNIT-MAP-FUNCTION (SI:INIT-FORM ALIST-ENTRY)
     
    12061225         (LET ((PKT (CHAOS:GET-PKT))
    12071226               (ID (FILE-MAKE-TRANSACTION-ID)))
     1227           (COND ((AND USER-ID
     1228                       ;; This is really a login
     1229                       (NULL (SETQ USER-ID (CDR (ASSOC 'ITS USER-UNAMES)))))
     1230                  ;; We don't know about USER-ID for this host, so must ask
     1231                  (FORMAT QUERY-IO "~&ITS uname? ")
     1232                  (SETQ USER-ID (READLINE))
     1233                  (FILE-HOST-USER-ID USER-ID (HOST-UNIT-HOST UNIT))))
    12081234           (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " (IF USER-ID
    12091235                                                       (STRING-UPCASE USER-ID)
     
    13061332                   (PASSWORD)
    13071333                   (ID (FILE-MAKE-TRANSACTION-ID)))
    1308                (MULTIPLE-VALUE (USER-ID PASSWORD) (FILE-GET-TOPS20-PASSWORD USER-ID))
     1334               (MULTIPLE-VALUE (USER-ID PASSWORD)
     1335                               (FILE-GET-TOPS20-PASSWORD USER-ID (HOST-UNIT-HOST UNIT)))
    13091336               ;; LOGIN <UID> <PASS> <NULL ACCOUNT STRING>
    13101337               (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " USER-ID " " PASSWORD "  ")
     
    13321359                   (SETF (HOST-UNIT-MAX-DATA-CONNECTIONS UNIT) 8.)) )
    13331360
    1334 (DEFUN FILE-GET-TOPS20-PASSWORD (UID)
     1361(DEFUN FILE-GET-TOPS20-PASSWORD (UID HOST)
    13351362  (DO-NAMED EXIT
    13361363            () (())
    1337     (FORMAT QUERY-IO "~&Current login name is ~A.
    1338 Type either password or loginname<space>password: " UID)
     1364    (SETQ UID (OR (CDR (ASSOC HOST USER-UNAMES)) UID))
     1365    (FORMAT QUERY-IO "~&Current login name is ~A for host ~A.
     1366Type either password or loginname<space>password: " UID HOST)
    13391367    (DO ((LINE (MAKE-ARRAY NIL 'ART-STRING 30 NIL '(0)))
    13401368         (CHAR))
     
    13531381             (SETQ CHAR (FUNCALL QUERY-IO ':TYI)))
    13541382            ((= CHAR #\CR)
     1383             (FILE-HOST-USER-ID UID HOST)
    13551384             (RETURN-FROM EXIT UID LINE)))
    13561385      (ARRAY-PUSH-EXTEND LINE CHAR))))
  • trunk/lisp/lmio/qio.lisp

    r234 r235  
    263263                         (NULL TEM))
    264264                      (ARRAY-PUSH-EXTEND BUF TEM)))))
    265         (:TRIGGER-MORE NIL)
     265;       (:HANDLE-EXCEPTIONS NIL)
    266266        (OTHERWISE
    267267         (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  
    10331033             (SETQ FSM (RTC-MAKE-FSM LIST))
    10341034             (SETQ RDTBL (MAKE-RDTBL))
    1035              (DO X 0 (1+ X) (= X (RDTBL-ARRAY-SIZE))
     1035             (DO X 0 (1+ X) (= X RDTBL-ARRAY-SIZE)
    10361036                 (SETF (RDTBL-BITS RDTBL X) 0)
    10371037                 (SETF (RDTBL-CODE RDTBL X) 0)
     
    12181218             (ZERID NIL)
    12191219             (LEADER-SIZE (RDTBL-SIZE))
    1220              (LEN (RDTBL-ARRAY-SIZE))
     1220             (LEN RDTBL-ARRAY-SIZE)
    12211221             (FILENAME (MERGEF '((* *) * QFASL) INFILENAME)))
    12221222            (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)))
Note: See TracChangeset for help on using the changeset viewer.