src/code/sharpm.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!IMPL")
  11 \f
  12 (declaim (special *read-suppress*))
  13
  14 ;;; FIXME: Is it standard to ignore numeric args instead of raising errors?
  15 (defun ignore-numarg (sub-char numarg)
  16   (when numarg
  17     (warn "A numeric argument was ignored in #~W~A." numarg sub-char)))
  18 \f
  19 ;;;; reading arrays and vectors: the #(, #*, and #A readmacros
  20
  21 (defun sharp-left-paren (stream ignore length)
  22   (declare (ignore ignore))
  23   (let* ((list (read-list stream nil))
  24          (list-length
  25           (handler-case (length list)
  26             (type-error ()
  27               (simple-reader-error stream "Improper list in #(): ~S." list)))))
  28     (declare (list list)
  29              (fixnum list-length))
  30     (cond (*read-suppress* nil)
  31           ((and length (> list-length length))
  32            (simple-reader-error
  33             stream
  34             "Vector longer than the specified length: #~S~S."
  35             length list))
  36           (length
  37            (when (and (plusp length) (null list))
  38              (simple-reader-error
  39               stream "Vector of length ~D can't be initialized from ()" length))
  40            ;; the syntax `#n(foo ,@bar) is not well-defined. [See lp#1096043.]
  41            ;; We take it to mean that the vector as read should be padded to
  42            ;; length 'n'. It could be argued that 'n' is the length after
  43            ;; expansion, but that's not easy, not to mention unportable.
  44            (fill (replace (make-array length) list)
  45                  (car (last list)) :start list-length))
  46           (t
  47            (coerce list 'vector)))))
  48
  49 (defun sharp-star (stream ignore numarg)
  50   (declare (ignore ignore))
  51   (declare (type (or null integer) numarg))
  52   (binding* (((buffer escape-appearedp) (read-extended-token stream))
  53              (input-len (token-buf-fill-ptr buffer))
  54              (bstring (token-buf-string buffer)))
  55     (cond (*read-suppress* nil)
  56           (escape-appearedp
  57            (simple-reader-error stream
  58                                 "An escape character appeared after #*."))
  59           ((and numarg (zerop input-len) (not (zerop numarg)))
  60            (simple-reader-error
  61             stream
  62             "You have to give a little bit for non-zero #* bit-vectors."))
  63           ((or (null numarg) (>= numarg input-len))
  64            (do ((bvec
  65                  (make-array (or numarg input-len)
  66                              :element-type 'bit
  67                              :initial-element
  68                              (if (and (plusp input-len)
  69                                       (char= (char bstring (1- input-len)) #\1))
  70                                  1 0)))
  71                 (i 0 (1+ i)))
  72                ((= i input-len) bvec)
  73              (declare (index i) (optimize (sb!c::insert-array-bounds-checks 0)))
  74              (let ((char (char bstring i)))
  75                (setf (elt bvec i)
  76                      (case char
  77                        (#\0 0)
  78                        (#\1 1)
  79                        (t (simple-reader-error
  80                            stream "illegal element given for bit-vector: ~S"
  81                            char)))))))
  82           (t
  83            (simple-reader-error
  84             stream
  85             "Bit vector is longer than specified length #~A*~A"
  86             numarg
  87             (copy-token-buf-string buffer))))))
  88
  89 (defun sharp-A (stream ignore dimensions)
  90   (declare (ignore ignore))
  91   (when *read-suppress*
  92     (read stream t nil t)
  93     (return-from sharp-A nil))
  94   (unless dimensions
  95     (simple-reader-error stream "No dimensions argument to #A."))
  96   (collect ((dims))
  97     (let* ((*bq-error*
  98             (if (zerop *backquote-depth*)
  99                 *bq-error*
 100                 "Comma inside a backquoted array (not a list or general vector.)"))
 101            (*backquote-depth* 0)
 102            (contents (read stream t nil t))
 103            (seq contents))
 104       (dotimes (axis dimensions
 105                      (make-array (dims) :initial-contents contents))
 106         (unless (typep seq 'sequence)
 107           (simple-reader-error stream
 108                                "#~WA axis ~W is not a sequence:~%  ~S"
 109                                dimensions axis seq))
 110         (let ((len (length seq)))
 111           (dims len)
 112           (unless (or (= axis (1- dimensions))
 113                       ;; ANSI: "If some dimension of the array whose
 114                       ;; representation is being parsed is found to be
 115                       ;; 0, all dimensions to the right (i.e., the
 116                       ;; higher numbered dimensions) are also
 117                       ;; considered to be 0."
 118                       (= len 0))
 119             (setq seq (elt seq 0))))))))
 120 \f
 121 ;;;; reading structure instances: the #S readmacro
 122
 123 (defun sharp-S (stream sub-char numarg)
 124   (ignore-numarg sub-char numarg)
 125   (when *read-suppress*
 126     (read stream t nil t)
 127     (return-from sharp-S nil))
 128   (let* ((*bq-error*
 129           (if (zerop *backquote-depth*)
 130               *bq-error*
 131               "Comma inside backquoted structure (not a list or general vector.)"))
 132          (body (if (char= (read-char stream t) #\( )
 133                   (let ((*backquote-depth* 0))
 134                     (read-list stream nil))
 135                   (simple-reader-error stream "non-list following #S"))))
 136     (unless (listp body)
 137       (simple-reader-error stream "non-list following #S: ~S" body))
 138     (unless (symbolp (car body))
 139       (simple-reader-error stream
 140                            "Structure type is not a symbol: ~S"
 141                            (car body)))
 142     (let ((classoid (find-classoid (car body) nil)))
 143       (unless (typep classoid 'structure-classoid)
 144         (simple-reader-error stream
 145                              "~S is not a defined structure type."
 146                              (car body)))
 147       (let ((default-constructor (dd-default-constructor
 148                                   (layout-info (classoid-layout classoid)))))
 149         (unless default-constructor
 150           (simple-reader-error
 151            stream
 152            "The ~S structure does not have a default constructor."
 153            (car body)))
 154         (when (and (atom (rest body))
 155                    (not (null (rest body))))
 156           (simple-reader-error stream "improper list for #S: ~S." body))
 157         (apply (fdefinition default-constructor)
 158                (loop for tail on (rest body) by #'cddr
 159                      with slot-name = (and (consp tail) (car tail))
 160                      do (progn
 161                           (when (null (cdr tail))
 162                             (simple-reader-error
 163                              stream
 164                              "the arglist for the ~S constructor in #S ~
 165                               has an odd length: ~S."
 166                              (car body) (rest body)))
 167                           (when (or (atom (cdr tail))
 168                                     (and (atom (cddr tail))
 169                                          (not (null (cddr tail)))))
 170                             (simple-reader-error
 171                              stream
 172                              "the arglist for the ~S constructor in #S ~
 173                               is improper: ~S."
 174                              (car body) (rest body)))
 175                           (when (not (typep (car tail) 'string-designator))
 176                             (simple-reader-error
 177                              stream
 178                              "a slot name in #S is not a string ~
 179                               designator: ~S."
 180                              slot-name))
 181                           (when (not (keywordp slot-name))
 182                             (warn 'structure-initarg-not-keyword
 183                                   :format-control
 184                                   "in #S ~S, the use of non-keywords ~
 185                                    as slot specifiers is deprecated: ~S."
 186                                   :format-arguments
 187                                   (list (car body) slot-name))))
 188                      collect (intern (string (car tail)) *keyword-package*)
 189                      collect (cadr tail)))))))
 190 \f
 191 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
 192
 193 (defun sharp-B (stream sub-char numarg)
 194   (ignore-numarg sub-char numarg)
 195   (sharp-R stream sub-char 2))
 196
 197 (defun sharp-C (stream sub-char numarg)
 198   (ignore-numarg sub-char numarg)
 199   ;; The next thing had better be a list of two numbers.
 200   (let ((cnum (read stream t nil t)))
 201     (when *read-suppress* (return-from sharp-C nil))
 202     (if (and (listp cnum) (= (length cnum) 2))
 203         (complex (car cnum) (cadr cnum))
 204         (simple-reader-error stream
 205                              "illegal complex number format: #C~S"
 206                              cnum))))
 207
 208 (defun sharp-O (stream sub-char numarg)
 209   (ignore-numarg sub-char numarg)
 210   (sharp-R stream sub-char 8))
 211
 212 (defun sharp-R (stream sub-char radix)
 213   (cond (*read-suppress*
 214          (read-extended-token stream)
 215          nil)
 216         ((not radix)
 217          (simple-reader-error stream "radix missing in #R"))
 218         ((not (<= 2 radix 36))
 219          (simple-reader-error stream "illegal radix for #R: ~D." radix))
 220         (t
 221          ;; FIXME: (read-from-string "#o#x1f") should not work!
 222          ;; The token should be comprised strictly of digits in the radix,
 223          ;; though the docs say this is undefined behavior, so it's ok,
 224          ;; other than it being something we should complain about
 225          ;; for portability reasons.
 226          (let ((res (let ((*read-base* radix))
 227                       (read stream t nil t))))
 228            (unless (typep res 'rational)
 229              (simple-reader-error stream
 230                                   "#~A (base ~D.) value is not a rational: ~S."
 231                                   sub-char
 232                                   radix
 233                                   res))
 234            res))))
 235
 236 (defun sharp-X (stream sub-char numarg)
 237   (ignore-numarg sub-char numarg)
 238   (sharp-R stream sub-char 16))
 239 \f
 240 ;;;; reading circular data: the #= and ## readmacros
 241
 242 (defconstant +sharp-equal-marker+ '+sharp-equal-marker+)
 243
 244 (defstruct (sharp-equal-wrapper
 245             (:constructor make-sharp-equal-wrapper (label))
 246             (:copier nil))
 247   (label nil :read-only t)
 248   (value +sharp-equal-marker+))
 249 (declaim (freeze-type sharp-equal-wrapper))
 250
 251 ;; This function is kind of like NSUBLIS, but checks for circularities and
 252 ;; substitutes in arrays and structures as well as lists. The first arg is an
 253 ;; alist of the things to be replaced assoc'd with the things to replace them.
 254 (defun circle-subst (circle-table tree)
 255   (cond ((and (sharp-equal-wrapper-p tree)
 256               (not (eq (sharp-equal-wrapper-value tree) +sharp-equal-marker+)))
 257          (sharp-equal-wrapper-value tree))
 258         ((null (gethash tree circle-table))
 259          (setf (gethash tree circle-table) t)
 260          (cond ((consp tree)
 261                 (let ((a (circle-subst circle-table (car tree)))
 262                       (d (circle-subst circle-table (cdr tree))))
 263                   (unless (eq a (car tree))
 264                     (rplaca tree a))
 265                   (unless (eq d (cdr tree))
 266                     (rplacd tree d))))
 267                ((arrayp tree)
 268                 (with-array-data ((data tree) (start) (end))
 269                   (declare (fixnum start end))
 270                   (do ((i start (1+ i)))
 271                       ((>= i end))
 272                     (let* ((old (aref data i))
 273                            (new (circle-subst circle-table old)))
 274                       (unless (eq old new)
 275                         (setf (aref data i) new))))))
 276                ((typep tree 'instance)
 277                 ;; We don't grovel the layout.
 278                 (do-instance-tagged-slot (i tree)
 279                   (let* ((old (%instance-ref tree i))
 280                          (new (circle-subst circle-table old)))
 281                     (unless (eq old new)
 282                       (setf (%instance-ref tree i) new)))))
 283                ((typep tree 'funcallable-instance)
 284                 (do ((i 1 (1+ i))
 285                      (end (- (1+ (get-closure-length tree)) sb!vm:funcallable-instance-info-offset)))
 286                     ((= i end))
 287                   (let* ((old (%funcallable-instance-info tree i))
 288                          (new (circle-subst circle-table old)))
 289                     (unless (eq old new)
 290                       (setf (%funcallable-instance-info tree i) new))))))
 291          tree)
 292         (t tree)))
 293
 294 ;;; Sharp-equal works as follows.
 295 ;;; When creating a new label a SHARP-EQUAL-WRAPPER is pushed onto
 296 ;;; *SHARP-EQUAL* with the value slot being +SHARP-EQUAL-MARKER+.
 297 ;;; When #x# looks up the label and SHARP-EQUAL-WRAPPER-VALUE is
 298 ;;; +SHARP-EQUAL-MARKER+ it leaves the wrapper, otherwise it uses the
 299 ;;; value.
 300 ;;; After reading the object the sharp-equal-wrapper-value is set to
 301 ;;; the object and CIRCLE-SUBST replaces all the sharp-equal-wrappers
 302 ;;; with the already read values.
 303 (defun sharp-equal (stream ignore label)
 304   (declare (ignore ignore))
 305   (when *read-suppress* (return-from sharp-equal (values)))
 306   (unless label
 307     (simple-reader-error stream "Missing label for #="))
 308   (when (find label *sharp-equal* :key #'sharp-equal-wrapper-label)
 309     (simple-reader-error stream "Multiply defined label: #~D=" label))
 310   (let* ((wrapper (make-sharp-equal-wrapper label))
 311          (obj (progn
 312                 (push wrapper *sharp-equal*)
 313                 (read stream t nil t))))
 314     (when (eq obj wrapper)
 315       (simple-reader-error stream
 316                            "Must label something more than just #~D#"
 317                            label))
 318     (setf (sharp-equal-wrapper-value wrapper) obj)
 319     (circle-subst (make-hash-table :test 'eq) obj)))
 320
 321 (defun sharp-sharp (stream ignore label)
 322   (declare (ignore ignore))
 323   (when *read-suppress* (return-from sharp-sharp nil))
 324   (unless label
 325     (simple-reader-error stream "Missing label for ##"))
 326   ;; Has this label been defined previously? (Don't read
 327   ;; ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that
 328   ;; it requires you to implement forward references,
 329   ;; because forward references are disallowed in
 330   ;; "2.4.8.16 Sharpsign Sharpsign".)
 331   (let ((entry (find label *sharp-equal* :key #'sharp-equal-wrapper-label)))
 332     (cond ((not entry)
 333            (simple-reader-error stream
 334                                 "Reference to undefined label #~D#"
 335                                 label))
 336           ((eq (sharp-equal-wrapper-value entry) +sharp-equal-marker+)
 337            entry)
 338           (t
 339            (sharp-equal-wrapper-value entry)))))
 340 \f
 341 ;;;; conditional compilation: the #+ and #- readmacros
 342
 343 (defun sharp-plus-minus (stream sub-char numarg)
 344     (ignore-numarg sub-char numarg)
 345     (if (char= (if (featurep (let ((*package* *keyword-package*)
 346                                    (*reader-package* nil)
 347                                    (*read-suppress* nil))
 348                                (read stream t nil t)))
 349                    #\+ #\-) sub-char)
 350         (read stream t nil t)
 351         (let ((*read-suppress* t))
 352           (read stream t nil t)
 353           (values))))
 354 \f
 355 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
 356
 357 (defun sharp-P (stream sub-char numarg)
 358   (ignore-numarg sub-char numarg)
 359   (let ((namestring (read stream t nil t)))
 360     (unless *read-suppress*
 361       (parse-namestring namestring))))
 362
 363 (defun sharp-backslash (stream backslash numarg)
 364   (ignore-numarg backslash numarg)
 365   (let ((buf (read-extended-token-escaped stream)))
 366     (cond (*read-suppress* nil)
 367           ((= (token-buf-fill-ptr buf) 1)
 368            (char (token-buf-string buf) 0))
 369           ;; NAME-CHAR is specified as case-insensitive
 370           ((name-char (sized-token-buf-string buf)))
 371           (t
 372            (simple-reader-error stream
 373                                 "unrecognized character name: ~S"
 374                                 (copy-token-buf-string buf))))))
 375
 376 (defun sharp-vertical-bar (stream sub-char numarg)
 377   (ignore-numarg sub-char numarg)
 378   (handler-bind
 379       ((character-decoding-error
 380         #'(lambda (decoding-error)
 381             (declare (ignorable decoding-error))
 382             (style-warn
 383              'sb!kernel::character-decoding-error-in-dispatch-macro-char-comment
 384              :sub-char sub-char :position (file-position stream) :stream stream)
 385             (invoke-restart 'attempt-resync))))
 386     (let ((stream (in-synonym-of stream)))
 387       (macrolet ((munch (get-char &optional finish)
 388                    `(do ((level 1)
 389                          (prev ,get-char char)
 390                          (char ,get-char ,get-char))
 391                         (())
 392                       (cond ((and (char= prev #\|) (char= char #\#))
 393                              (setq level (1- level))
 394                              (when (zerop level)
 395                                ,finish
 396                                (return (values)))
 397                              (setq char ,get-char))
 398                             ((and (char= prev #\#) (char= char #\|))
 399                              (setq char ,get-char)
 400                              (setq level (1+ level)))))))
 401         (if (ansi-stream-p stream)
 402             (prepare-for-fast-read-char stream
 403               (munch (fast-read-char) (done-with-fast-read-char)))
 404             ;; fundamental-stream
 405             (munch (read-char stream t)))))))
 406 \f
 407 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
 408
 409 (defun sharp-quote (stream sub-char numarg)
 410   (ignore-numarg sub-char numarg)
 411   ;; The fourth arg tells READ that this is a recursive call.
 412   `(function ,(read stream t nil t)))
 413
 414 ;;; Read an uninterned symbol.
 415 ;;; Unescaped whitespace terminates the token, however a token comprised
 416 ;;; of zero characters is an edge-case that is not extremely portable other
 417 ;;; than for a few well-known uses, such as the incontrovertible fact that
 418 ;;; "#* foo" is two tokens: an empty bit-vector followed by a symbol.
 419 ;;; But different behaviors can be observed for #: in other implementations:
 420 ;;;  (read-from-string "#:  foo") => #:FOO
 421 ;;;  (read-from-string "#:  foo") => ERROR "token expected"
 422 (defun sharp-colon (stream sub-char numarg)
 423   (ignore-numarg sub-char numarg)
 424   (multiple-value-bind (buffer escapep colon) (read-extended-token stream)
 425     (unless *read-suppress*
 426       (casify-read-buffer buffer)
 427       (let ((token (copy-token-buf-string buffer)))
 428         (cond (colon
 429                (simple-reader-error
 430                 stream "The symbol following #: contains a package marker: ~S"
 431                 token))
 432               ;; We'd like to signal errors on tokens that look like numbers,
 433               ;; but doing that is actually nontrivial. None of the possible
 434               ;; ways to test for numeric syntax are great:
 435               ;; - using SYMBOL-QUOTEP to see if it says that the symbol would
 436               ;;   print using escapes could produce false positives
 437               ;;   because it's seldom wrong to use vertical bars.
 438               ;; - calling READ-FROM-STRING to see if it returns a number
 439               ;;   would demand a new string stream.
 440               ;; - a potential number with _ and/or ^ should not be allowed.
 441               ;; An acceptable rough cut is to use PARSE-INTEGER even though it
 442               ;; won't help to reject ratios or floating point syntax.
 443               ((and (not escapep)
 444                     (multiple-value-bind (num end)
 445                         (parse-integer token :radix *read-base* :junk-allowed t)
 446                       (and num (= end (length token)))))
 447                (simple-reader-error
 448                 stream "The symbol following #: has numeric syntax: ~S"
 449                 token))
 450               (t
 451                (make-symbol token)))))))
 452
 453 (defvar *read-eval* t
 454   #!+sb-doc
 455   "If false, then the #. read macro is disabled.")
 456
 457 (defun sharp-dot (stream sub-char numarg)
 458   (ignore-numarg sub-char numarg)
 459   (let ((*backquote-depth* 0))
 460     (let ((expr (read stream t nil t)))
 461       (unless *read-suppress*
 462         (unless *read-eval*
 463           (simple-reader-error stream "can't read #. while *READ-EVAL* is NIL"))
 464         (eval expr)))))
 465 \f
 466 (defun sharp-illegal (stream sub-char ignore)
 467   (declare (ignore ignore))
 468   (simple-reader-error stream "illegal sharp macro character: ~S" sub-char))
 469
 470 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
 471 (defun !sharpm-cold-init ()
 472   (make-dispatch-macro-character #\# t)
 473   (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
 474   (set-dispatch-macro-character #\# #\' #'sharp-quote)
 475   (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
 476   (set-dispatch-macro-character #\# #\* #'sharp-star)
 477   (set-dispatch-macro-character #\# #\: #'sharp-colon)
 478   (set-dispatch-macro-character #\# #\. #'sharp-dot)
 479   ;; This used to set the dispatch-function for pairs of alphabetics, but
 480   ;; {SET,GET}-DISPATCH-MACRO-CHARACTER and READ-DISPATCH-CHAR
 481   ;; all use CHAR-UPCASE on the sub-char, so it makes no difference.
 482   (set-dispatch-macro-character #\# #\r #'sharp-R)
 483   (set-dispatch-macro-character #\# #\b #'sharp-B)
 484   (set-dispatch-macro-character #\# #\o #'sharp-O)
 485   (set-dispatch-macro-character #\# #\x #'sharp-X)
 486   (set-dispatch-macro-character #\# #\a #'sharp-A)
 487   (set-dispatch-macro-character #\# #\s #'sharp-S)
 488   (set-dispatch-macro-character #\# #\= #'sharp-equal)
 489   (set-dispatch-macro-character #\# #\# #'sharp-sharp)
 490   (set-dispatch-macro-character #\# #\+ #'sharp-plus-minus)
 491   (set-dispatch-macro-character #\# #\- #'sharp-plus-minus)
 492   (set-dispatch-macro-character #\# #\c #'sharp-C)
 493   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
 494   (set-dispatch-macro-character #\# #\p #'sharp-P)
 495   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
 496   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
 497   (set-dispatch-macro-character #\# #\Space #'sharp-illegal)
 498   (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code
 499                        line-feed-char-code backspace-char-code))
 500     (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))