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 #~D~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 (length list)))
  25     (declare (list list)
  26              (fixnum listlength))
  27     (cond (*read-suppress* nil)
  28           ((zerop *backquote-count*)
  29            (if length
  30                (cond ((> listlength (the fixnum length))
  31                       (%reader-error
  32                        stream
  33                        "vector longer than specified length: #~S~S"
  34                        length list))
  35                      (t
  36                       (fill (the simple-vector
  37                                  (replace (the simple-vector
  38                                                (make-array length))
  39                                           list))
  40                             (car (last list))
  41                             :start listlength)))
  42                (coerce list 'vector)))
  43           (t (cons *bq-vector-flag* list)))))
  44
  45 (defun sharp-star (stream ignore numarg)
  46   (declare (ignore ignore))
  47   (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
  48     (declare (simple-string bstring))
  49     (cond (*read-suppress* nil)
  50           (escape-appearedp
  51            (%reader-error stream "An escape character appeared after #*"))
  52           ((and numarg (zerop (length bstring)) (not (zerop numarg)))
  53            (%reader-error
  54             stream
  55             "You have to give a little bit for non-zero #* bit-vectors."))
  56           ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
  57            (let* ((len1 (length bstring))
  58                   (last1 (1- len1))
  59                   (len2 (or numarg len1))
  60                   (bvec (make-array len2 :element-type 'bit
  61                                     :initial-element 0)))
  62              (declare (fixnum len1 last1 len2))
  63              (do ((i 0 (1+ i))
  64                   (char ()))
  65                  ((= i len2))
  66                (declare (fixnum i))
  67                (setq char (elt bstring (if (< i len1) i last1)))
  68                (setf (elt bvec i)
  69                      (cond ((char= char #\0) 0)
  70                            ((char= char #\1) 1)
  71                            (t
  72                             (%reader-error
  73                              stream
  74                              "illegal element given for bit-vector: ~S"
  75                              char)))))
  76              bvec))
  77           (t
  78            (%reader-error stream
  79                          "Bit vector is longer than specified length #~A*~A"
  80                          numarg bstring)))))
  81
  82 (defun sharp-A (stream ignore dimensions)
  83   (declare (ignore ignore))
  84   (when *read-suppress*
  85     (read stream t nil t)
  86     (return-from sharp-A nil))
  87   (unless dimensions (%reader-error stream "no dimensions argument to #A"))
  88   (collect ((dims))
  89     (let* ((contents (read stream t nil t))
  90            (seq contents))
  91       (dotimes (axis dimensions
  92                      (make-array (dims) :initial-contents contents))
  93         (unless (typep seq 'sequence)
  94           (%reader-error stream
  95                          "#~DA axis ~D is not a sequence:~%  ~S"
  96                          dimensions axis seq))
  97         (let ((len (length seq)))
  98           (dims len)
  99           (unless (= axis (1- dimensions))
 100             (when (zerop len)
 101               (%reader-error stream
 102                              "#~DA axis ~D is empty, but is not ~
 103                               the last dimension."
 104                              dimensions axis))
 105             (setq seq (elt seq 0))))))))
 106 \f
 107 ;;;; reading structure instances: the #S readmacro
 108
 109 (defun sharp-S (stream sub-char numarg)
 110   (ignore-numarg sub-char numarg)
 111   (when *read-suppress*
 112     (read stream t nil t)
 113     (return-from sharp-S nil))
 114   (let ((body (if (char= (read-char stream t) #\( )
 115                   (read-list stream nil)
 116                   (%reader-error stream "non-list following #S"))))
 117     (unless (listp body)
 118       (%reader-error stream "non-list following #S: ~S" body))
 119     (unless (symbolp (car body))
 120       (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
 121     (let ((class (sb!xc:find-class (car body) nil)))
 122       (unless (typep class 'sb!xc:structure-class)
 123         (%reader-error stream "~S is not a defined structure type."
 124                        (car body)))
 125       (let ((def-con (dd-default-constructor
 126                       (layout-info
 127                        (class-layout class)))))
 128         (unless def-con
 129           (%reader-error
 130            stream "The ~S structure does not have a default constructor."
 131            (car body)))
 132         (apply (fdefinition def-con) (rest body))))))
 133 \f
 134 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
 135
 136 (defun sharp-B (stream sub-char numarg)
 137   (ignore-numarg sub-char numarg)
 138   (sharp-r stream sub-char 2))
 139
 140 (defun sharp-C (stream sub-char numarg)
 141   (ignore-numarg sub-char numarg)
 142   ;; The next thing had better be a list of two numbers.
 143   (let ((cnum (read stream t nil t)))
 144     (when *read-suppress* (return-from sharp-c nil))
 145     (if (and (listp cnum) (= (length cnum) 2))
 146         (complex (car cnum) (cadr cnum))
 147         (%reader-error stream "illegal complex number format: #C~S" cnum))))
 148
 149 (defun sharp-O (stream sub-char numarg)
 150   (ignore-numarg sub-char numarg)
 151   (sharp-r stream sub-char 8))
 152
 153 (defun sharp-R (stream sub-char radix)
 154   (cond (*read-suppress*
 155          (read-extended-token stream)
 156          nil)
 157         ((not radix)
 158          (%reader-error stream "radix missing in #R"))
 159         ((not (<= 2 radix 36))
 160          (%reader-error stream "illegal radix for #R: ~D" radix))
 161         (t
 162          (let ((res (let ((*read-base* radix))
 163                       (read stream t nil t))))
 164            (unless (typep res 'rational)
 165              (%reader-error stream
 166                             "#~A (base ~D) value is not a rational: ~S."
 167                             sub-char
 168                             radix
 169                             res))
 170            res))))
 171
 172 (defun sharp-X (stream sub-char numarg)
 173   (ignore-numarg sub-char numarg)
 174   (sharp-r stream sub-char 16))
 175 \f
 176 ;;;; reading circular data: the #= and ## readmacros
 177
 178 ;;; objects already seen by CIRCLE-SUBST
 179 (defvar *sharp-equal-circle-table*)
 180 (declaim (type hash-table *sharp-equal-circle-table*))
 181
 182 ;; This function is kind of like NSUBLIS, but checks for circularities and
 183 ;; substitutes in arrays and structures as well as lists. The first arg is an
 184 ;; alist of the things to be replaced assoc'd with the things to replace them.
 185 (defun circle-subst (old-new-alist tree)
 186   (cond ((not (typep tree '(or cons (array t) structure-object)))
 187          (let ((entry (find tree old-new-alist :key #'second)))
 188            (if entry (third entry) tree)))
 189         ((null (gethash tree *sharp-equal-circle-table*))
 190          (setf (gethash tree *sharp-equal-circle-table*) t)
 191          (cond ((typep tree 'structure-object)
 192                 (do ((i 1 (1+ i))
 193                      (end (%instance-length tree)))
 194                     ((= i end))
 195                   (let* ((old (%instance-ref tree i))
 196                          (new (circle-subst old-new-alist old)))
 197                     (unless (eq old new)
 198                       (setf (%instance-ref tree i) new)))))
 199                ((arrayp tree)
 200                 (with-array-data ((data tree) (start) (end))
 201                   (declare (fixnum start end))
 202                   (do ((i start (1+ i)))
 203                       ((>= i end))
 204                     (let* ((old (aref data i))
 205                            (new (circle-subst old-new-alist old)))
 206                       (unless (eq old new)
 207                         (setf (aref data i) new))))))
 208                (t
 209                 (let ((a (circle-subst old-new-alist (car tree)))
 210                       (d (circle-subst old-new-alist (cdr tree))))
 211                   (unless (eq a (car tree))
 212                     (rplaca tree a))
 213                   (unless (eq d (cdr tree))
 214                     (rplacd tree d)))))
 215          tree)
 216         (t tree)))
 217
 218 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
 219 ;;; #= is called) we GENSYM a symbol is which is used as an
 220 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
 221 ;;; gensym.
 222 ;;;
 223 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
 224 ;;; symbol assoc'd with the label. Resolution of the reference is
 225 ;;; deferred until the read done by #= finishes. Any already resolved
 226 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
 227 ;;;
 228 ;;; After reading of the #= form is completed, we add an entry to
 229 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
 230 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
 231 ;;; object is searched and any uses of the gensysm token are replaced
 232 ;;; with the actual value.
 233 (defvar *sharp-sharp-alist* ())
 234
 235 (defun sharp-equal (stream ignore label)
 236   (declare (ignore ignore))
 237   (when *read-suppress* (return-from sharp-equal (values)))
 238   (unless label
 239     (%reader-error stream "missing label for #=" label))
 240   (when (or (assoc label *sharp-sharp-alist*)
 241             (assoc label *sharp-equal-alist*))
 242     (%reader-error stream "multiply defined label: #~D=" label))
 243   (let* ((tag (gensym))
 244          (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
 245          (obj (read stream t nil t)))
 246     (when (eq obj tag)
 247       (%reader-error stream
 248                      "must tag something more than just #~D#"
 249                      label))
 250     (push (list label tag obj) *sharp-equal-alist*)
 251     (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
 252       (circle-subst *sharp-equal-alist* obj))))
 253
 254 (defun sharp-sharp (stream ignore label)
 255   (declare (ignore ignore))
 256   (when *read-suppress* (return-from sharp-sharp nil))
 257   (unless label
 258     (%reader-error stream "missing label for ##" label))
 259
 260   (let ((entry (assoc label *sharp-equal-alist*)))
 261     (if entry
 262         (third entry)
 263         (let ((pair (assoc label *sharp-sharp-alist*)))
 264           (unless pair
 265             (%reader-error stream "object is not labelled #~S#" label))
 266           (cdr pair)))))
 267 \f
 268 ;;;; conditional compilation: the #+ and #- readmacros
 269
 270 (flet ((guts (stream not-p)
 271          (unless (if (handler-case
 272                          (let ((*package* *keyword-package*)
 273                                (*read-suppress* nil))
 274                            (featurep (read stream t nil t)))
 275                        (reader-package-error
 276                         (condition)
 277                         (declare (ignore condition))
 278                         nil))
 279                      (not not-p)
 280                      not-p)
 281            (let ((*read-suppress* t))
 282              (read stream t nil t)))
 283          (values)))
 284
 285   (defun sharp-plus (stream sub-char numarg)
 286     (ignore-numarg sub-char numarg)
 287     (guts stream nil))
 288
 289   (defun sharp-minus (stream sub-char numarg)
 290     (ignore-numarg sub-char numarg)
 291     (guts stream t)))
 292 \f
 293 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
 294
 295 (defun sharp-P (stream sub-char numarg)
 296   (ignore-numarg sub-char numarg)
 297   (let ((namestring (read stream t nil t)))
 298     (unless *read-suppress*
 299       (parse-namestring namestring))))
 300
 301 (defun sharp-backslash (stream backslash numarg)
 302   (ignore-numarg backslash numarg)
 303   (unread-char backslash stream)
 304   (let* ((*readtable* *standard-readtable*)
 305          (charstring (read-extended-token stream)))
 306     (declare (simple-string charstring))
 307     (cond (*read-suppress* nil)
 308           ((= (the fixnum (length charstring)) 1)
 309            (char charstring 0))
 310           ((name-char charstring))
 311           (t
 312            (%reader-error stream
 313                           "unrecognized character name: ~S"
 314                           charstring)))))
 315
 316 (defun sharp-vertical-bar (stream sub-char numarg)
 317   (ignore-numarg sub-char numarg)
 318   (let ((stream (in-synonym-of stream)))
 319     (if (lisp-stream-p stream)
 320         (prepare-for-fast-read-char stream
 321           (do ((level 1)
 322                (prev (fast-read-char) char)
 323                (char (fast-read-char) (fast-read-char)))
 324               (())
 325             (cond ((and (char= prev #\|) (char= char #\#))
 326                    (setq level (1- level))
 327                    (when (zerop level)
 328                      (done-with-fast-read-char)
 329                      (return (values)))
 330                    (setq char (fast-read-char)))
 331                   ((and (char= prev #\#) (char= char #\|))
 332                    (setq char (fast-read-char))
 333                    (setq level (1+ level))))))
 334         ;; fundamental-stream
 335         (do ((level 1)
 336              (prev (read-char stream t) char)
 337              (char (read-char stream t) (read-char stream t)))
 338             (())
 339           (cond ((and (char= prev #\|) (char= char #\#))
 340                  (setq level (1- level))
 341                  (when (zerop level)
 342                    (return (values)))
 343                  (setq char (read-char stream t)))
 344                 ((and (char= prev #\#) (char= char #\|))
 345                  (setq char (read-char stream t))
 346                  (setq level (1+ level))))))))
 347 \f
 348 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
 349
 350 (defun sharp-quote (stream sub-char numarg)
 351   (ignore-numarg sub-char numarg)
 352   ;; The fourth arg tells READ that this is a recursive call.
 353   `(function ,(read stream t nil t)))
 354
 355 (defun sharp-colon (stream sub-char numarg)
 356   (ignore-numarg sub-char numarg)
 357   (multiple-value-bind (token escapep colon) (read-extended-token stream)
 358     (declare (simple-string token) (ignore escapep))
 359     (cond
 360      (*read-suppress* nil)
 361      (colon
 362       (%reader-error stream
 363                      "The symbol following #: contains a package marker: ~S"
 364                      token))
 365      (t
 366       (make-symbol token)))))
 367
 368 (defvar *read-eval* t
 369   #!+sb-doc
 370   "If false, then the #. read macro is disabled.")
 371
 372 (defun sharp-dot (stream sub-char numarg)
 373   (ignore-numarg sub-char numarg)
 374   (let ((token (read stream t nil t)))
 375     (unless *read-suppress*
 376       (unless *read-eval*
 377         (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
 378       (eval token))))
 379 \f
 380 (defun sharp-illegal (stream sub-char ignore)
 381   (declare (ignore ignore))
 382   (%reader-error stream "illegal sharp macro character: ~S" sub-char))
 383
 384 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
 385 (defun !sharpm-cold-init ()
 386   (make-dispatch-macro-character #\# t)
 387   (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
 388   (set-dispatch-macro-character #\# #\' #'sharp-quote)
 389   (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
 390   (set-dispatch-macro-character #\# #\* #'sharp-star)
 391   (set-dispatch-macro-character #\# #\: #'sharp-colon)
 392   (set-dispatch-macro-character #\# #\. #'sharp-dot)
 393   (set-dispatch-macro-character #\# #\R #'sharp-R)
 394   (set-dispatch-macro-character #\# #\r #'sharp-R)
 395   (set-dispatch-macro-character #\# #\B #'sharp-B)
 396   (set-dispatch-macro-character #\# #\b #'sharp-B)
 397   (set-dispatch-macro-character #\# #\O #'sharp-O)
 398   (set-dispatch-macro-character #\# #\o #'sharp-O)
 399   (set-dispatch-macro-character #\# #\X #'sharp-X)
 400   (set-dispatch-macro-character #\# #\x #'sharp-X)
 401   (set-dispatch-macro-character #\# #\A #'sharp-A)
 402   (set-dispatch-macro-character #\# #\a #'sharp-A)
 403   (set-dispatch-macro-character #\# #\S #'sharp-S)
 404   (set-dispatch-macro-character #\# #\s #'sharp-S)
 405   (set-dispatch-macro-character #\# #\= #'sharp-equal)
 406   (set-dispatch-macro-character #\# #\# #'sharp-sharp)
 407   (set-dispatch-macro-character #\# #\+ #'sharp-plus)
 408   (set-dispatch-macro-character #\# #\- #'sharp-minus)
 409   (set-dispatch-macro-character #\# #\C #'sharp-C)
 410   (set-dispatch-macro-character #\# #\c #'sharp-C)
 411   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
 412   (set-dispatch-macro-character #\# #\p #'sharp-p)
 413   (set-dispatch-macro-character #\# #\P #'sharp-p)
 414   (set-dispatch-macro-character #\# #\  #'sharp-illegal)
 415   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
 416   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
 417   ;; FIXME: Should linefeed/newline go in this list too?
 418   (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code))
 419     (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))