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* *standard-readtable* *bq-vector-flag*))
  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) (special *backquote-count*))
  23   (let* ((list (read-list stream nil))
  24          (listlength (handler-case (length list)
  25                        (type-error
  26                         (error)
  27                         (declare (ignore error))
  28                         (simple-reader-error stream
  29                                              "improper list in #(): ~S"
  30                                              list)))))
  31     (declare (list list)
  32              (fixnum listlength))
  33     (cond (*read-suppress* nil)
  34           ((zerop *backquote-count*)
  35            (if length
  36                (cond ((> listlength (the fixnum length))
  37                       (simple-reader-error
  38                        stream
  39                        "vector longer than specified length: #~S~S"
  40                        length list))
  41                      (t
  42                       (fill (the simple-vector
  43                                  (replace (the simple-vector
  44                                                (make-array length))
  45                                           list))
  46                             (car (last list))
  47                             :start listlength)))
  48                (coerce list 'vector)))
  49           (t (cons *bq-vector-flag* list)))))
  50
  51 (defun sharp-star (stream ignore numarg)
  52   (declare (ignore ignore))
  53   (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
  54     (declare (simple-string bstring))
  55     (cond (*read-suppress* nil)
  56           (escape-appearedp
  57            (simple-reader-error stream
  58                                 "An escape character appeared after #*."))
  59           ((and numarg (zerop (length bstring)) (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) (>= (the fixnum numarg) (length bstring)))
  64            (let* ((len1 (length bstring))
  65                   (last1 (1- len1))
  66                   (len2 (or numarg len1))
  67                   (bvec (make-array len2 :element-type 'bit
  68                                     :initial-element 0)))
  69              (declare (fixnum len1 last1 len2))
  70              (do ((i 0 (1+ i))
  71                   (char ()))
  72                  ((= i len2))
  73                (declare (fixnum i))
  74                (setq char (elt bstring (if (< i len1) i last1)))
  75                (setf (elt bvec i)
  76                      (cond ((char= char #\0) 0)
  77                            ((char= char #\1) 1)
  78                            (t
  79                             (simple-reader-error
  80                              stream
  81                              "illegal element given for bit-vector: ~S"
  82                              char)))))
  83              bvec))
  84           (t
  85            (simple-reader-error
  86             stream
  87             "Bit vector is longer than specified length #~A*~A"
  88             numarg
  89             bstring)))))
  90
  91 (defun sharp-A (stream ignore dimensions)
  92   (declare (ignore ignore))
  93   (when *read-suppress*
  94     (read stream t nil t)
  95     (return-from sharp-A nil))
  96   (unless dimensions
  97     (simple-reader-error stream "No dimensions argument to #A."))
  98   (collect ((dims))
  99     (let* ((*bq-error*
 100             (if (zerop *backquote-count*)
 101                 *bq-error*
 102                 "Comma inside a backquoted array (not a list or general vector.)"))
 103            (*backquote-count* 0)
 104            (contents (read stream t nil t))
 105            (seq contents))
 106       (dotimes (axis dimensions
 107                      (make-array (dims) :initial-contents contents))
 108         (unless (typep seq 'sequence)
 109           (simple-reader-error stream
 110                                "#~WA axis ~W is not a sequence:~%  ~S"
 111                                dimensions axis seq))
 112         (let ((len (length seq)))
 113           (dims len)
 114           (unless (or (= axis (1- dimensions))
 115                       ;; ANSI: "If some dimension of the array whose
 116                       ;; representation is being parsed is found to be
 117                       ;; 0, all dimensions to the right (i.e., the
 118                       ;; higher numbered dimensions) are also
 119                       ;; considered to be 0."
 120                       (= len 0))
 121             (setq seq (elt seq 0))))))))
 122 \f
 123 ;;;; reading structure instances: the #S readmacro
 124
 125 (defun sharp-S (stream sub-char numarg)
 126   (ignore-numarg sub-char numarg)
 127   (when *read-suppress*
 128     (read stream t nil t)
 129     (return-from sharp-S nil))
 130   (let* ((*bq-error*
 131           (if (zerop *backquote-count*)
 132               *bq-error*
 133               "Comma inside backquoted structure (not a list or general vector.)"))
 134          (*backquote-count* 0)
 135          (body (if (char= (read-char stream t) #\( )
 136                   (let ((*backquote-count* 0))
 137                     (read-list stream nil))
 138                   (simple-reader-error stream "non-list following #S"))))
 139     (unless (listp body)
 140       (simple-reader-error stream "non-list following #S: ~S" body))
 141     (unless (symbolp (car body))
 142       (simple-reader-error stream
 143                            "Structure type is not a symbol: ~S"
 144                            (car body)))
 145     (let ((classoid (find-classoid (car body) nil)))
 146       (unless (typep classoid 'structure-classoid)
 147         (simple-reader-error stream
 148                              "~S is not a defined structure type."
 149                              (car body)))
 150       (let ((default-constructor (dd-default-constructor
 151                                   (layout-info (classoid-layout classoid)))))
 152         (unless default-constructor
 153           (simple-reader-error
 154            stream
 155            "The ~S structure does not have a default constructor."
 156            (car body)))
 157         (when (and (atom (rest body))
 158                    (not (null (rest body))))
 159           (simple-reader-error stream "improper list for #S: ~S." body))
 160         (apply (fdefinition default-constructor)
 161                (loop for tail on (rest body) by #'cddr
 162                      with slot-name = (and (consp tail) (car tail))
 163                      do (progn
 164                           (when (null (cdr tail))
 165                             (simple-reader-error
 166                              stream
 167                              "the arglist for the ~S constructor in #S ~
 168                               has an odd length: ~S."
 169                              (car body) (rest body)))
 170                           (when (or (atom (cdr tail))
 171                                     (and (atom (cddr tail))
 172                                          (not (null (cddr tail)))))
 173                             (simple-reader-error
 174                              stream
 175                              "the arglist for the ~S constructor in #S ~
 176                               is improper: ~S."
 177                              (car body) (rest body)))
 178                           (when (not (typep (car tail) 'string-designator))
 179                             (simple-reader-error
 180                              stream
 181                              "a slot name in #S is not a string ~
 182                               designator: ~S."
 183                              slot-name))
 184                           (when (not (keywordp slot-name))
 185                             (warn 'structure-initarg-not-keyword
 186                                   :format-control
 187                                   "in #S ~S, the use of non-keywords ~
 188                                    as slot specifiers is deprecated: ~S."
 189                                   :format-arguments
 190                                   (list (car body) slot-name))))
 191                      collect (intern (string (car tail)) *keyword-package*)
 192                      collect (cadr tail)))))))
 193 \f
 194 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
 195
 196 (defun sharp-B (stream sub-char numarg)
 197   (ignore-numarg sub-char numarg)
 198   (sharp-R stream sub-char 2))
 199
 200 (defun sharp-C (stream sub-char numarg)
 201   (ignore-numarg sub-char numarg)
 202   ;; The next thing had better be a list of two numbers.
 203   (let ((cnum (read stream t nil t)))
 204     (when *read-suppress* (return-from sharp-C nil))
 205     (if (and (listp cnum) (= (length cnum) 2))
 206         (complex (car cnum) (cadr cnum))
 207         (simple-reader-error stream
 208                              "illegal complex number format: #C~S"
 209                              cnum))))
 210
 211 (defun sharp-O (stream sub-char numarg)
 212   (ignore-numarg sub-char numarg)
 213   (sharp-R stream sub-char 8))
 214
 215 (defun sharp-R (stream sub-char radix)
 216   (cond (*read-suppress*
 217          (read-extended-token stream)
 218          nil)
 219         ((not radix)
 220          (simple-reader-error stream "radix missing in #R"))
 221         ((not (<= 2 radix 36))
 222          (simple-reader-error stream "illegal radix for #R: ~D." radix))
 223         (t
 224          (let ((res (let ((*read-base* radix))
 225                       (read stream t nil t))))
 226            (unless (typep res 'rational)
 227              (simple-reader-error stream
 228                                   "#~A (base ~D.) value is not a rational: ~S."
 229                                   sub-char
 230                                   radix
 231                                   res))
 232            res))))
 233
 234 (defun sharp-X (stream sub-char numarg)
 235   (ignore-numarg sub-char numarg)
 236   (sharp-R stream sub-char 16))
 237 \f
 238 ;;;; reading circular data: the #= and ## readmacros
 239
 240 ;;; objects already seen by CIRCLE-SUBST
 241 (defvar *sharp-equal-circle-table*)
 242 (declaim (type hash-table *sharp-equal-circle-table*))
 243
 244 ;; This function is kind of like NSUBLIS, but checks for circularities and
 245 ;; substitutes in arrays and structures as well as lists. The first arg is an
 246 ;; alist of the things to be replaced assoc'd with the things to replace them.
 247 (defun circle-subst (old-new-alist tree)
 248   (cond ((not (typep tree '(or cons (array t) instance funcallable-instance)))
 249          (let ((entry (find tree old-new-alist :key #'second)))
 250            (if entry (third entry) tree)))
 251         ((null (gethash tree *sharp-equal-circle-table*))
 252          (setf (gethash tree *sharp-equal-circle-table*) t)
 253          (cond ((consp tree)
 254                 (let ((a (circle-subst old-new-alist (car tree)))
 255                       (d (circle-subst old-new-alist (cdr tree))))
 256                   (unless (eq a (car tree))
 257                     (rplaca tree a))
 258                   (unless (eq d (cdr tree))
 259                     (rplacd tree d))))
 260                ((arrayp tree)
 261                 (with-array-data ((data tree) (start) (end))
 262                   (declare (fixnum start end))
 263                   (do ((i start (1+ i)))
 264                       ((>= i end))
 265                     (let* ((old (aref data i))
 266                            (new (circle-subst old-new-alist old)))
 267                       (unless (eq old new)
 268                         (setf (aref data i) new))))))
 269                ((typep tree 'instance)
 270                 (let* ((n-untagged (layout-n-untagged-slots (%instance-layout tree)))
 271                        (n-tagged (- (%instance-length tree) n-untagged)))
 272                   ;; N-TAGGED includes the layout as well (at index 0), which
 273                   ;; we don't grovel.
 274                   (do ((i 1 (1+ i)))
 275                       ((= i n-tagged))
 276                     (let* ((old (%instance-ref tree i))
 277                            (new (circle-subst old-new-alist old)))
 278                       (unless (eq old new)
 279                         (setf (%instance-ref tree i) new))))
 280                   (do ((i 0 (1+ i)))
 281                       ((= i n-untagged))
 282                     (let* ((old (%raw-instance-ref/word tree i))
 283                            (new (circle-subst old-new-alist old)))
 284                       (unless (= old new)
 285                         (setf (%raw-instance-ref/word tree i) new))))))
 286                ((typep tree 'funcallable-instance)
 287                 (do ((i 1 (1+ i))
 288                      (end (- (1+ (get-closure-length tree)) sb!vm:funcallable-instance-info-offset)))
 289                     ((= i end))
 290                   (let* ((old (%funcallable-instance-info tree i))
 291                          (new (circle-subst old-new-alist old)))
 292                     (unless (eq old new)
 293                       (setf (%funcallable-instance-info tree i) new))))))
 294          tree)
 295         (t tree)))
 296
 297 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
 298 ;;; #= is called) we GENSYM a symbol is which is used as an
 299 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
 300 ;;; gensym.
 301 ;;;
 302 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
 303 ;;; symbol assoc'd with the label. Resolution of the reference is
 304 ;;; deferred until the read done by #= finishes. Any already resolved
 305 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
 306 ;;;
 307 ;;; After reading of the #= form is completed, we add an entry to
 308 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
 309 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
 310 ;;; object is searched and any uses of the gensysm token are replaced
 311 ;;; with the actual value.
 312 (defvar *sharp-sharp-alist* ())
 313
 314 (defun sharp-equal (stream ignore label)
 315   (declare (ignore ignore))
 316   (when *read-suppress* (return-from sharp-equal (values)))
 317   (unless label
 318     (simple-reader-error stream "missing label for #=" label))
 319   (when (or (assoc label *sharp-sharp-alist*)
 320             (assoc label *sharp-equal-alist*))
 321     (simple-reader-error stream "multiply defined label: #~D=" label))
 322   (let* ((tag (gensym))
 323          (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
 324          (obj (read stream t nil t)))
 325     (when (eq obj tag)
 326       (simple-reader-error stream
 327                      "must tag something more than just #~D#"
 328                      label))
 329     (push (list label tag obj) *sharp-equal-alist*)
 330     (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
 331       (circle-subst *sharp-equal-alist* obj))))
 332
 333 (defun sharp-sharp (stream ignore label)
 334   (declare (ignore ignore))
 335   (when *read-suppress* (return-from sharp-sharp nil))
 336   (unless label
 337     (simple-reader-error stream "missing label for ##" label))
 338
 339   (let ((entry (assoc label *sharp-equal-alist*)))
 340     (if entry
 341         (third entry)
 342         (let (;; Has this label been defined previously? (Don't read
 343               ;; ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that
 344               ;; it requires you to implement forward references,
 345               ;; because forward references are disallowed in
 346               ;; "2.4.8.16 Sharpsign Sharpsign".)
 347               (pair (assoc label *sharp-sharp-alist*)))
 348           (unless pair
 349             (simple-reader-error stream
 350                                  "reference to undefined label #~D#"
 351                                  label))
 352           (cdr pair)))))
 353 \f
 354 ;;;; conditional compilation: the #+ and #- readmacros
 355
 356 (flet ((guts (stream not-p)
 357          (unless (if (let ((*package* *keyword-package*)
 358                            (*read-suppress* nil))
 359                        (featurep (read stream t nil t)))
 360                      (not not-p)
 361                      not-p)
 362            (let ((*read-suppress* t))
 363              (read stream t nil t)))
 364          (values)))
 365
 366   (defun sharp-plus (stream sub-char numarg)
 367     (ignore-numarg sub-char numarg)
 368     (guts stream nil))
 369
 370   (defun sharp-minus (stream sub-char numarg)
 371     (ignore-numarg sub-char numarg)
 372     (guts stream t)))
 373 \f
 374 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
 375
 376 (defun sharp-P (stream sub-char numarg)
 377   (ignore-numarg sub-char numarg)
 378   (let ((namestring (read stream t nil t)))
 379     (unless *read-suppress*
 380       (parse-namestring namestring))))
 381
 382 (defun sharp-backslash (stream backslash numarg)
 383   (ignore-numarg backslash numarg)
 384   (let ((charstring (read-extended-token-escaped stream)))
 385     (declare (simple-string charstring))
 386     (cond (*read-suppress* nil)
 387           ((= (the fixnum (length charstring)) 1)
 388            (char charstring 0))
 389           ((name-char charstring))
 390           (t
 391            (simple-reader-error stream
 392                                 "unrecognized character name: ~S"
 393                                 charstring)))))
 394
 395 (defun sharp-vertical-bar (stream sub-char numarg)
 396   (ignore-numarg sub-char numarg)
 397   (handler-bind
 398       ((character-decoding-error
 399         #'(lambda (decoding-error)
 400             (declare (ignorable decoding-error))
 401             (style-warn
 402              'sb!kernel::character-decoding-error-in-dispatch-macro-char-comment
 403              :sub-char sub-char :position (file-position stream) :stream stream)
 404             (invoke-restart 'attempt-resync))))
 405     (let ((stream (in-synonym-of stream)))
 406       (if (ansi-stream-p stream)
 407           (prepare-for-fast-read-char stream
 408             (do ((level 1)
 409                  (prev (fast-read-char) char)
 410                  (char (fast-read-char) (fast-read-char)))
 411                 (())
 412               (cond ((and (char= prev #\|) (char= char #\#))
 413                      (setq level (1- level))
 414                      (when (zerop level)
 415                        (done-with-fast-read-char)
 416                        (return (values)))
 417                      (setq char (fast-read-char)))
 418                     ((and (char= prev #\#) (char= char #\|))
 419                      (setq char (fast-read-char))
 420                      (setq level (1+ level))))))
 421           ;; fundamental-stream
 422           (do ((level 1)
 423                (prev (read-char stream t) char)
 424                (char (read-char stream t) (read-char stream t)))
 425               (())
 426             (cond ((and (char= prev #\|) (char= char #\#))
 427                    (setq level (1- level))
 428                    (when (zerop level)
 429                      (return (values)))
 430                    (setq char (read-char stream t)))
 431                   ((and (char= prev #\#) (char= char #\|))
 432                    (setq char (read-char stream t))
 433                    (setq level (1+ level)))))))))
 434 \f
 435 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
 436
 437 (defun sharp-quote (stream sub-char numarg)
 438   (ignore-numarg sub-char numarg)
 439   ;; The fourth arg tells READ that this is a recursive call.
 440   `(function ,(read stream t nil t)))
 441
 442 (defun sharp-colon (stream sub-char numarg)
 443   (ignore-numarg sub-char numarg)
 444   (multiple-value-bind (token escapep colon) (read-extended-token stream)
 445     (declare (simple-string token) (ignore escapep))
 446     (cond
 447      (*read-suppress* nil)
 448      (colon
 449       (simple-reader-error
 450        stream "The symbol following #: contains a package marker: ~S" token))
 451      (t
 452       (make-symbol token)))))
 453
 454 (defvar *read-eval* t
 455   #!+sb-doc
 456   "If false, then the #. read macro is disabled.")
 457
 458 (defun sharp-dot (stream sub-char numarg)
 459   (ignore-numarg sub-char numarg)
 460   (let ((token (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 token))))
 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   (set-dispatch-macro-character #\# #\R #'sharp-R)
 480   (set-dispatch-macro-character #\# #\r #'sharp-R)
 481   (set-dispatch-macro-character #\# #\B #'sharp-B)
 482   (set-dispatch-macro-character #\# #\b #'sharp-B)
 483   (set-dispatch-macro-character #\# #\O #'sharp-O)
 484   (set-dispatch-macro-character #\# #\o #'sharp-O)
 485   (set-dispatch-macro-character #\# #\X #'sharp-X)
 486   (set-dispatch-macro-character #\# #\x #'sharp-X)
 487   (set-dispatch-macro-character #\# #\A #'sharp-A)
 488   (set-dispatch-macro-character #\# #\a #'sharp-A)
 489   (set-dispatch-macro-character #\# #\S #'sharp-S)
 490   (set-dispatch-macro-character #\# #\s #'sharp-S)
 491   (set-dispatch-macro-character #\# #\= #'sharp-equal)
 492   (set-dispatch-macro-character #\# #\# #'sharp-sharp)
 493   (set-dispatch-macro-character #\# #\+ #'sharp-plus)
 494   (set-dispatch-macro-character #\# #\- #'sharp-minus)
 495   (set-dispatch-macro-character #\# #\C #'sharp-C)
 496   (set-dispatch-macro-character #\# #\c #'sharp-C)
 497   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
 498   (set-dispatch-macro-character #\# #\p #'sharp-P)
 499   (set-dispatch-macro-character #\# #\P #'sharp-P)
 500   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
 501   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
 502   (set-dispatch-macro-character #\# #\Space #'sharp-illegal)
 503   (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code
 504                        line-feed-char-code backspace-char-code))
 505     (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))