Changeset 15416


Ignore:
Timestamp:
Jun 27, 2012, 1:42:41 AM (7 years ago)
Author:
gb
Message:

Fix some cases of improper/insufficient escaping when printing symbols.
Fixes ticket:985 in the trunk.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-io.lisp

    r15344 r15416  
    10171017           (optimize (speed 3)(safety 0)))
    10181018  (let* ((readtable *readtable*)
    1019          (readcase (readtable-case (if *print-readably*
    1020                                        %initial-readtable%
    1021                                        readtable)))
    1022          (escape? (or *print-readably* *print-escape*)))
    1023       (flet ((slashify? (char)
    1024                (declare (type character char))
    1025                (and escape?
    1026                     (if (alpha-char-p char)
    1027                       (if (eq readcase :upcase)
    1028                         (lower-case-p char)  ; _tolower
    1029                         (if (eq readcase :downcase)
    1030                           (upper-case-p char)))
    1031                       ; should be using readtable here - but (get-macro-character #\|) is nil
    1032                       (not (%str-member
    1033                             char
    1034                             "!$%&*0123456789.<=>?@[]^_{}~+-/")))))
     1019         (syntax-readtable (if *print-readably*
     1020                             %initial-readtable%
     1021                             readtable))
     1022         (readcase (readtable-case syntax-readtable))
     1023         (attrtab (rdtab.ttab syntax-readtable))
     1024         (escape? (or *print-readably* *print-escape*))
     1025         (needs-escape nil))
     1026    (flet ((slashify? (char)
     1027             (declare (type character char))
     1028             (and escape?                 
     1029                  (or (and (eq readcase :upcase) (lower-case-p char))
     1030                      (and (eq readcase :downcase) (upper-case-p char))
     1031                      (eql char #\:)
     1032                      (not (eql $cht_cnst (%character-attribute char attrtab))))))
    10351033             (single-case-p (name)
    1036                (let ((sofar nil))
    1037                  (dotimes (i (length name) sofar)
    1038                    (declare (type fixnum i))
    1039                    (declare (type simple-string name))
    1040                    (let* ((c (schar name i))
    1041                           (c-case (if (upper-case-p c)
    1042                                     :upcase
    1043                                     (if (lower-case-p c)
    1044                                       :downcase))))
    1045                      (when c-case
    1046                        (if sofar
    1047                          (if (neq sofar c-case)
    1048                            (return nil))
    1049                          (setq sofar c-case))))))))
    1050         (declare (dynamic-extent #'slashify? #'single-case-p))
    1051         (block alice
    1052           (let ((len (length name))
    1053                 (slash-count 0)
    1054                 (last-slash-pos 0))
    1055             (declare (type fixnum len)
    1056                      (type fixnum slash-count last-slash-pos))               
    1057             (when escape?
    1058               (when (or (%izerop len)
    1059                         ;; if more than a few \, just use |...|
    1060                         (and (not (memq readcase '(:invert :preserve))) ; these never slashify alpha-p
    1061                              (let ((m (max (floor len 4) 2)))
    1062                                (dotimes (i (the fixnum len) nil)
    1063                                  (declare (type fixnum i))
    1064                                  (when (slashify? (schar name i))
    1065                                    (setq slash-count (%i+ slash-count 1))
    1066                                    (when (or (eql slash-count m)
    1067                                              (eq i (1+ last-slash-pos)))
    1068                                      (return t))
    1069                                    (setq last-slash-pos i)))))
    1070                         ;; or could be read as a number
    1071                         (handler-case (%parse-number-token name 0 len *print-base*)
    1072                           (arithmetic-error (c) (declare (ignore c)) t))
    1073                         ;; or symbol consisting entirely of .'s
    1074                         (dotimes (i len t)
    1075                           (declare (fixnum i))
    1076                           (unless (eql (schar name i) #\.)
    1077                             (return nil))))
    1078                 (return-from alice
    1079                   (write-escaped-string name stream #\|))))
    1080             (case readcase
    1081               (:preserve (return-from alice  (write-string name stream :start  0 :end len)))
    1082               (:invert (return-from alice
    1083                          (cond ((single-case-p name)(write-perverted-string name stream len :invert))
    1084                                (t (write-string name stream :start  0 :end len)))))
    1085               (t
    1086                (when (eql slash-count 0)
    1087                  (return-from alice
    1088                    (cond ((eq readcase case)
    1089                           (write-string name stream :start  0 :end len))
    1090                          (t (write-perverted-string name stream len case)))))))
    1091             (let* ((outbuf-len (+ len len))
    1092                    (outbuf-ptr -1)
    1093                    (outbuf (make-string outbuf-len)))
    1094               (declare (fixnum outbuf-ptr outbuf-len)
    1095                        (dynamic-extent outbuf)
    1096                        (simple-string outbuf))
    1097               (dotimes (pos (the fixnum len))
    1098                 (declare (type fixnum pos))
    1099                 (let* ((char (schar name pos))
    1100                        (slashify? (cond ((eql slash-count 0)
    1101                                          nil)
    1102                                         ((eql slash-count 1)
    1103                                          (eql pos last-slash-pos))
    1104                                         (t
    1105                                          (slashify? char)))))
    1106                   (declare (type character char))
    1107                   (when slashify?
    1108                     (setq slash-count (%i- slash-count 1))
    1109                     (setf (schar outbuf (incf outbuf-ptr)) #\\))
    1110                   (setf (schar outbuf (incf outbuf-ptr)) char)))
    1111               (write-string outbuf stream :start  0 :end (1+ outbuf-ptr))))))))
     1034                            (let ((sofar nil))
     1035                              (dotimes (i (length name) sofar)
     1036                                (declare (type fixnum i))
     1037                                (declare (type simple-string name))
     1038                                (let* ((c (schar name i))
     1039                                       (c-case (if (upper-case-p c)
     1040                                                 :upcase
     1041                                                 (if (lower-case-p c)
     1042                                                   :downcase))))
     1043                                  (when c-case
     1044                                    (if sofar
     1045                                      (if (neq sofar c-case)
     1046                                        (return nil))
     1047                                      (setq sofar c-case))))))))
     1048           (declare (dynamic-extent #'slashify? #'single-case-p))
     1049           (block alice
     1050             (let ((len (length name))
     1051                   (slash-count 0)
     1052                   (last-slash-pos 0))
     1053               (declare (type fixnum len)
     1054                        (type fixnum slash-count last-slash-pos))               
     1055               (when escape?
     1056                 (when (or (%izerop len)
     1057                           ;; if more than a few \, just use |...|
     1058                           (and;;(not (memq readcase '(:invert :preserve))) ; these never slashify alpha-p
     1059                            (let ((m (max (floor len 4) 2)))
     1060                              (dotimes (i (the fixnum len) nil)
     1061                                (declare (type fixnum i))
     1062                                (when (slashify? (schar name i))
     1063                                  (setq slash-count (%i+ slash-count 1)
     1064                                        needs-escape t)
     1065                                  (when (or (eql slash-count m)
     1066                                            (eq i (1+ last-slash-pos)))
     1067                                    (return t))
     1068                                  (setq last-slash-pos i)))))
     1069                           ;; or could be read as a number
     1070                           (handler-case (%parse-number-token name 0 len *print-base*)
     1071                             (arithmetic-error (c)
     1072                                               (declare (ignore c))))
     1073                           ;; or symbol consisting entirely of .'s
     1074                           (dotimes (i len (setq needs-escape t))
     1075                             (declare (fixnum i))
     1076                             (unless (eql (schar name i) #\.)
     1077                               (return nil))))
     1078                   (return-from alice
     1079                     (write-escaped-string name stream #\|))))
     1080               (case readcase
     1081                 (:preserve (return-from alice
     1082                              (if needs-escape
     1083                                (write-escaped-string name stream #\|)
     1084                                (write-string name stream :start  0 :end len))))
     1085                           
     1086                 (:invert (return-from alice
     1087                            (cond ((single-case-p name)
     1088                                   (write-perverted-string name stream len :invert (if needs-escape #\|)))
     1089                                  (t (if needs-escape
     1090                                       (write-escaped-string name stream #\|)
     1091                                       (write-string name stream :start  0 :end len))))))
     1092                 (t
     1093                  (when (eql slash-count 0)
     1094                    (return-from alice
     1095                      (cond ((eq readcase case)
     1096                             (write-string name stream :start  0 :end len))
     1097                            (t (write-perverted-string name stream len case)))))))
     1098               (let* ((outbuf-len (+ len len))
     1099                      (outbuf-ptr -1)
     1100                      (outbuf (make-string outbuf-len)))
     1101                 (declare (fixnum outbuf-ptr outbuf-len)
     1102                          (dynamic-extent outbuf)
     1103                          (simple-string outbuf))
     1104                 (dotimes (pos (the fixnum len))
     1105                   (declare (type fixnum pos))
     1106                   (let* ((char (schar name pos))
     1107                          (slashify? (cond ((eql slash-count 0)
     1108                                            nil)
     1109                                           ((eql slash-count 1)
     1110                                            (eql pos last-slash-pos))
     1111                                           (t
     1112                                            (slashify? char)))))
     1113                     (declare (type character char))
     1114                     (when slashify?
     1115                       (setq slash-count (%i- slash-count 1))
     1116                       (setf (schar outbuf (incf outbuf-ptr)) #\\))
     1117                     (setf (schar outbuf (incf outbuf-ptr)) char)))
     1118                 (write-string outbuf stream :start  0 :end (1+ outbuf-ptr))))))))
    11121119
    11131120#|
     
    11461153|#
    11471154
    1148 (defun write-perverted-string (string stream end type)
     1155(defun write-perverted-string (string stream end type &optional escape)
    11491156  ; type :invert :upcase :downcase :capitalize or :studly
    11501157  (declare (fixnum end))
     
    11521159         (readcase (readtable-case readtable))
    11531160         (outbuf-ptr -1)
    1154          (outbuf (make-string end))
     1161         (outbuf (make-string (if escape
     1162                                (+ end 2 (count-if (lambda (c) (or (eql c escape)
     1163                                                                   (eql c #\\))) string :end end))
     1164                                end)))
    11551165         (word-start t)
    11561166         (offset 0))
     
    11621172        (declare (type fixnum i))
    11631173        (setq offset (%i+ offset (char-int (char string i))))))
     1174    (when escape
     1175      (setf (schar outbuf (incf outbuf-ptr)) escape))
    11641176    (do ((i 0 (%i+ i 1)))
    11651177        ((%i>= i end))
     
    11931205                                                 (char-downcase c)
    11941206                                                 c)))))))
     1207              ((or (eql c escape) (eql c #\\))
     1208               (setf (schar outbuf (incf outbuf-ptr)) #\\))
    11951209              ((digit-char-p c)(setq word-start nil))
    11961210              (t (setq word-start t)))
    11971211        (setf (schar outbuf (incf outbuf-ptr)) c)))
    1198     (write-string outbuf stream :start  0 :end end)))
     1212    (when escape
     1213      (setf (schar outbuf (incf outbuf-ptr)) escape))
     1214    (write-string outbuf stream :start  0 :end (1+ outbuf-ptr))))
    11991215
    12001216
Note: See TracChangeset for help on using the changeset viewer.