;; -*- Mode:Lisp; Package:FORMAT; Base:8 -*- ;; Function for printing or creating nicely formatted strings. ;; written by Andrew L. Ressler on September 8, 1982 ;; copyright LISP MACHINE INC. ;; permission granted to anyone to use this or modify it. ;; attempt to turn format into a macro facility ;; if it can't do it easily it just makes it call format instead. (defvar format-results NIL) (defvar final-format-results NIL) (defvar inside-conditional NIL) (defvar optimize-lets T) (defmacro format-macro (stream ctl-string &REST args) (prog () (setq final-format-results NIL) (let ((FORMAT-ARGLIST ARGS) (LOOP-ARGLIST NIL)(value)) (setq value (*Catch 'IMPOSSIBLE (*CATCH 'FORMAT-/:^-POINT (*CATCH 'FORMAT-^-POINT (COND ((STRINGP CTL-STRING) (FORMAT-CTL-STRING-macro ARGS CTL-STRING)) (T (return `(format ,stream ,ctl-string . ,args)))))))) (if (eq value 'IMPOSSIBLE) (return `(format ,stream ,ctl-string . ,args)))) (return (let ((result (if (null stream) `(progn ;;; Only bind FORMAT-STRING if STREAM is NIL. This avoids lossage if ;;; FORMAT with a first arg of NIL calls FORMAT recursively (e.g. if ;;; printing a named structure). (bind (value-cell-location 'FORMAT-STRING) (make-array 200 ':AREA FORMAT-TEMPORARY-AREA ':TYPE 'ART-STRING ':LEADER-LIST '(0))) (let ((standard-output 'FORMAT-STRING-STREAM)) ,@(nreverse final-format-results)) (prog1 (substring format-string 0) (return-array format-string))) `(let ((standard-output ,(cond ((eq stream T) 'standard-output) (T stream)))) . ,(nreverse final-format-results))))) (if optimize-lets (setq result (elim-lets result)) result))))) (defun format-ctl-string-macro (ARGS CTL-STRING &AUX (FORMAT-PARAMS NIL)) (UNWIND-PROTECT (DO ((CTL-INDEX 0) (CTL-LENGTH (ARRAY-ACTIVE-LENGTH CTL-STRING)) (TEM)) ((>= CTL-INDEX CTL-LENGTH)) (SETQ TEM (%STRING-SEARCH-CHAR #/~ CTL-STRING CTL-INDEX CTL-LENGTH)) (COND ((NEQ TEM CTL-INDEX) ;Put out some literal string (push `(funcall standard-output ':STRING-OUT ,(substring CTL-STRING CTL-INDEX ;If you really supply the fourth arg, ;it had better be a string index or some ;streams will bomb. (IF (NULL TEM) (ARRAY-ACTIVE-LENGTH CTL-STRING) tem))) final-format-results) (IF (NULL TEM) (RETURN)) (SETQ CTL-INDEX TEM))) ;; (AREF CTL-STRING CTL-INDEX) is a tilde. (LET ((ATSIGN-FLAG NIL) (COLON-FLAG NIL) (format-results NIL) (flush-let NIL)) (IF (NULL FORMAT-PARAMS) (SETQ FORMAT-PARAMS (ALLOCATE-RESOURCE 'FORMAT-PARAMS))) (STORE-ARRAY-LEADER 0 FORMAT-PARAMS 0) (MULTIPLE-VALUE (TEM ARGS) (FORMAT-PARSE-COMMAND ARGS T)) (multiple-value (ARGS flush-let) (FORMAT-CTL-OP-macro TEM ARGS (G-L-P FORMAT-PARAMS))) (if flush-let (push (cons 'PROGN (nreverse format-results)) final-format-results) (push `(let ((atsign-flag ,ATSIGN-FLAG) (colon-flag ,colon-flag)) . ,(nreverse format-results)) final-format-results)))) (AND FORMAT-PARAMS (DEALLOCATE-RESOURCE 'FORMAT-PARAMS FORMAT-PARAMS))) ARGS) ;Perform a single formatted output operation on specified args. ;Return the remaining args not used up by the operation. (defun format-ctl-op-macro (op args params &AUX tem immediate) (cond ((null op) (format-error "Undefined FORMAT command.") args) ;e.g. not interned ((setq tem (get op 'FORMAT-CTL-ONE-ARG)) (if (setq immediate (get op 'EVAL-IMMEDIATE)) (progn (funcall immediate (car args) params) (values (cdr args) T)) (push `(funcall ',tem ,(copytree (first args)) ',(copytree params)) format-results) (cdr args))) ((setq tem (get op 'FORMAT-CTL-NO-ARG)) (if (setq immediate (get op 'eval-immediate)) (progn (funcall immediate params) (values args T)) (push `(funcall ',TEM ',(copytree params)) format-results) args)) ((setq tem (get op 'FORMAT-CTL-MULTI-ARG)) (if (setq immediate (get op 'eval-immediate)) (values (funcall immediate args params) T) (push `(funcall ',TEM ,(copytree args) ,(copytree params)) format-results))) ((setq tem (get op 'FORMAT-CTL-REPEAT-CHAR)) (push `(format-ctl-repeat-char ,(copytree (or (first params) 1)) ,tem) format-results) (values args T)) (T (FORMAT-ERROR "/"~S/" is not defined as a FORMAT command." OP) args))) (defprop * format-ctl-ignore-macro eval-immediate) (defun format-ctl-ignore-macro (args params &AUX (count (or (car params) 1))) (if colon-flag (do ((a format-arglist (cdr a)) (b (nthcdr count format-arglist) (cdr b))) ((null a) (format-error "Can't back up properly for a ~:*")) (and (eq b args) (return a))) (nthcdr count args))) (defprop crlf crlf-macro eval-immediate) (defun crlf-macro (ignore) (and atsign-flag (push '(funcall standard-output ':TYO #\CR) format-results))) (defprop % format-ctl-newlines-macro eval-immediate) (defun format-ctl-newlines-macro (params &AUX (count (or (car params) 1))) (dotimes (i count) (push '(funcall standard-output ':TYO #\CR) format-results))) (defprop & format-ctl-fresh-line-macro eval-immediate) (defun format-ctl-fresh-line-macro (params &AUX (count (or (car params) 1))) (push '(funcall standard-output ':FRESH-LINE) format-results) (do i (1- count) (1- i) (= i 0) (push '(FUNCALL STANDARD-OUTPUT ':TYO #\CR) format-results))) (defprop d format-ctl-decimal-macro eval-immediate) (defun format-ctl-decimal-macro (arg params &OPTIONAL (base 10.) ;Also called for octal &AUX (width (first params)) (padchar (second params)) (commachar (third params)) (gen-arg (gensym))) (setq padchar (cond ((null padchar) #\SP) ((numberp padchar) padchar) (T (aref (string padchar) 0))) commachar (cond ((null commachar) #/,) ((numberp commachar) commachar) (T (aref (string commachar) 0)))) (push `(let ((base ,base)(*nopoint T)(,gen-arg ,arg)) ,@(if width `((format-ctl-justify ,width (+ (if (typep ,gen-arg ':FIXNUM) (+ (LOOP FOR x = (abs ,gen-arg) THEN (// x base) COUNT T UNTIL (< x base)) (if (minusp ,gen-arg) 1 0)) (flatc ,gen-arg)) ,(if atsign-flag `(if (and (numberp ,gen-arg)(not (minusp ,gen-arg))) 1 0) 0) ,(if colon-flag `(if (fixp ,gen-arg) (// (1- (flatc (abs ,gen-arg))) 3) 0) 0)) ,padchar)) NIL) ,@(if atsign-flag `((if (and (numberp ,gen-arg)(not (minusp ,gen-arg))) (funcall standard-output ':TYO #/+))) NIL) ,(if colon-flag `(cond ((fixp ,gen-arg) ;; Random hair with commas. I'm not going to bother not consing. (cond ((minusp ,gen-arg) (funcall standard-output ':TYO #/-) (setq ,gen-arg (- ,gen-arg)))) (setq ,gen-arg (nreverse (inhibit-style-warnings ;Give up! (exploden ,gen-arg)))) (do ((l ,gen-arg (cdr l)) (i 2 (1- i))) ((null (cdr l))) (cond ((zerop i) (rplacd l (cons ,commachar (cdr l))) (setq i 3 l (cdr l))))) (dolist (ch (nreverse ,gen-arg)) (funcall standard-output ':TYO ch))) ((typep ,gen-arg ':FIXNUM) (si:print-fixnum ,gen-arg standard-output)) ;; This is PRINC rather than PRIN1 ;; so you can have a string instead of a number (T (princ ,gen-arg))) `(cond ((typep ,gen-arg ':FIXNUM) (si:print-fixnum ,gen-arg standard-output)) ;; This is PRINC rather than PRIN1 ;; so you can have a string instead of a number (T (princ ,gen-arg))))) format-results)) (defprop o format-ctl-octal-macro eval-immediate) (defun format-ctl-octal-macro (arg params) (format-ctl-decimal-macro arg params 8)) (defprop f format-ctl-f-format-macro eval-immediate) (defun format-ctl-f-format-macro (arg params) (push `(let ((arg ,arg)) (and (numberp arg) (not (floatp arg)) (setq arg (float arg))) (if (not (floatp arg)) ,(let ((format-results NIL)) (format-ctl-decimal-macro 'ARG NIL) format-results) (si:print-flonum arg standard-output NIL (small-floatp arg) ,(first params) NIL))) format-results)) (defprop e format-ctl-e-format-macro eval-immediate) (defun format-ctl-e-format-macro (arg params) (push `(let ((arg ,arg)) (and (numberp arg) (not (floatp arg)) (setq arg (float arg))) (if (not (floatp arg)) ,(let ((format-results NIL)) (format-ctl-decimal-macro 'ARG NIL) format-results) (si:print-flonum arg standard-output NIL (small-floatp arg) ,(first params) T))) format-results)) (defprop A format-ctl-ascii-macro eval-immediate) (defun format-ctl-ascii-macro (arg params &OPTIONAL prin1p) (let ((edge (car params)) (period (cadr params)) (min (caddr params)) (padchar (cadddr params))) (cond ((null padchar) (setq padchar #\SP)) ((not (numberp padchar)) (setq padchar (character padchar)))) (cond (atsign-flag) ;~@5nA right justifies (colon-flag (if prin1p (push `(cond ((null ,arg) (funcall standard-output ':STRING-OUT "()")) (T (prin1 ,ARG))) format-results) (push `(cond ((null ,arg) (funcall standard-output ':STRING-OUT "()")) ((stringp ,arg) (funcall standard-output ':STRING-OUT ,arg)) (T (princ ,arg))) format-results))) (prin1p (push `(prin1 ,ARG) format-results)) (T (push `(if (stringp ,ARG)(funcall standard-output ':STRING-OUT ,ARG) (princ ,ARG)) format-results))) (cond ((not (null edge)) (push `(let ((width ,(if prin1p `(funcall #'FLATSIZE ,ARG) `(cond ((stringp ,ARG) #'ARRAY-ACTIVE-LENGTH) (T #'FLATC))))) ,@(cond (min `((progn (format-ctl-repeat-char ,min ,padchar) (setq width (+ width ,min)))))) ,(cond (period `(progn (format-ctl-repeat-char (- (+ ,edge (* (// (+ (- (max ,edge width) ,edge 1) ,period) ,period) ,period)) width) ,padchar))) (T (progn `(format-ctl-justify edge width ,padchar))))) format-results))) (cond ((null atsign-flag)) (colon-flag (if prin1p (push `(cond ((null ,arg) (funcall standard-output ':STRING-OUT "()")) (T (prin1 ,ARG))) format-results) (push `(cond ((null ,arg) (funcall standard-output ':STRING-OUT "()")) ((stringp ,arg) (funcall standard-output ':STRING-OUT ,arg)) (T (princ ,arg))) format-results))) (prin1p (push `(prin1 ,ARG) format-results)) (T (push `(if (stringp ,ARG)(funcall standard-output ':STRING-OUT ,ARG) (princ ,ARG)) format-results))))) (defprop s format-ctl-sexp-macro eval-immediate) (defun format-ctl-sexp-macro (arg params) (format-ctl-ascii-macro arg params T)) (defprop g format-ctl-goto-macro eval-immediate) (defun format-ctl-goto-macro (ignore params &AUX (count (or (car params) 1))) (nthcdr count format-arglist)) (defprop p format-ctl-plural-macro eval-immediate) (defun format-ctl-plural-macro (args ignore) (and colon-flag (setq args (format-ctl-ignore-macro args NIL))) ;crock: COLON-FLAG is set (if atsign-flag (push `(if (equal ,(car args) 1) (funcall standard-output ':TYO #/y) (funcall standard-output ':STRING-OUT "ies")) format-results) (push `(or (equal,(car args) 1) (funcall standard-output ':TYO #/s)) format-results)) (cdr args)) (defprop q format-ctl-apply-macro eval-immediate) (defun format-ctl-apply-macro (arg params) (push `(apply ,arg ,params) format-results)) (defprop t format-ctl-tab-macro eval-immediate) (defun format-ctl-tab-macro (params &AUX (dest (or (first params) 1)) (extra (or (second params) 1))) (push `(let ((ops (funcall standard-output ':WHICH-OPERATIONS))(incr-ok)) (cond ((or (setq incr-ok (memq ':INCREMENT-CURSORPOS ops)) (memq ':SET-CURSORPOS ops)) (multiple-value-bind (x y) (funcall standard-output ':READ-CURSORPOS ,(if colon-flag '':PIXEL '':CHARACTER)) (let ((new-x ;next multiple of EXTRA after X (if (< x ,dest) ,dest ,(if (eq extra 1) `(1+ x) `(* (1+ (// x ,extra)) ,extra))))) (cond (incr-ok ;; Use :INCREMENT-CURSORPOS preferentially ;; because it will do a **MORE** if we need one. (funcall standard-output ':INCREMENT-CURSORPOS (- new-x x) 0 ,(if colon-flag '':PIXEL '':CHARACTER))) (T (funcall standard-output ':SET-CURSORPOS new-x y ,(if colon-flag '':PIXEL '':CHARACTER))))))) (T (funcall standard-output ':STRING-OUT " ")))) format-results)) (defprop [ format-ctl-start-case-macro eval-immediate) (defun format-ctl-start-case-macro (args params &AUX (arg (car args))) (let ((inside-conditional T)) (let ((clauses (format-parse-clauses '] T)) (remaining-args 'NO-ARGS)) (cond (colon-flag (cond (atsign-flag (format-error "~~:@[ is not a defined FORMAT command")) (T (pop args)))) (atsign-flag (*THROW 'IMPOSSIBLE 'IMPOSSIBLE)) (T (pop args))) (push `(let ((arg ,(COND (COLON-FLAG (COND (ATSIGN-FLAG (FORMAT-ERROR "~~:@[ is not a defined FORMAT command")) (T `(if ,ARG 1 0)))) (ATSIGN-FLAG `(if ,ARG 0 -1)) ((CAR PARAMS) (CAR PARAMS)) (T arg)))) ,(cons 'cond (LOOP FOR clause ON (g-l-p clauses) BY #'CDDDR FOR clause-number FROM 0 AS string = (first clause) AS code = (let* ((final-format-results NIL) (arguments (format-ctl-string-macro args string))) (if (or (eq remaining-args 'NO-ARGS) (equal remaining-args arguments)) (setq remaining-args arguments) (*Throw 'IMPOSSIBLE 'IMPOSSIBLE)) (nreverse final-format-results)) COLLECT `((= ,clause-number arg) . ,code)))) format-results) remaining-args))) (defprop ] format-ctl-end-case-macro eval-immediate) (defun format-ctl-end-case-macro (ignore) (format-error "Stray ~~] in FORMAT control string")) (defun elim-lets (tree) (cond ((null tree) NIL) ((atom tree) tree) ((listp tree) (setq tree (eliminate-lets tree)) (elim-lets (first tree)) (elim-lets (cdr tree)) tree))) (defun eliminate-lets (tree) (if (and (listp tree) (listp (first tree)) (listp (second tree))) (if (and (eq 'LET (first (first tree))) (eq 'LET (first (second tree)))) ;; then maybe we can eliminate something (if (equal (second (first tree))(second (second tree))) ;; then we can eliminate the lets probably. (progn (setf (second tree) `(let ,(second (first tree)) ,(third (first tree)) ,(third (second tree)))) (setf (first tree) '(progn))) tree) tree) tree)) (defprop /| format-ctl-forms-macro eval-immediate) (defun format-ctl-forms-macro (params) (if colon-flag (push `(if (memq ':CLEAR-SCREEN (funcall standard-output ':WHICH-OPERATIONS)) (funcall standard-output ':CLEAR-SCREEN) (format-ctl-repeat-char ,(or (first params) 1) #\FORM)) format-results) (push `(format-ctl-repeat-char ,(or (first params) 1) #\FORM) format-results))) (defprop { format-iterate-over-list-maco eval-immediate) (defun format-iterate-over-list-maco (&REST ignore) (*Throw 'IMPOSSIBLE 'IMPOSSIBLE)) (defprop ^ format-ctl-terminate-macro eval-immediate) (defun format-ctl-terminate-macro (&REST ignore) (*Throw 'IMPOSSIBLE 'IMPOSSIBLE)) ;This is not so hairy as to work with ~T, tabs, crs. I really don't see how to do that. ;It makes a list of strings, then decides how much spacing to put in, ;then goes back and outputs. (defprop < format-hairy-justification-macro eval-immediate) (defun format-hairy-justification-macro (&REST ignore) (*Throw 'IMPOSSIBLE 'IMPOSSIBLE)) (comment (defun format-hairy-justification-macro (args params) (let ((mincol (or (first params) 0)) (colinc (or (second params) 1)) (minpad (or (third params) 0)) (padchar (or (fourth params) #\SP))(temp-results NIL)) `(let ((newline NIL) (extra 0) (linewidth NIL) (strings NIL) (string-ncol 0) (clauses) (n-padding-points -1) (total-padding) (n-pads) (n-extra-pads)) (push '((W-O (FUNCALL STANDARD-OUTPUT ':WHICH-OPERATIONS))) temp-results) (and colon-flag (setq n-padding-points (1+ n-padding-points))) (and atsign-flag (setq n-padding-points (1+ n-padding-points))) (*catch 'FORMAT-^-POINT (progn (setq clauses (format-parse-clauses '> T)) (do ((specs (g-l-p clauses) (cdddr specs)) (str)) ((null specs)) (multiple-value (args str-code) (format-ctl-string-to-string args (car specs))) (push `(setq str ,str-code) temp-results) (push `(progn (setq string-ncol (+ (string-length str) string-ncol)) (setq n-padding-points (1+ n-padding-points)) (setq strings (cons-in-area str strings format-temporary-area))) temp-results)))) (push `(setq strings (nreverse strings)) temp-results) (cond ((and (g-l-p clauses) (oddp (cadr (g-l-p clauses)))) (push `(progn (setq newline (pop strings)) (and ,(caddr (g-l-p clauses)) (setq extra ,(or (car (g-l-p (caddr (g-l-p clauses)))) 0) linewidth ,(cadr (g-l-p (caddr (g-l-p clauses)))))) (setq string-ncol (- string-ncol (string-length newline))) (setq n-padding-points (1- n-padding-points))) temp-results))) (push `(progn (and (zerop n-padding-points) ;With no options and no ~; right-justify (setq colon-flag T n-padding-points 1)) ;; Get the amount of space needed to print the strings and MINPAD padding (setq total-padding (+ (* n-padding-points minpad) string-ncol)) ;; Now bring in the MINCOL and COLINC constraint, i.e. the total width is ;; at least MINCOL and exceeds MINCOL by a multiple of COLINC, and ;; get the total amount of padding to be divided among the padding points (setq total-padding (- (+ mincol (* colinc (// (+ (max (- total-padding mincol) 0) (1- colinc)) colinc))) string-ncol)) ;; Figure out whether a newline is called for or not. (cond ((and newline (memq ':READ-CURSORPOS w-o) (> (+ (funcall standard-output ':READ-CURSORPOS ':CHARACTER) string-ncol total-padding extra) (or linewidth (and (memq ':SIZE-IN-CHARACTERS w-o) (funcall standard-output ':SIZE-IN-CHARACTERS)) 95.))) (funcall standard-output ':STRING-OUT newline))) ;; Decide how many pads at each padding point + how many of the leftmost ;; padding points need one extra pad. (setq n-pads (// total-padding n-padding-points) n-extra-pads (\ total-padding n-padding-points)) (or (zerop n-extra-pads) (setq n-pads (1+ n-pads))) ;; Output the stuff (do ((strings strings (cdr strings)) (pad-before-p colon-flag t)) ((null strings)) (cond (pad-before-p (format-ctl-repeat-char n-pads ,padchar) (and (zerop (setq n-extra-pads (1- n-extra-pads))) (setq n-pads (1- n-pads))))) (funcall standard-output ':STRING-OUT (first strings))) ;; Finally spacing at the right ,@(and atsign-flag `((format-ctl-repeat-char n-pads ,padchar))) ;; Reclamation (dolist (str (nreverse strings)) (return-array str)) (and newline (return-array newline)) (format-reclaim-clauses clauses)) temp-results) (push (cons 'LET (nreverse temp-results)) format-results) args)))) (defprop > format-ctl-end-hairy-justification-macro eval-immediate) (defun format-ctl-end-hairy-justification-macro (ignore) (format-error "Stray ~~> in FORMAT control string")) ;;; This function is like FORMAT-CTL-STRING except that instead of sending to ;;; STANDARD-OUTPUT it sends to a string and returns that as its second value. ;;; The returned string is in the temporary area. (defun format-ctl-string-to-string-macro (args str) (let* ((format-results) (args-result (format-ctl-string args str))) (values args-result `(let ((format-string (make-array 200 ':AREA format-temporary-area ':TYPE 'ART-STRING ':LEADER-LIST '(0))) (standard-output 'FORMAT-STRING-STREAM)) ,@(nreverse format-results) (adjust-array-size format-string (array-active-length format-string))))))