From bfcd79843bf7714b7afbf47148815619ac3b7c20 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 2 Dec 1991 18:56:15 +0000 Subject: [PATCH] Several bug fixes. --- code/format.lisp | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/code/format.lisp b/code/format.lisp index a3162b51d..f869192f5 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.16 1991/12/01 18:06:36 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.17 1991/12/02 18:56:15 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1357,7 +1357,7 @@ :complaint "Cannot specify both colon and at-sign.") (expand-bind-defaults ((posn 0)) params `(if (<= 0 ,posn (length orig-args)) - (setf args (subseq orig-args ,posn)) + (setf args (nthcdr ,posn orig-args)) (error 'format-error :complaint "Index ~D out of bounds. Should have been ~ between 0 and ~D." @@ -1370,7 +1370,7 @@ ((eq arg-ptr args) (let ((new-posn (- cur-posn ,n))) (if (<= 0 new-posn (length orig-args)) - (setf args (subseq orig-args new-posn)) + (setf args (nthcdr new-posn orig-args)) (error 'format-error :complaint "Index ~D out of bounds. Should have been ~ @@ -1391,7 +1391,7 @@ :complaint "Cannot specify both colon and at-sign.") (interpret-bind-defaults ((posn 0)) params (if (<= 0 posn (length orig-args)) - (setf args (subseq orig-args posn)) + (setf args (nthcdr posn orig-args)) (error 'format-error :complaint "Index ~D out of bounds. Should have been ~ between 0 and ~D." @@ -1403,7 +1403,7 @@ ((eq arg-ptr args) (let ((new-posn (- cur-posn n))) (if (<= 0 new-posn (length orig-args)) - (setf args (subseq orig-args new-posn)) + (setf args (nthcdr new-posn orig-args)) (error 'format-error :complaint "Index ~D out of bounds. Should have been ~ @@ -1465,7 +1465,7 @@ :complaint "No corresponding close paren.")) (let* ((posn (position close directives)) (before (subseq directives 0 posn)) - (after (subseq directives (1+ posn)))) + (after (nthcdr (1+ posn) directives))) (values (expand-bind-defaults () params `(let ((stream (make-case-frob-stream stream @@ -1487,7 +1487,7 @@ (interpret-bind-defaults () params (let* ((posn (position close directives)) (before (subseq directives 0 posn)) - (after (subseq directives (1+ posn))) + (after (nthcdr (1+ posn) directives)) (stream (make-case-frob-stream stream (if colonp (if atsignp @@ -1521,7 +1521,7 @@ :complaint "No corresponding close bracket.")) (let ((posn (position close-or-semi remaining))) (push (subseq remaining 0 posn) sublists) - (setf remaining (subseq remaining (1+ posn))) + (setf remaining (nthcdr (1+ posn) remaining)) (when (char= (format-directive-character close-or-semi) #\]) (return)) (setf last-semi-with-colon-p @@ -1747,7 +1747,7 @@ (setf loop `(let ((inside-string (next-arg))) ,loop))) - (values loop (subseq directives (1+ posn)))))))) + (values loop (nthcdr (1+ posn) directives))))))) (def-complex-format-interpreter #\{ (colonp atsignp params string end directives) @@ -1802,7 +1802,7 @@ (setf args (do-loop orig-args args)) (let ((arg (next-arg))) (do-loop arg arg))) - (subseq directives (1+ posn))))))) + (nthcdr (1+ posn) directives)))))) (def-complex-format-directive #\} () (error 'format-error @@ -1854,7 +1854,7 @@ :complaint "No corresponding close bracket.")) (let ((posn (position close-or-semi remaining))) (segments (subseq remaining 0 posn)) - (setf remaining (subseq remaining (1+ posn)))) + (setf remaining (nthcdr (1+ posn) remaining))) (when (char= (format-directive-character close-or-semi) #\>) (setf close close-or-semi) @@ -1911,7 +1911,7 @@ (when (and first-semi (format-directive-colonp first-semi)) (interpret-bind-defaults ((extra 0) - (line-len (or (lisp::line-length stream) 72))) + (len (or (lisp::line-length stream) 72))) (format-directive-params first-semi) (setf newline-string (with-output-to-string (stream) @@ -1921,20 +1921,21 @@ orig-args args)))) (setf extra-space extra) - (setf line-len line-len))) + (setf line-len len))) (dolist (segment segments) (push (with-output-to-string (stream) (setf args (interpret-directive-list stream segment orig-args args))) - strings)))) + strings)) + args)) (format-justification stream newline-string extra-space line-len strings colonp atsignp mincol colinc minpad padchar))) args) (defun format-justification (stream newline-prefix extra-space line-len strings pad-left pad-right mincol colinc minpad padchar) - + (setf strings (reverse strings)) (when (and (not pad-left) (not pad-right) (null (cdr strings))) (setf pad-left t)) (let* ((num-gaps (+ (1- (length strings)) -- GitLab