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