;LISP MACHINE SIDE OF INTERIM FILE COMPUTER PACKAGE -*-LISP-*- ;ASSUMES SYSTEM-COMMUNICATION-AREA IS AT 200 (400 ON CADR) ;ALSO, WATCH OUT! LOCATIONS 376 AND 377 ARE HAUNTED. ;SYSTEM COMMUNICATION AREA LOCATIONS USED IN NEW PAGED SCHEME ;THE PDP10 SIDE USES THESE TWO TO DEVIRTUALIZE THE ADDRESSES IT IS GIVEN. ;IT IS THE RESPONSIBILITY OF THE LISP MACHINE SIDE TO WIRE DOWN THE BUFFER ;BEFORE MAKING A REQUEST. ; %SYS-COM-PAGE-TABLE-PNTR ;ADDRESS OF PAGE-TABLE-AREA ; %SYS-COM-PAGE-TABLE-SIZE ;NUMBER OF QS ;THESE ARE FOR I/O TO PDP10 ; %SYS-COM-QIO-REQUEST ;REQUEST TO PDP10, SEE BELOW ; ;ZEROED BY PDP10 AFTER REQ PROCESSED ; %SYS-COM-QIO-BUFFER ;ARRAY POINTER TO BUFFER ; ;PDP10 USES SIZE AND ARRAY LEADER 0 ; ;REQUESTS: ; 0 IDLE ; 1 READ ; 2 READ BINARY (16 BIT) ; 3 WRITE ; 4 WRITE BINARY (16 BIT) ; 5 COMMAND (OPEN/CLOSE) ; 6 READ FROM MAPPED FILE ; 7 WRITE INTO MAPPED FILE ; ;THERE CAN ONLY BE ONE FILE OPEN IN EACH DIRECTION, TO SIMPLIFY ;BUFFER ALLOCATION, WIRING/UNWIRING, COMMUNICATION WITH PDP10, ETC. (SPECIAL FILE-READ-BUFFER ;DISPLACED ARRAY POINTER TO THE BUFFER FILE-WRITE-BUFFER FILE-READ-BINARY-BUFFER FILE-WRITE-BINARY-BUFFER FILE-COMMAND-BUFFER FILE-MAPPED-BUFFER FILE-BUFFER ;FOR CLOSURES FILE-REAL-BUFFER ;DITTO, IF FILE-BUFFER IS INDIRECT-ARRAY TO HERE FILE-OPCODE ;DITTO FILE-ERROR ;THE FUNCTION TO USE IN PLACE OF ERROR. FILE-INPUT-BUFFER-COUNT ;# BUFFERS READ FROM INPUT FILE. ;NIL IF NO FILE OPEN. SEE WHO-LINE. FILE-INPUT-NAME ;NAME TO APPEAR IN THE WHO LINE %FILE-READ-OPCODE %FILE-WRITE-OPCODE %FILE-READ-BINARY-OPCODE %FILE-WRITE-BINARY-OPCODE %FILE-COMMAND-OPCODE %FILE-READ-MAPPED-OPCODE %FILE-WRITE-MAPPED-OPCODE FILE-USE-CHAOS ;SHOULD WE TRY TO USE CHAOSNET? FILE-CHAOS-CONN ;CONNECTION TO FILE COMPUTER FILE-DSK-DEVICE-NAME ;WHAT TO CALL "DSK" FILE-CHAOS-BUFFER-SIZE-STRING ;NUMBER OF PACKETS BUFFER CAN HOLD FILE-CHAOS-MAPPED-BUFFER-SIZE-STRING) ;DITTO FOR FILE-MAPPED BUFFER (SETQ %FILE-READ-OPCODE 1 %FILE-READ-BINARY-OPCODE 2 %FILE-WRITE-OPCODE 3 %FILE-WRITE-BINARY-OPCODE 4 %FILE-COMMAND-OPCODE 5 %FILE-READ-MAPPED-OPCODE 6 %FILE-WRITE-MAPPED-OPCODE 7) ;FOR 16-BIT BINARY I/O: ;IN LISP-MACHINE, JUST OPEN IN FIXNUM MODE AND FUNCALL THAT STREAM WITH 'TYI AND 'TYO. (ENDF HEAD) ;CREATE BUFFERS ;A BUFFER IS AN ART-STRING ARRAY WITH A LEADER. ;LEADER ELEMENTS: 0 FILL POINTER, 1 READ POINTER, 2 FILE NAME. (DEFUN FILE-INIT () (SETQ FILE-ERROR 'ERROR FILE-DSK-DEVICE-NAME "AI" FILE-CHAOS-CONN NIL FILE-USE-CHAOS NIL) (SETQ FILE-READ-BUFFER (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 10000 ;1K WORDS NIL '(0 0 NIL))) (SETQ FILE-WRITE-BUFFER (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 10000 ;1K WORDS NIL '(0 0 NIL))) (SETQ FILE-MAPPED-BUFFER (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 2000 ;256. WORDS NIL '(0 0 NIL))) (SETQ FILE-COMMAND-BUFFER (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 100. NIL '(0 0 NIL))) (SETQ FILE-READ-BINARY-BUFFER (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-16B 4000 FILE-READ-BUFFER '(0 0 NIL))) (SETQ FILE-WRITE-BINARY-BUFFER (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-16B 4000 FILE-WRITE-BUFFER '(0 0 NIL)))) ;WIRE DOWN A BUFFER. THIS ISN'T GC-SAFE. ;FIRST ARG IS THE ARRAY, SECOND IS T TO WIRE AND NIL TO UNWIRE. (DEFUN FILE-WIRE-BUFFER (ARRAY WIRE-P &AUX (LOW (- (%POINTER ARRAY) (ARRAY-DIMENSION-N 0 ARRAY) 2)) (HIGH (+ (%POINTER ARRAY) 2 (// (ARRAY-LENGTH ARRAY) 4))) (SWAP-STATUS (COND (WIRE-P %PHT-SWAP-STATUS-WIRED) (T %PHT-SWAP-STATUS-NORMAL)))) (DO LOC (LOGAND LOW (- PAGE-SIZE)) (+ LOC PAGE-SIZE) (>= LOC HIGH) A (%P-DPB (%P-LDB 1 LOC) ;REFERENCE THE LOCATION TO SWAP IT IN 1 LOC) ;AND MODIFY IT SO HAS-BEEN-WRITTEN GETS SET, SINCE (OR (%CHANGE-PAGE-STATUS LOC SWAP-STATUS NIL) ;PDP10 WILL PROBABLY MODIFY IT (GO A)))) ;THIS HAS TO BE COMPILED BECAUSE INTERPRETED IT WOULDN'T WORK IN THE COLD-LOAD (DEFUN FILE-WARM-INIT () (COND ((FBOUNDP 'CHAOS:CONNECT) ; and if Chaos software seems to be loaded, (FILE-USE-CHAOS NIL) ;Don't turn on the Chaos net as soon as machine is booted (SETQ FILE-USE-CHAOS T))) ; cause the first OPEN to turn on the Chaos file stuff (SETQ FILE-CHAOS-CONN NIL)) (ADD-INITIALIZATION "FILE-CHAOS" '(FILE-WARM-INIT) '(WARM)) ;UNWIRE ALL BUFFERS (DEFUN FILE-RESET () (AND (BOUNDP 'FILE-CHAOS-CONN) FILE-CHAOS-CONN ;IF CONNECTION EXISTS, CLOSE IT (CHAOS:CHAOS-CLOSE FILE-CHAOS-CONN "DONE")) (STORE-ARRAY-LEADER 0 FILE-READ-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-READ-BUFFER 1) (STORE-ARRAY-LEADER 0 FILE-READ-BINARY-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-READ-BINARY-BUFFER 1) (STORE-ARRAY-LEADER 0 FILE-WRITE-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-WRITE-BUFFER 1) (STORE-ARRAY-LEADER 0 FILE-WRITE-BINARY-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-WRITE-BINARY-BUFFER 1) (STORE-ARRAY-LEADER 0 FILE-MAPPED-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-MAPPED-BUFFER 1) (STORE-ARRAY-LEADER 0 FILE-COMMAND-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-COMMAND-BUFFER 1) (FILE-WIRE-BUFFER FILE-READ-BUFFER NIL) (FILE-WIRE-BUFFER FILE-WRITE-BUFFER NIL) (FILE-WIRE-BUFFER FILE-COMMAND-BUFFER NIL) (FILE-WIRE-BUFFER FILE-MAPPED-BUFFER NIL)) ;START USING THE CHAOSNET FOR FILES (DEFUN FILE-USE-CHAOS (&OPTIONAL (TURN-ON T) (HOST "AI") &AUX CONNECT-RESPONSE) (AND (BOUNDP 'FILE-CHAOS-CONN) ;Don't do this if haven't got Chaos net, but have to (CHAOS:ASSURE-ENABLED)) ;do it if FILE-RESET is going to try to close a connection (FILE-RESET) (COND ((SETQ FILE-USE-CHAOS TURN-ON) (SETQ FILE-CHAOS-BUFFER-SIZE-STRING (FORMAT NIL "~D" (// 10000 CHAOS:MAX-DATA-BYTES-PER-PKT)) FILE-CHAOS-MAPPED-BUFFER-SIZE-STRING (FORMAT NIL "~D" (// 2000 CHAOS:MAX-DATA-BYTES-PER-PKT)) FILE-DSK-DEVICE-NAME (STRING-UPCASE HOST) FILE-CHAOS-CONN (COND ((NOT (STRINGP (SETQ CONNECT-RESPONSE (CHAOS:CONNECT HOST "FILE")))) CONNECT-RESPONSE) (T (FORMAT T "Cannot connect to ~S, ~S~%" HOST CONNECT-RESPONSE) NIL)))) (T (SETQ FILE-DSK-DEVICE-NAME "AI")))) (DEFUN FILE-RESET-CHAOSNET () (SETQ FILE-CHAOS-CONN NIL)) ;(FILE-COMMAND "FOO " "BAR" "BLETCH") PASSES THE COMMAND "FOO BARBLETCH" ;TO THE PDP10 FILE PROGRAM, AND RETURNS NIL IF AN EMPTY STRING IS RETURNED, ;OTHERWISE RETURNS THE STRING (IN FILE-COMMAND-BUFFER, SO THE NEXT (FILE-COMMAND ...) ;WILL CLOBBER IT! SO DON'T DEPEND ON IT TO STAY AROUND LONG). (DEFUN FILE-COMMAND (&REST ARGS &AUX STR) (OR ARGS (FERROR NIL "No args were given")) (COND (FILE-USE-CHAOS (SETQ STR (LEXPR-FUNCALL 'FILE-CHAOS-COMMAND ARGS)) (PROG NIL (RETURN (COND ((STRING-EQUAL (SUBSTRING STR 0 (MIN (ARRAY-ACTIVE-LENGTH STR) 3)) "+OK") NIL) (T (SUBSTRING STR 1 (1- (ARRAY-ACTIVE-LENGTH STR))))) ( (AR-1 STR 0) ## -)))) ;RETURN STRING AND FLAG IF WON (T (STORE-ARRAY-LEADER 0 FILE-COMMAND-BUFFER 0) (DO ((ARGS ARGS (CDR ARGS))) ((NULL ARGS)) (DO I 0 (1+ I) (= I (ARRAY-ACTIVE-LENGTH (CAR ARGS))) (ARRAY-PUSH FILE-COMMAND-BUFFER (AR-1 (CAR ARGS) I)))) (FILE-ACTIVATE-AND-WAIT FILE-COMMAND-BUFFER %FILE-COMMAND-OPCODE (CAR ARGS)) (COND ((= (ARRAY-LEADER FILE-COMMAND-BUFFER 0) 0) NIL) (T FILE-COMMAND-BUFFER))))) ;PERFORM A FILE COMMAND, AND BARF IF IT RETURNS FAILURE (A NON-EMPTY STRING). (DEFUN FILE-COMMAND-CAREFUL (&REST STRINGS &AUX WINP ANSWER) (COND (FILE-USE-CHAOS (MULTIPLE-VALUE (ANSWER WINP) (APPLY (FUNCTION FILE-COMMAND) STRINGS)) (AND WINP (SETQ ANSWER NIL))) (T (SETQ ANSWER (APPLY (FUNCTION FILE-COMMAND) STRINGS)))) (AND ANSWER (FUNCALL FILE-ERROR (STRING-APPEND "FAILED: " ANSWER) (APPLY (FUNCTION STRING-APPEND) STRINGS)))) ;SEND COMMAND TO FILE COMPUTER AND GET BACK RESPONSE (DEFUN FILE-CHAOS-COMMAND (&REST ARGS &AUX PKT STR) (COND ((NOT (AND FILE-CHAOS-CONN (EQ (CHAOS:STATE FILE-CHAOS-CONN) 'CHAOS:OPEN-STATE))) (FILE-USE-CHAOS NIL) (FILE-USE-CHAOS T FILE-DSK-DEVICE-NAME))) (SETQ PKT (CHAOS:GET-PKT)) ;GET A PACKET TO SEND (STORE-ARRAY-LEADER 0 (CHAOS:PKT-STRING PKT) 0) (DO ((ARGS ARGS (CDR ARGS))) ((NULL ARGS)) (DO I 0 (1+ I) (= I (ARRAY-ACTIVE-LENGTH (CAR ARGS))) ;FILL WITH STRINGS (ARRAY-PUSH (CHAOS:PKT-STRING PKT) (AR-1 (CAR ARGS) I)))) (ARRAY-PUSH (CHAOS:PKT-STRING PKT) 215) ;FOLLOWED BY (SETF (CHAOS:PKT-NBYTES PKT) (ARRAY-LEADER (CHAOS:PKT-STRING PKT) 0)) (CHAOS:SEND-PKT FILE-CHAOS-CONN PKT) ;SEND IT OFF (OR (SETQ PKT (CHAOS:GET-NEXT-PKT FILE-CHAOS-CONN)) (FERROR NIL "Chaos net connection in ~A state" (CHAOS:STATE FILE-CHAOS-CONN))) (SETQ STR (STRING-APPEND (CHAOS:PKT-STRING PKT))) (CHAOS:RETURN-PKT PKT) (COND (( (CHAOS:PKT-OPCODE PKT) CHAOS:DAT-OP) ;IF VALID DATA REPLY STR) ;GIVE BACK RESPONSE (T (FERROR NIL "Bad packet from file computer: ~A" STR)))) ;OPEN A FILE. ;RETURNS A STREAM FOR IT. (DEFUN OPEN (FILE-NAME OPTIONS &AUX WRITE-P BINARY-P FILE-BUFFER FILE-REAL-BUFFER FILE-OPCODE) (AND (SYMBOLP OPTIONS) ; For MACLISP compatibility -- DLW OPTIONS ;make NIL work! (SETQ OPTIONS (LIST OPTIONS))) (DO L OPTIONS (CDR L) (NULL L) (SELECTQ (CAR L) ((IN READ)) ((OUT WRITE PRINT) (SETQ WRITE-P T)) (FIXNUM (SETQ BINARY-P T)) (ASCII (SETQ BINARY-P NIL)) (SINGLE ) (BLOCK ) (OTHERWISE (FERROR NIL "~S is not a known option" (CAR L))))) (OR (BOUNDP 'FILE-READ-BUFFER) (FILE-INIT)) (SETQ FILE-REAL-BUFFER (SETQ FILE-BUFFER (COND (WRITE-P FILE-WRITE-BUFFER) (T FILE-READ-BUFFER)))) (SETQ FILE-NAME (FILE-EXPAND-PATHNAME FILE-NAME)) (FILE-COMMAND-CAREFUL "OPEN" (COND (WRITE-P "W") (T "R")) (COND (BINARY-P "B") (T "A")) " " FILE-NAME) (AND BINARY-P (SETQ FILE-BUFFER (COND (WRITE-P FILE-WRITE-BINARY-BUFFER) (T FILE-READ-BINARY-BUFFER)))) (STORE-ARRAY-LEADER FILE-NAME FILE-BUFFER 2) (COND ((NOT WRITE-P) ;THIS WANTS TO APPEAR IN THE WHO LINE (SETQ FILE-INPUT-BUFFER-COUNT 0 FILE-INPUT-NAME FILE-NAME) (AND (FBOUNDP 'TV-WHO-LINE-UPDATE) (TV-WHO-LINE-UPDATE)))) (STORE-ARRAY-LEADER 0 FILE-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-BUFFER 1) (SETQ FILE-OPCODE (COND ((NOT BINARY-P) (COND (WRITE-P %FILE-WRITE-OPCODE) (T %FILE-READ-OPCODE))) ((COND (WRITE-P %FILE-WRITE-BINARY-OPCODE) (T %FILE-READ-BINARY-OPCODE))))) (CLOSURE '(FILE-BUFFER FILE-REAL-BUFFER FILE-OPCODE FILE-USE-CHAOS) (COND ((NOT WRITE-P) (FUNCTION FILE-READ)) (T (FUNCTION FILE-WRITE))))) ;CLOSE (DEFUN CLOSE (STREAM) (FUNCALL STREAM 'CLOSE)) ;MAP IN A FILE AND CREATE A STREAM TO READ OR WRITE FROM IT ;IN THE RANGE SET BY A "MAPSET" OR "FINDDEF" FILE-COMMAND. ;CLOSING A STREAM OF THIS SORT HAS NO EFFECT. ;YOU GET "EOF" FROM IT WHEN THE SPECIFIED RANGE IS EXHAUSTED. ;ANOTHER "MAPSET" OR "FINDDEF" WILL MAKE IT START READING A DIFFERENT RANGE. ;TO SKIP THE REST OF A RANGE, DO ANOTHER "MAPSET" OR "FINDDEF" ; AND DO A 'CLEAR OPERATION ON THE STREAM. ;TO SET THE RANGE WITH MAPSET, DO (FILE-COMMAND "MAPSET ") ;WHERE START AND SIZE ARE NUMBERS CONVERTED TO DECIMAL. ;TO SET THE RANGE TO FOO'S DEFINITION, DO (FILE-COMMAND "FINDDEF " "FOO"). (DEFUN FILE-MAPPED-OPEN (FILE-NAME &OPTIONAL WRITE-P &AUX FILE-OPCODE (FILE-BUFFER FILE-MAPPED-BUFFER) (FILE-REAL-BUFFER FILE-MAPPED-BUFFER)) (SETQ FILE-NAME (FILE-EXPAND-PATHNAME FILE-NAME)) (FILE-COMMAND-CAREFUL "MAPRD " FILE-NAME) (STORE-ARRAY-LEADER FILE-NAME FILE-BUFFER 2) (STORE-ARRAY-LEADER 0 FILE-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-BUFFER 1) (SETQ FILE-OPCODE (COND (WRITE-P %FILE-WRITE-MAPPED-OPCODE) (T %FILE-READ-MAPPED-OPCODE))) (CLOSURE '(FILE-BUFFER FILE-REAL-BUFFER FILE-OPCODE FILE-USE-CHAOS) (COND ((NOT WRITE-P) (FUNCTION FILE-READ)) (T (FUNCTION FILE-WRITE))))) ;THIS FUNCTION OPENS AN INPUT STREAM FROM WHICH YOU CAN READ THE INDEX ;OF A MULTI-SECTION FILE WHICH HAS BEEN OPENED WITH FILE-MAPPED-OPEN. (DEFUN FILE-OPEN-MAPPED-INDEX () (LET ((FILE-OPCODE %FILE-READ-OPCODE) (FILE-BUFFER FILE-READ-BUFFER) (FILE-REAL-BUFFER FILE-READ-BUFFER)) (FILE-COMMAND-CAREFUL "MAPINDEX") (STORE-ARRAY-LEADER "MAPINDEX" FILE-BUFFER 2) ;IN CASE SOMEONE ASKS FOR FILE NAME (STORE-ARRAY-LEADER 0 FILE-BUFFER 0) ;BUFFER EMPTY (STORE-ARRAY-LEADER 0 FILE-BUFFER 1) (SETQ FILE-INPUT-BUFFER-COUNT 0 ;FAKE OUT WHO-LINE STUFF FILE-INPUT-NAME "MAPINDEX") (CLOSURE '(FILE-BUFFER FILE-REAL-BUFFER FILE-OPCODE FILE-USE-CHAOS) (FUNCTION FILE-READ)))) ;Return T if the specified file is a QFASL file, ;or NIL if it is not. Err out if the file can't be opened at all. (DEFUN FILE-QFASL-P (FILENAMES &AUX TEM) (COND (FILE-USE-CHAOS (SETQ TEM (FILE-CHAOS-COMMAND "QFASLP " FILENAMES)) (COND (( (AR-1 TEM 0) ## +) (FUNCALL FILE-ERROR (SUBSTRING TEM 0 (1- (ARRAY-ACTIVE-LENGTH TEM))))) ((= (AR-1 TEM 1) ## Y) T) (T NIL))) (T (SETQ TEM (FILE-COMMAND "QFASLP " FILENAMES)) (COND ((NULL TEM) T) ((EQUAL TEM "NOT A QFASL FILE") NIL) ((FUNCALL FILE-ERROR (STRING-APPEND TEM) (FILE-COMMAND "RFILENAMES"))))))) ;Return non-NIL if the specified file exists, NIL if it doesn't. ;Also, what we return is QFASL if the file is a QFASL file. (DEFUN FILE-EXISTS-P (FILENAMES &AUX TEM) (COND (FILE-USE-CHAOS (SETQ TEM (FILE-CHAOS-COMMAND "QFASLP " FILENAMES)) (COND (( (AR-1 TEM 0) ## +) NIL) ((= (AR-1 TEM 1) ## Y) ':QFASL) (T T))) (T (SETQ TEM (FILE-COMMAND "QFASLP " FILENAMES)) (COND ((NULL TEM) ':QFASL) ((EQUAL TEM "NOT A QFASL FILE") T))))) ;THIS IS THE READ STREAM FUNCTION. (DEFUN FILE-READ (OPERATION &OPTIONAL ARG1 &REST REST) (PROG NIL (COND ((EQ OPERATION ':WHICH-OPERATIONS) (RETURN '(:TYI :TYI-NO-HANG :UNTYI :CLOSE :NAME :LINE-IN :GET-UNIQUE-ID :CLEAR-INPUT :READ-POINTER :SET-POINTER))) ((EQ OPERATION ':TYI) (COND ((< (ARRAY-LEADER FILE-BUFFER 1) (ARRAY-LEADER FILE-BUFFER 0))) ((NOT FILE-USE-CHAOS) ;TEN11 FILE COMPUTER (FILE-ACTIVATE-AND-WAIT FILE-REAL-BUFFER FILE-OPCODE "AIBI") (STORE-ARRAY-LEADER (ARRAY-LEADER FILE-REAL-BUFFER 0) FILE-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-BUFFER 1) (COND ((NOT (= FILE-OPCODE %FILE-READ-MAPPED-OPCODE)) (SETQ FILE-INPUT-BUFFER-COUNT (1+ FILE-INPUT-BUFFER-COUNT)) (AND (FBOUNDP 'TV-WHO-LINE-UPDATE) (TV-WHO-LINE-UPDATE)))) (AND (= 0 (ARRAY-LEADER FILE-BUFFER 0)) ;EOF (COND ((NULL ARG1) (RETURN NIL)) (T (RETURN (ERROR ARG1)))))) (T ;CHAOSNET FILE COMPUTER (LET ((STR (FILE-CHAOS-COMMAND (COND ((= FILE-OPCODE %FILE-READ-BINARY-OPCODE) "READB ") ((= FILE-OPCODE %FILE-READ-MAPPED-OPCODE) "MAPXI ") (T "READ ")) (COND ((= FILE-OPCODE %FILE-READ-MAPPED-OPCODE) FILE-CHAOS-MAPPED-BUFFER-SIZE-STRING) (T FILE-CHAOS-BUFFER-SIZE-STRING))))) (OR (= (AR-1 STR 0) ## +) (FUNCALL FILE-ERROR (SUBSTRING STR 0 (1- (ARRAY-ACTIVE-LENGTH STR))) (FILE-COMMAND "RFILENAMES"))) (LET ((NPKTS (READ-FROM-STRING STR))) (AND (ZEROP NPKTS) (COND ((NULL ARG1) (RETURN NIL)) (T (RETURN (ERROR ARG1))))) ;EOF (STORE-ARRAY-LEADER 0 FILE-REAL-BUFFER 0) (DO ((I 0 (1+ I)) (PKT)) (( I NPKTS)) (OR (SETQ PKT (CHAOS:GET-NEXT-PKT FILE-CHAOS-CONN)) ;GET NEXT DATA PKT (FERROR NIL "Chaos net connection in ~A state" (CHAOS:STATE FILE-CHAOS-CONN))) (DO ((J 0 (1+ J)) ;COPY DATA INTO FILE BUFFER (LEN (ARRAY-ACTIVE-LENGTH (CHAOS:PKT-STRING PKT))) (STR (CHAOS:PKT-STRING PKT))) (( J LEN)) (ARRAY-PUSH FILE-REAL-BUFFER (AR-1 STR J))) (CHAOS:RETURN-PKT PKT)) (STORE-ARRAY-LEADER (// (ARRAY-LEADER FILE-REAL-BUFFER 0) (COND ((= FILE-OPCODE %FILE-READ-BINARY-OPCODE) 2) (T 1))) FILE-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-BUFFER 1) (COND ((NOT (= FILE-OPCODE %FILE-READ-MAPPED-OPCODE)) (SETQ FILE-INPUT-BUFFER-COUNT (1+ FILE-INPUT-BUFFER-COUNT)) (AND (FBOUNDP 'TV-WHO-LINE-UPDATE) (TV-WHO-LINE-UPDATE)))))))) (RETURN (PROG1 (AR-1 FILE-BUFFER (SETQ ARG1 (ARRAY-LEADER FILE-BUFFER 1))) (STORE-ARRAY-LEADER (1+ ARG1) FILE-BUFFER 1)))) ((EQ OPERATION ':TYI-NO-HANG) (COND ((>= (ARRAY-LEADER FILE-BUFFER 1) (ARRAY-LEADER FILE-BUFFER 0)) NIL) (T (PROG1 (AR-1 FILE-BUFFER (SETQ ARG1 (ARRAY-LEADER FILE-BUFFER 1))) (STORE-ARRAY-LEADER (1+ ARG1) FILE-BUFFER 1))))) ((EQ OPERATION ':LINE-IN) (LET ((CH) (I 0) (SIZE 120.) (LINE (MAKE-ARRAY NIL ART-STRING 120. NIL (AND (NUMBERP ARG1) ARG1)))) (DO ((L (ARRAY-LEADER FILE-BUFFER 1) (1+ L)) ;Do until end of buffer (LEN (ARRAY-LEADER FILE-BUFFER 0))) ; or newline or EOF (()) (COND ((= L LEN) (STORE-ARRAY-LEADER L FILE-BUFFER 1) (OR (SETQ CH (FILE-READ ':TYI)) ;Get next buffer (RETURN NIL)) ;EOF, stop DO (SETQ LEN (ARRAY-LEADER FILE-BUFFER 0) L (1- (ARRAY-LEADER FILE-BUFFER 1)))) ((SETQ CH (AR-1 FILE-BUFFER L)))) (COND ((= CH 215) (STORE-ARRAY-LEADER (1+ L) FILE-BUFFER 1) (RETURN NIL))) (AND (= I SIZE) (ADJUST-ARRAY-SIZE LINE (SETQ SIZE (+ 120. SIZE)))) (AS-1 CH LINE I) (SETQ I (1+ I))) (ADJUST-ARRAY-SIZE LINE I) (AND (NUMBERP ARG1) ;If it has a leader (STORE-ARRAY-LEADER I LINE 0)) (RETURN LINE (NULL CH)))) ((EQ OPERATION ':CLEAR-INPUT) (STORE-ARRAY-LEADER (ARRAY-LEADER FILE-BUFFER 0) FILE-BUFFER 1)) ((EQ OPERATION ':UNTYI) (STORE-ARRAY-LEADER (1- (ARRAY-LEADER FILE-BUFFER 1)) FILE-BUFFER 1)) ((EQ OPERATION ':CLOSE) (COND ((NOT (= FILE-OPCODE %FILE-READ-MAPPED-OPCODE)) ;DON'T CLOSE INFILE IF READING WITH MAPXI. (SETQ FILE-INPUT-BUFFER-COUNT NIL) (FILE-COMMAND "CLOSE" "R")))) ((EQ OPERATION ':NAME) (RETURN (ARRAY-LEADER FILE-BUFFER 2))) ((EQ OPERATION ':GET-UNIQUE-ID) (RETURN (STRING-APPEND (COND ((= FILE-OPCODE %FILE-READ-MAPPED-OPCODE) (FILE-COMMAND "MAPINFO")) (T (FILE-COMMAND "ININFO")))))) ((EQ OPERATION ':SET-POINTER) ;; Flush all buffered input, and tell the file server to set its pointer. (STORE-ARRAY-LEADER 0 FILE-BUFFER 0) (STORE-ARRAY-LEADER 0 FILE-BUFFER 1) (FILE-COMMAND-CAREFUL (COND ((ZEROP ARG1) "SINPOS 0") ;FORMAT not in cold load ((FORMAT NIL "SINPOS ~D" ARG1))))) ;euggghhh! (T (MULTIPLE-VALUE-CALL (STREAM-DEFAULT-HANDLER 'FILE-READ OPERATION ARG1 REST)))))) ;THIS IS THE WRITE STREAM FUNCTION. (DEFUN FILE-WRITE (OPERATION &OPTIONAL ARG1 &REST REST) (PROG NIL A (COND ((EQ OPERATION ':WHICH-OPERATIONS) (RETURN '(:TYO :CLOSE :FINISH :READ-POINTER :NAME :LINE-OUT :STRING-OUT))) ((EQ OPERATION ':TYO) (AND (ARRAY-PUSH FILE-BUFFER ARG1) (RETURN ARG1)) (FILE-WRITE-FINISH) (GO A)) ((EQ OPERATION ':LINE-OUT) (FILE-WRITE-LINE ARG1 (FIRST REST) (SECOND REST))) ((EQ OPERATION ':STRING-OUT) (FILE-WRITE-STRING ARG1 (FIRST REST) (SECOND REST))) ((EQ OPERATION ':CLOSE) (FILE-WRITE-FINISH) (OR (= FILE-OPCODE %FILE-WRITE-MAPPED-OPCODE) (FILE-COMMAND "CLOSE" "W"))) ((EQ OPERATION ':FINISH) (FILE-WRITE-FINISH)) ((EQ OPERATION ':READ-POINTER) (FILE-WRITE-FINISH) (RETURN (DO ((IBASE 10.)) (T (READ-FROM-STRING (FILE-COMMAND "ROUTPOS")))))) ((EQ OPERATION ':NAME) (RETURN (ARRAY-LEADER FILE-BUFFER 2))) (T (MULTIPLE-VALUE-CALL (STREAM-DEFAULT-HANDLER 'FILE-WRITE OPERATION ARG1 REST)))))) ;Force out the output file's buffer. Assumes variables bound by output stream. (DEFUN FILE-WRITE-FINISH () (STORE-ARRAY-LEADER (ARRAY-LEADER FILE-BUFFER 0) FILE-REAL-BUFFER 0) (COND ((ZEROP (ARRAY-LEADER FILE-REAL-BUFFER 0))) ((NOT FILE-USE-CHAOS) (FILE-ACTIVATE-AND-WAIT FILE-REAL-BUFFER FILE-OPCODE "AIBO")) (T (AND (= FILE-OPCODE %FILE-WRITE-BINARY-OPCODE) (STORE-ARRAY-LEADER (* (ARRAY-LEADER FILE-REAL-BUFFER 0) 2) FILE-REAL-BUFFER 0)) ;If sending wds, *2 bytes (LET ((STR (FILE-CHAOS-COMMAND (COND ((= FILE-OPCODE %FILE-WRITE-BINARY-OPCODE) "WRITEB ") ((= FILE-OPCODE %FILE-WRITE-MAPPED-OPCODE) "MAPXO ") (T "WRITE ")) (FORMAT NIL "~D" (// (+ (ARRAY-LEADER FILE-REAL-BUFFER 0) CHAOS:MAX-DATA-BYTES-PER-PKT -1) CHAOS:MAX-DATA-BYTES-PER-PKT))))) (OR (= (AR-1 STR 0) ## :) ;GO-AHEAD-SYMBOL? (FUNCALL FILE-ERROR (SUBSTRING STR 0 (1- (ARRAY-ACTIVE-LENGTH STR))) (FILE-COMMAND "RFILENAMES")))) (DO ((N (ARRAY-LEADER FILE-REAL-BUFFER 0)) (I 0) (PKT) (NBYTES)) (()) (SETQ PKT (CHAOS:GET-PKT) ;ALLOCATE A PKT TO SEND WITH NBYTES (COND (( N CHAOS:MAX-DATA-BYTES-PER-PKT) CHAOS:MAX-DATA-BYTES-PER-PKT) (T N))) (CHAOS:SET-PKT-STRING PKT (NSUBSTRING FILE-REAL-BUFFER I (+ I NBYTES))) (CHAOS:SEND-PKT FILE-CHAOS-CONN PKT (COND ((= FILE-OPCODE %FILE-WRITE-BINARY-OPCODE) (+ CHAOS:DAT-OP 100)) ;BINARY DATA (T CHAOS:DAT-OP))) (SETQ N (- N NBYTES) I (+ I NBYTES)) (AND ( N 0) (RETURN NIL))) (LET ((PKT (CHAOS:GET-NEXT-PKT FILE-CHAOS-CONN))) (OR PKT (FERROR NIL "Chaos net connection in ~A state" (CHAOS:STATE FILE-CHAOS-CONN))) (LET ((STR (CHAOS:PKT-STRING PKT))) (OR (= (AR-1 STR 0) ## +) ;GOT THERE OK? (FUNCALL FILE-ERROR (SUBSTRING STR 0 (1- (ARRAY-ACTIVE-LENGTH STR))) (FILE-COMMAND "RFILENAMES")))) (CHAOS:RETURN-PKT PKT)))) (STORE-ARRAY-LEADER 0 FILE-BUFFER 0)) ;Given a line, output it to the output file, followed by a CR of course. (DEFUN FILE-WRITE-LINE (LINE START END) (FILE-WRITE-STRING LINE START END) (FILE-WRITE ':TYO 215)) ;Given a string, output it to the output file all at once. (DEFUN FILE-WRITE-STRING (STRING START END) (PROG (I) (SETQ I (IF START START 0)) (OR END (SETQ END (STRING-LENGTH STRING))) LOOP (COND ((= I END) (RETURN NIL)) ((NULL (ARRAY-PUSH FILE-BUFFER (AR-1 STRING I))) (FILE-WRITE ':FINISH) (GO LOOP))) (SETQ I (1+ I)) (GO LOOP))) ;WIRE DOWN THE BUFFER, STORE IT AND THE OPCODE INTO SYSTEM COMMUNICATION AREA, ;WAIT FOR PDP10 TO REPLY, THEN UNWIRE AND RETURN. ALSO HACKS THE WHO-LINE. ;FOR WHY THERE'S A COLON HERE, SEE THE COMMENT IN FRONT OF TV-DEFINE-SCREEN IN TV ;AS WE SAY, "IT SUCKS DEAD ROCKS" (DEFUN FILE-ACTIVATE-AND-WAIT (:BUFFER OPCODE WHOSTATE) (FILE-WIRE-BUFFER :BUFFER T) (AS-1 :BUFFER (FUNCTION SYSTEM-COMMUNICATION-AREA) %SYS-COM-QIO-BUFFER) ;MUST NOT USE STORE (AS-1 OPCODE (FUNCTION SYSTEM-COMMUNICATION-AREA) %SYS-COM-QIO-REQUEST) ; SINCE Q MAY BE ;GARBAGE ON INITIAL REFERENCE (PROCESS-WAIT WHOSTATE (FUNCTION (LAMBDA () (ZEROP (AR-1 (FUNCTION SYSTEM-COMMUNICATION-AREA) %SYS-COM-QIO-REQUEST))))) (FILE-WIRE-BUFFER :BUFFER NIL)) (DEFUN READFILE (FILE-NAME &OPTIONAL PKG) (LET ((EOF '(())) FILE-ID FILE-SYMBOL FILE-GROUP-SYMBOL (STANDARD-INPUT (OPEN FILE-NAME '(READ)))) (SETQ FILE-ID (FILE-ININFO STANDARD-INPUT)) (MULTIPLE-VALUE (FILE-SYMBOL FILE-GROUP-SYMBOL) (GET-FILE-SYMBOLS FILE-NAME)) (OR (NOT (NULL PKG)) (GET FILE-GROUP-SYMBOL ':PACKAGE) (FILE-READ-PROPERTY-LIST FILE-GROUP-SYMBOL STANDARD-INPUT)) (LET ((PACKAGE (PKG-FIND-PACKAGE (OR PKG (GET FILE-GROUP-SYMBOL ':PACKAGE) PACKAGE))) (FDEFINE-FILE-SYMBOL FILE-GROUP-SYMBOL)) (OR PKG (FORMAT T "~&Loading file ~A into package ~A~%" FILE-SYMBOL PACKAGE)) (DO FORM (READ STANDARD-INPUT EOF) (READ STANDARD-INPUT EOF) (EQ FORM EOF) (EVAL FORM)) (SET-FILE-LOADED-ID FILE-SYMBOL FILE-ID PACKAGE) (CLOSE STANDARD-INPUT)))) ;; 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 ">") (DEFUN GET-FILE-SYMBOLS (FILE-NAME &AUX FILE-SYMBOL FILE-GROUP-SYMBOL) (SETQ FILE-SYMBOL (INTERN-LOCAL (FILE-EXPAND-PATHNAME FILE-NAME) PKG-FILE-PACKAGE)) (SETQ FILE-GROUP-SYMBOL (INTERN-LOCAL (FILE-SET-FN2 (GET-PNAME FILE-SYMBOL) ">") PKG-FILE-PACKAGE)) (PROG () (RETURN FILE-SYMBOL FILE-GROUP-SYMBOL))) ;; Does not handle multiple-line property lists. (DEFUN FILE-READ-PROPERTY-LIST (FILE-SYMBOL STREAM) (DO ((LINE) (EOF-P)) (()) (MULTIPLE-VALUE (LINE EOF-P) (FUNCALL STREAM ':LINE-IN)) (COND (EOF-P (RETURN NIL)) ((STRING-SEARCH-NOT-SET '(40 211) LINE) ;; This is the first non-blank line. (LET ((I (STRING-SEARCH "-*-" LINE))) (COND ((NOT (NULL I)) ;; The file has a property list. (SETQ I (+ I 3)) ;Move over -*- (LET ((END (STRING-SEARCH "-*-" LINE I))) ;; For now, don't handle the multiple-line case. (LET ((COLON (STRING-SEARCH ":" LINE I))) (COND ((OR (NULL COLON) (> COLON END)) (FILE-ADD-PROPERTY FILE-SYMBOL "MODE" (NSUBSTRING LINE I END))) (T ;; File has full hair with colons and semicolons. (DO ((START I (+ 1 SEMI)) (COLON) (SEMI)) (NIL) (SETQ COLON (STRING-SEARCH-CHAR #/: LINE START)) (COND ((OR (NULL COLON) (> COLON END)) (RETURN NIL))) (SETQ SEMI (STRING-SEARCH-CHAR #/; LINE (1+ COLON))) (COND ((OR (NULL SEMI) (> SEMI END)) (SETQ SEMI END))) (FILE-ADD-PROPERTY FILE-SYMBOL (NSUBSTRING LINE START COLON) (NSUBSTRING LINE (1+ COLON) SEMI)))))))))) (RETURN NIL)))) (FUNCALL STREAM ':SET-POINTER 0)) (DEFUN FILE-ADD-PROPERTY (FILE-SYMBOL INDICATOR VALUE &AUX COMMA) (COND ((SETQ COMMA (STRING-SEARCH-CHAR #/, VALUE)) (DO ((COMMA COMMA (STRING-SEARCH-CHAR #/, VALUE (1+ COMMA))) (BEG 0 (1+ COMMA)) (L NIL)) (NIL) (PUSH (INTERN (STRING-UPCASE (STRING-TRIM '(#\SP #\TAB) (NSUBSTRING VALUE BEG COMMA))) "") L) (COND ((NOT COMMA) (SETQ VALUE (NREVERSE L)) (RETURN NIL))))) (T (SETQ VALUE (INTERN (STRING-UPCASE (STRING-TRIM '(40 211) VALUE)) "")))) (PUTPROP FILE-SYMBOL VALUE (INTERN (STRING-UPCASE (STRING-TRIM '(40 211) INDICATOR)) ""))) (DEFUN READ-FUNCTIONS-FROM-FILE (FUNCTION-LIST FILE-NAME) (PROG (TEM LAST-THING-READ LOADED-LIST NAME STREAM) (SETQ STREAM (OPEN FILE-NAME '(READ))) LP (SETQ TEM (READ STREAM '*EOF*)) (COND ((EQ TEM '*EOF*) (CLOSE STREAM) (RETURN (LIST 'LOADED LOADED-LIST)))) (SETQ LAST-THING-READ TEM) (COND ((NOT (AND (MEMQ (CAR LAST-THING-READ) '(DEFUN MACRO)) (SETQ NAME (READ-FUNCTIONS-MAP-HEAD (CADR LAST-THING-READ) FUNCTION-LIST)))) (GO LP))) (SETQ LOADED-LIST (CONS NAME LOADED-LIST)) (COND ((EQ NAME (CADR LAST-THING-READ)) (EVAL TEM)) (T (EVAL (CONS (CAR LAST-THING-READ) (CONS NAME (CDDR LAST-THING-READ)))))) (GO LP) )) (DEFUN READ-FUNCTIONS-MAP-HEAD (HEAD FUNCTION-LIST) ;LIKE MEMQ, BUT ITEMS IN FUNCTION-LIST (PROG NIL ;CAN BE (READ Q-READ) ETC. RETURNS REAL L (COND ((NULL FUNCTION-LIST) (RETURN NIL)) ;NAME (IE READ). ((ATOM (CAR FUNCTION-LIST)) (COND ((EQ (CAR FUNCTION-LIST) HEAD) (RETURN HEAD)))) ((EQ (CADAR FUNCTION-LIST) HEAD) (RETURN (CAAR FUNCTION-LIST)))) (SETQ FUNCTION-LIST (CDR FUNCTION-LIST)) (GO L))) (DEFUN FILE-ERROR-STATUS (FILENAME) (LET ((ERROR (COND ((NOT FILE-USE-CHAOS) (LET ((CHAR (AR-1 (FILE-COMMAND "ERRSTA " FILENAME) 0))) (COND ((= CHAR 0) NIL) (T (- CHAR 40))))) (T (LET ((ERRNUM (READ-FROM-STRING (FILE-CHAOS-COMMAND "ERRSTA " FILENAME)))) (COND ((ZEROP ERRNUM) NIL) (T ERRNUM))))))) (IF (EQ ERROR 4) "FNF" ERROR))) ;;; Things for processing filenames. ;;; Nobody should know about the syntax of pathnames outside of this page. ;;; Since the format of path lists will change, ;;; nobody should know about them either outside of this page. ;;; The entry points are FILE-EXPAND-PATHNAME, FILE-DEFAULT-FN2, ;;; FILE-SET-FN2. (eval-when (compile) (special file-last-device file-last-directory file-last-fn1)) (setq file-last-device "DSK" file-last-directory "LISPM" file-last-fn1 "FOO") ;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. (defun file-spread-pathname (pathname &aux dev dir fn1 fn2) (cond ((stringp pathname) (do ((i 0) (ch) (tem) (next) (len (string-length pathname)) (j 0 (1+ j))) ((> j len)) (setq ch (cond ((= j len) ## ) (t (ar-1 pathname j)))) (cond ((string-search-char ch "//") (setq j (1+ j))) ((setq tem (string-search-char ch ":; ")) (setq next (string-upcase (nsubstring pathname i j))) (cond ((not (zerop (string-length next))) (selectq tem (0 (setq dev next)) (1 (setq dir next)) (2 (cond (fn2) (fn1 (setq fn2 next)) (t (setq fn1 next))))))) (setq i (1+ j))))) (list dev dir fn1 fn2)) ((listp pathname) ;MACLISP file-lists (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) ;old style n1 n2 dev dir (car pathname) (cadr pathname)))))) (t (ferror nil "~s is not an acceptable pathname" pathname)))) ;Replace NILs in a path with the defaults. Also update the ;defaults for the specified parts of the path. (defun file-default-path (path) (apply (function (lambda (dev dir fn1 fn2) (and dev (setq file-last-device dev)) (and dir (setq file-last-directory dir)) (and fn1 (setq file-last-fn1 fn1)) (or fn2 (setq fn2 ">")) (and (equal file-last-device "DSK") (setq file-last-device file-dsk-device-name)) (list file-last-device file-last-directory file-last-fn1 fn2))) path)) ;Turn a path list back into a pathname string. (defun file-unspread-path (path) (or (third path) (ferror nil "The path ~S contains no FN1" path)) (string-append (cond ((first path) (string-append (first path) ": ")) (t "")) (cond ((second path) (string-append (second path) "; ")) (t "")) (third path) " " (or (fourth path) ""))) ;Given a pathname string, default it and return a new pathname string. ; Also, for MACLISP compatibility, will accept MACLISP type LIST file spec lists. (defun file-expand-pathname (pathname) (cond ((fboundp 'nsubstring) (file-unspread-path (file-default-path (file-spread-pathname pathname)))) (t pathname))) ;Given two pathnames, default missing parts of first from second. (defun file-merge-pathnames (pathname1 pathname2) (file-unspread-path (file-merge-paths (file-spread-pathname pathname1) (file-spread-pathname pathname2)))) ;Internal merge function. (defun file-merge-paths (path1 path2) (do ((l1 path1 (cdr l1)) (l2 path2 (cdr l2)) (npath)) ((null l2) (nreverse npath)) (push (or (car l1) (car l2)) npath))) ;Old name for file-expand-pathname. (defun file-default-filenames (filename) (file-expand-pathname filename)) ;Given a pathname string, return a new one like it with the FN2 defaulted ;to the default we specify, unless there was an FN2 in the original. (defun file-default-fn2 (pathname default-fn2 &aux path) (cond ((fboundp 'nsubstring) (setq path (file-spread-pathname pathname)) (or (fourth path) (setf (fourth path) default-fn2)) (file-unspread-path path)) (t pathname))) ;Given a pathname string, return a new one like it but with the fn2 ;replaced. (defun file-set-fn2 (pathname fn2) (file-unspread-path (let ((path (file-spread-pathname pathname))) (setf (fourth path) fn2) path))) ;;; Returns the INFO for a file. Any errors signal errors. ** THIS COMMENT IS WRONG ** ;;; Takes a file symbol or a string. (DEFUN FILE-GET-FILE-INFO (FILENAME &AUX WINP) (COND (FILE-USE-CHAOS (MULTIPLE-VALUE (NIL WINP) (FILE-COMMAND "OPENRA " (STRING FILENAME)))) (T (SETQ WINP (NOT (FILE-COMMAND "OPENRA " (STRING FILENAME)))))) (AND WINP (PROG1 (STRING-APPEND (FILE-COMMAND "ININFO")) (FILE-COMMAND-CAREFUL "CLOSER")))) (DEFUN FILE-ININFO (IGNORE) (STRING-APPEND (FILE-COMMAND "ININFO"))) (DEFUN FILE-OUTINFO (IGNORE) (STRING-APPEND (FILE-COMMAND "OUTINFO"))) (DEFUN FILE-OUTRFN (IGNORE) (STRING-APPEND (FILE-COMMAND "OUTRFN")))