1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.* ;1;; Revision History* ;1;;* ;1;; 01/05/87 HW Change prog2 to progn of multiple-value-prog1 in* ;1;;* 1with-open-stream to allow it to return multiple values*. (Defmacro WITH-OPEN-STREAM ((stream construction-form) &BODY body) 1"Execute the BODY with the variable STREAM bound to the value of CONSTRUCTOR-FORM. On normal exit, close STREAM normally. On abnormal exit (throwing, errors, etc) close STREAM with argument :ABORT."* (LET ((gensym (GENSYM))) `(LET ((,gensym NIL) (.FILE-ABORTED-FLAG. :ABORT)) (UNWIND-PROTECT (PROGN (SETQ ,gensym ,construction-form) (MULTIPLE-VALUE-PROG1 (LET ((,stream ,gensym)) . ,body) (SETQ .FILE-ABORTED-FLAG. NIL))) (AND ,gensym (NOT (ERRORP ,gensym)) (FUNCALL ,gensym :CLOSE .FILE-ABORTED-FLAG.)))))) (Defmacro WITH-OPEN-STREAM-CASE ((STREAM CONSTRUCTION-FORM) &BODY CLAUSES) 1"Use CONSTRUCTOR-FORM to open a stream, using the CLAUSES as in CONDITION-CASE. The CLAUSES may contain a :NO-ERROR clause which will be executed, with STREAM bound to the resulting stream, if CONSTRUCTOR-FORM does not get an error. On normal exit from the :NO-ERROR clause, STREAM is closed normally. On abnormal exit (throwing, errors, etc) STREAM is closed with argument :ABORT."* (LET ((GENSYM (GENSYM))) `(LET ((,GENSYM NIL) (.FILE-ABORTED-FLAG. :ABORT)) (UNWIND-PROTECT (PROG1 (CONDITION-CASE (,STREAM) (SETQ ,GENSYM ,CONSTRUCTION-FORM) . ,CLAUSES) (SETQ .FILE-ABORTED-FLAG. NIL)) (AND ,GENSYM (NOT (ERRORP ,GENSYM)) (FUNCALL ,GENSYM :CLOSE .FILE-ABORTED-FLAG.)))))) (Defmacro WITH-INPUT-FROM-STRING ((stream string . keyword-args) &body body) 1"Execute BODY with STREAM bound to a stream to output into STRING. The values of BODY's last expression are returned. Keywords allowed are :START, :END and :INDEX. :START and :END can be used to specify a substring of STRING to be read from. Eof will then occur when :END is reached. If the :END value is NIL, that means the end of STRING. :INDEX specifies a SETF-able place to store the index of where reading stopped. This is done after exit from the body. It stores the index of the first unread character, or the index of eof if that was reached. / Old calling format: (STREAM STRING &OPTIONAL INDEX END), where INDEX serves as the value for the :START keyword and for the :INDEX keyword."* (LET (start end index decls realbody) (MULTIPLE-VALUE-SETQ (realbody decls) (PARSE-BODY body nil nil)) (IF (KEYWORDP (CAR keyword-args)) (SETQ start (GET (LOCF keyword-args) :start) index (GET (LOCF keyword-args) :index) end (GET (LOCF keyword-args) :end)) (SETQ start (CAR keyword-args) index (CAR keyword-args) end (CADR keyword-args))) `(LET ((,stream (MAKE-STRING-INPUT-STREAM ,string ,(OR start 0) ,@(if end `(,end))))) ,@(if decls `((DECLARE . ,(FLATTEN-DECLARATIONS decls)))) ,@(if index `((UNWIND-PROTECT (PROGN . ,realbody) (SETF ,index (SEND ,stream :get-string-index)))) realbody)))) (Defmacro WITH-OUTPUT-TO-STRING ((stream string index) &body body &aux (string-symbol string)) 1"Execute BODY with STREAM bound to a stream to output into STRING. If STRING is omitted, a new string with no fill pointer is created and returned. If STRING is supplied, that string's contents are modified destructively, and the values of BODY's last expression are returned. If INDEX is supplied, it should be a SETFable accessor which describes where to find the index to store into STRING, instead of at the end. The value of INDEX will be updated after the BODY is finished."* (MULTIPLE-VALUE-BIND (realbody decls) (PARSE-BODY body nil nil) (let ((doc (and decls `((DECLARE . ,(FLATTEN-DECLARATIONS decls)))))) (if index `(let* (,@(and (not (symbolp string)) `((,(setf string-symbol (gensym)) ,string))) (,stream (MAKE-STRING-OUTPUT-STREAM ,string-symbol ,index))) ,@doc (unwind-protect (progn ,@realbody) (SETF ,index (LENGTH ,string-symbol)))) `(LET ((,stream (MAKE-STRING-OUTPUT-STREAM ,@(if string `(,string))))) ,@doc ,@realbody ,@(if (null string ) `((GET-OUTPUT-STREAM-STRING ,stream)))))))) (Defmacro WITH-OPEN-FILE ((stream filename . options) &body body) 1"Execute the BODY with the variable STREAM bound to a stream for file FILENAME. FILENAME is opened using OPTIONS, which are the same as for the OPEN function. On normal exit, close STREAM normally. On abnormal exit (throwing, errors, etc) close STREAM with argument :ABORT."* `(WITH-OPEN-STREAM (,stream (OPEN ,filename . ,options)) . ,body)) (Defmacro WITH-OPEN-FILE-CASE ((STREAM FILENAME . OPTIONS) &BODY CLAUSES) 1"Use open a file stream from FILENAME and OPTIONS, using the CLAUSES as in CONDITION-CASE. FILENAME and OPTIONS are passed to OPEN. The CLAUSES may contain a :NO-ERROR clause which will be executed, with STREAM bound to the resulting stream, if OPEN does not get an error. On normal exit from the :NO-ERROR clause, STREAM is closed normally. On abnormal exit (throwing, errors, etc) STREAM is closed with argument :ABORT."* `(WITH-OPEN-STREAM-CASE (,stream (OPEN ,filename . ,options)) . ,clauses)) (Defmacro FORMAT:OUTPUT (stream &BODY forms) 1"Do output to STREAM using FORMS. Any string in FORMS is printed on STREAM; anything else in FORMS is evaluated with STANDARD-OUTPUT bound to STREAM. If STREAM is T, STANDARD-OUTPUT is used, and if STREAM is NIL a string is constructed from the output, and returned. Otherwise, STREAM is evaluated and the value used as a stream."* ;; note: format:format-string is a DEFVAR defined in the format file. (LET ((do-the-work (MAPCAR #'SI::output-expand forms))) (COND ((EQ stream t) `(PROGN . ,do-the-work)) ((NULL stream) `(LET ((*standard-output* 'Format:FORMAT-STRING-STREAM) (FORMAT::format-string (MAKE-ARRAY 128. :element-type 'string-char :FILL-POINTER 0))) (PROGN . ,do-the-work) (ADJUST-ARRAY FORMAT::format-string (ARRAY-ACTIVE-LENGTH FORMAT::format-string)) FORMAT::format-string)) (t `(LET ((*standard-output* ,stream)) . ,do-the-work))))) (Defun OUTPUT-EXPAND (form) (COND ((STRINGP form) `(PRINC ,form)) ((NUMBERP form) `(TYO ,form)) (t form))) (Defmacro FILE-RETRY-NEW-PATHNAME ((pathname-variable . condition-names) &body body) 1"Execute BODY with a handler for CONDITION-NAMES that reads a new pathname and tries again. If one of those conditions is signaled within BODY, a new pathname is read and put in PATHNAME-VARIABLE, and then BODY is executed again. This is most useful when BODY is an OPEN, DELETE2-*F2ILE*, etc."* (LET ((tag (GENSYM))) `(BLOCK file-retry-new-pn (TAGBODY RETRY (RETURN-FROM FILE-RETRY-NEW-PN (CATCH-CONTINUATION ',TAG #'(LAMBDA (NEW-PATHNAME) (SETQ ,PATHNAME-VARIABLE NEW-PATHNAME) (GO RETRY)) NIL (CONDITION-RESUME `(,',CONDITION-NAMES :NEW-PATHNAME T ("Try again with a new pathname, not telling the callers.") FILE-RETRY-RESUME-HANDLER ,',TAG) (CONDITION-BIND-DEFAULT ((,CONDITION-NAMES 'FILE-RETRY-HANDLER ,PATHNAME-VARIABLE ',TAG)) . ,BODY)))))))) (Defun FILE-RETRY-RESUME-HANDLER (error-object &OPTIONAL (tag 'file-retry-new-pathname) new-pathname) (DECLARE (IGNORE error-object)) (THROW tag new-pathname)) (Defun FILE-RETRY-HANDLER (error-object pathname &OPTIONAL (tag 'file-retry-new-pathname)) (FORMAT *QUERY-IO* "~&~A" error-object) (SETQ pathname (FS:PARSE-PATHNAME pathname)) (LET* ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* T) (FS:*NAME-SPECIFIED-DEFAULT-TYPE* NIL) (INPUT (PROMPT-AND-READ `(:PATHNAME-OR-END :DEFAULTS ,PATHNAME) "~&Pathname to use instead (default ~A)~%or ~C to enter debugger: " PATHNAME #\END))) (IF (EQL INPUT #\END) NIL (THROW TAG INPUT)))) (Defmacro FILE-RETRY-NEW-PATHNAME-IF (COND-FORM (PATHNAME-VARIABLE . CONDITION-NAMES) &BODY BODY) 1"Execute BODY with a handler for CONDITION-NAMES that reads a new pathname and tries again. If COND-FORM evaluates non-NIL, then if one of those conditions is signaled within BODY, a new pathname is read and put in PATHNAME-VARIABLE, and then BODY is executed again. This is most useful when BODY is an OPEN, DELETE2-*F2ILE*, etc."* (LET ((TAG (GENSYM))) `(BLOCK file-retry-new-pn (TAGBODY retry (RETURN-FROM file-retry-new-pn (CATCH-CONTINUATION ',TAG #'(LAMBDA (new-pathname) (SETQ ,pathname-variable new-pathname) (GO retry)) NIL (CONDITION-RESUME `(,',CONDITION-NAMES :NEW-PATHNAME T ("Try again with a new pathname, not telling the callers.") FILE-RETRY-RESUME-HANDLER ,',TAG) (CONDITION-BIND-DEFAULT-IF ,COND-FORM ((,CONDITION-NAMES 'FILE-RETRY-HANDLER ,PATHNAME-VARIABLE ',TAG)) . ,body)))))))) (Defmacro WITH-OPEN-FILE-RETRY ((stream (filename . condition-names) . options) &body body) 1"Like WITH-OPEN-FILE, but provides a :NEW-PATHNAME resume handler around the OPEN. Thus, if the open fails, condition handlers or the user can specify a new pathname and retry the open."* `(WITH-OPEN-STREAM (,STREAM (FILE-RETRY-NEW-PATHNAME-IF T (,FILENAME . ,CONDITION-NAMES) (OPEN ,FILENAME . ,OPTIONS))) . ,BODY)) (Defmacro WITH-OPEN-FILE-SEARCH ((STREAM (OPERATION DEFAULTS AUTO-RETRY) TYPE-LIST-AND-PATHNAME-FORM . OPEN-OPTIONS) &BODY BODY) 1"Open one of several filenames, the same except for the type component. Binds the variable STREAM to the resulting stream, executes the BODY, then closes the stream. OPEN-OPTIONS are alternating keywords and values, passed to OPEN. TYPE-LIST-AND-PATHNAME-FORM is evaluated to get two values: a list of pathname types to try, and a base pathname. The base pathname is merged successively with each type in the list. This is done using FS:MERGE-PATHNAME-DEFAULTS, with DEFAULTS's value used as the second argument and the type to be tried as the third argument. As soon as a merged pathname succeeds in being opened, we execute BODY. If they all fail, an error is signaled with condition FS:MULTIPLE-FILE-NOT-FOUND. OPERATION should eval to the name of the calling function; it is used for signaling. If AUTO-RETRY evals to non-NIL, then the user is asked to type a new pathname to retry with."* (LET ((BASE-PATHNAME-VAR (GENSYM)) (TYPE-LIST-VAR (GENSYM)) (DEFAULTS-VAR (GENSYM)) (AUTO-RETRY-VAR (GENSYM))) `(LET ((,DEFAULTS-VAR ,DEFAULTS) (,AUTO-RETRY-VAR ,AUTO-RETRY)) (MULTIPLE-VALUE-BIND (,TYPE-LIST-VAR ,BASE-PATHNAME-VAR) ,TYPE-LIST-AND-PATHNAME-FORM (FILE-RETRY-NEW-PATHNAME-IF ,AUTO-RETRY-VAR (,BASE-PATHNAME-VAR FS:FILE-ERROR) (WITH-OPEN-STREAM (,STREAM (FS:OPEN-FILE-SEARCH ,BASE-PATHNAME-VAR ,TYPE-LIST-VAR ,DEFAULTS-VAR ,OPERATION . ,OPEN-OPTIONS)) . ,BODY)))))) (Defmacro WITH-SYS-HOST-ACCESSIBLE (&BODY BODY) 1"Execute the BODY, making sure we can read files without user interaction. This is done by logging in if necessary (and logging out again when done)."* `(LET (UNDO-FORM) (UNWIND-PROTECT (PROGN (SETQ UNDO-FORM (MAYBE-SYS-LOGIN)) . ,BODY) (EVAL UNDO-FORM)))) (Defmacro WITH-INPUT-EDITING ((stream rubout-options . brand-s-compatibility-args) &body body) "Execute BODY inside of STREAM's :RUBOUT-HANDLER method. If BODY does input from STREAM, it will be done with rubout processing if STREAM implements any. RUBOUT-OPTIONS should be the options for the :RUBOUT-HANDLER message, such as (:NO-INPUT-SAVE T) -- don't save this batch of input in the history. (:FULL-RUBOUT T) -- return from this construct if rubout buffer becomes empty. (:INITIAL-INPUT string) -- start out with that string in the buffer. (:INITIAL-INPUT-POINTER n) -- start out with editing pointer n chars from start. (:ACTIVATION fn x-args) -- fn is used to test characters for being activators. fn's args are the character read followed by the x-args from the option. If fn returns non-NIL, the character is an activation. It makes a blip (:ACTIVATION char numeric-arg) which BODY can read with :ANY-TYI. (:DO-NOT-ECHO chars...) -- poor man's activation characters. This is like the :ACTIVATION option except that: characters are listed explicitly; and the character itself is returned when it is read, rather than an :ACTIVATION blip. (:COMMAND fn x-args) -- tests like :ACTIVATION, but command chars do a different thing. If fn returns non-NIL, the character is a command character. The :RUBOUT-HANDLER operation (and therefore the WITH-INPUT-EDITING) returns instantly these two values: (:COMMAND char numeric-arg) :COMMAND. The input that was buffered remains in the buffer. (:PREEMPTABLE token) -- makes all blips act like command chars. If the rubout handler encounters a blip while reading input, it instantly returns two values: the blip itself, and the specified token. Any buffered input remains buffered for the next request for input editing. (:EDITING-COMMAND (char doc)...) -- user-implemented \"editing\" commands. If any char in the alist is read by the rubout handler, it is returned to the caller (that is, to an :ANY-TYI in BODY). BODY should process these characters in appropriate ways and keep reading. (:PASS-THROUGH chars...) -- makes chars not be treated specially by the rubout handler. Useful for getting characters such as † into the buffer. Only works for characters with no control, meta, etc bits set. (:PROMPT fn-or-string) Says how to prompt initially for the input. If a string, it is printed; otherwise it is called with two args, the stream and a character which is an editing command that says why the prompt is being printed. (:REPROMPT fn-or-string) Same as :PROMPT except used only if the input is reprinted for some reason after editing has begun. The :REPROMPT option is not used on initial entry. If both :PROMPT and :REPROMPT are specified, :PROMPT is used on initial entry and :REPROMPT thereafter." (LET ((keyword (CADR brand-s-compatibility-args))) (UNLESS stream (SETQ stream '*standard-input*)) `(FLET ((DO-IT () . ,body)) (IF (SEND ,stream ':operation-handled-p ':rubout-handler) ,(IF keyword `(WITH-STACK-LIST* (options ',(CASE keyword (:end-activation '(:activation = #\end)) ((:line :line-activation) '(:activation memq (#\end #\newline)))) ,rubout-options) (SEND ,stream ':rubout-handler options #'do-it)) `(SEND ,stream ':rubout-handler ,rubout-options #'do-it)) ;; ELSE (DO-IT)))))