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 (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                          "#~WA axis ~W is not a sequence:~%  ~S"
  96                          dimensions axis seq))
  97         (let ((len (length seq)))
  98           (dims len)
  99           (unless (or (= axis (1- dimensions))
 100                       ;; ANSI: "If some dimension of the array whose
 101                       ;; representation is being parsed is found to be
 102                       ;; 0, all dimensions to the right (i.e., the
 103                       ;; higher numbered dimensions) are also
 104                       ;; considered to be 0."
 105                       (= len 0))
 106             (setq seq (elt seq 0))))))))
 107 \f
 108 ;;;; reading structure instances: the #S readmacro
 109
 110 (defun sharp-S (stream sub-char numarg)
 111   (ignore-numarg sub-char numarg)
 112   (when *read-suppress*
 113     (read stream t nil t)
 114     (return-from sharp-S nil))
 115   (let ((body (if (char= (read-char stream t) #\( )
 116                   (read-list stream nil)
 117                   (%reader-error stream "non-list following #S"))))
 118     (unless (listp body)
 119       (%reader-error stream "non-list following #S: ~S" body))
 120     (unless (symbolp (car body))
 121       (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
 122     (let ((classoid (find-classoid (car body) nil)))
 123       (unless (typep classoid 'structure-classoid)
 124         (%reader-error stream "~S is not a defined structure type."
 125                        (car body)))
 126       (let ((def-con (dd-default-constructor
 127                       (layout-info
 128                        (classoid-layout classoid)))))
 129         (unless def-con
 130           (%reader-error
 131            stream "The ~S structure does not have a default constructor."
 132            (car body)))
 133         (when (and (atom (rest body))
 134                    (not (null (rest body))))
 135           (%reader-error
 136            stream "improper list for #S: ~S." body))
 137         (apply (fdefinition def-con)
 138                (loop for tail on (rest body) by #'cddr
 139                      with slot-name = (and (consp tail) (car tail))
 140                      do (progn
 141                           (when (null (cdr tail))
 142                             (%reader-error
 143                              stream
 144                              "the arglist for the ~S constructor in #S ~
 145                               has an odd length: ~S."
 146                              (car body) (rest body)))
 147                           (when (or (atom (cdr tail))
 148                                     (and (atom (cddr tail))
 149                                          (not (null (cddr tail)))))
 150                             (%reader-error
 151                              stream
 152                              "the arglist for the ~S constructor in #S ~
 153                               is improper: ~S."
 154                              (car body) (rest body)))
 155                           (when (not (typep (car tail) 'string-designator))
 156                             (%reader-error
 157                              stream
 158                              "a slot name in #S is not a string ~
 159                               designator: ~S."
 160                              slot-name))
 161                           (when (not (keywordp slot-name))
 162                             (style-warn "in #S ~S, the use of non-keywords ~
 163                                          as slot specifiers is deprecated: ~S."
 164                                         (car body) slot-name)))
 165                      collect (intern (string (car tail)) *keyword-package*)
 166                      collect (cadr tail)))))))
 167 \f
 168 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
 169
 170 (defun sharp-B (stream sub-char numarg)
 171   (ignore-numarg sub-char numarg)
 172   (sharp-r stream sub-char 2))
 173
 174 (defun sharp-C (stream sub-char numarg)
 175   (ignore-numarg sub-char numarg)
 176   ;; The next thing had better be a list of two numbers.
 177   (let ((cnum (read stream t nil t)))
 178     (when *read-suppress* (return-from sharp-c nil))
 179     (if (and (listp cnum) (= (length cnum) 2))
 180         (complex (car cnum) (cadr cnum))
 181         (%reader-error stream "illegal complex number format: #C~S" cnum))))
 182
 183 (defun sharp-O (stream sub-char numarg)
 184   (ignore-numarg sub-char numarg)
 185   (sharp-r stream sub-char 8))
 186
 187 (defun sharp-R (stream sub-char radix)
 188   (cond (*read-suppress*
 189          (read-extended-token stream)
 190          nil)
 191         ((not radix)
 192          (%reader-error stream "radix missing in #R"))
 193         ((not (<= 2 radix 36))
 194          (%reader-error stream "illegal radix for #R: ~D." radix))
 195         (t
 196          (let ((res (let ((*read-base* radix))
 197                       (read stream t nil t))))
 198            (unless (typep res 'rational)
 199              (%reader-error stream
 200                             "#~A (base ~D.) value is not a rational: ~S."
 201                             sub-char
 202                             radix
 203                             res))
 204            res))))
 205
 206 (defun sharp-X (stream sub-char numarg)
 207   (ignore-numarg sub-char numarg)
 208   (sharp-r stream sub-char 16))
 209 \f
 210 ;;;; reading circular data: the #= and ## readmacros
 211
 212 ;;; objects already seen by CIRCLE-SUBST
 213 (defvar *sharp-equal-circle-table*)
 214 (declaim (type hash-table *sharp-equal-circle-table*))
 215
 216 ;; This function is kind of like NSUBLIS, but checks for circularities and
 217 ;; substitutes in arrays and structures as well as lists. The first arg is an
 218 ;; alist of the things to be replaced assoc'd with the things to replace them.
 219 (defun circle-subst (old-new-alist tree)
 220   (cond ((not (typep tree '(or cons (array t) structure-object standard-object)))
 221          (let ((entry (find tree old-new-alist :key #'second)))
 222            (if entry (third entry) tree)))
 223         ((null (gethash tree *sharp-equal-circle-table*))
 224          (setf (gethash tree *sharp-equal-circle-table*) t)
 225          (cond ((typep tree '(or structure-object standard-object))
 226                 (do ((i 1 (1+ i))
 227                      (end (%instance-length tree)))
 228                     ((= i end))
 229                   (let* ((old (%instance-ref tree i))
 230                          (new (circle-subst old-new-alist old)))
 231                     (unless (eq old new)
 232                       (setf (%instance-ref tree i) new)))))
 233                ((arrayp tree)
 234                 (with-array-data ((data tree) (start) (end))
 235                   (declare (fixnum start end))
 236                   (do ((i start (1+ i)))
 237                       ((>= i end))
 238                     (let* ((old (aref data i))
 239                            (new (circle-subst old-new-alist old)))
 240                       (unless (eq old new)
 241                         (setf (aref data i) new))))))
 242                (t
 243                 (let ((a (circle-subst old-new-alist (car tree)))
 244                       (d (circle-subst old-new-alist (cdr tree))))
 245                   (unless (eq a (car tree))
 246                     (rplaca tree a))
 247                   (unless (eq d (cdr tree))
 248                     (rplacd tree d)))))
 249          tree)
 250         (t tree)))
 251
 252 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
 253 ;;; #= is called) we GENSYM a symbol is which is used as an
 254 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
 255 ;;; gensym.
 256 ;;;
 257 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
 258 ;;; symbol assoc'd with the label. Resolution of the reference is
 259 ;;; deferred until the read done by #= finishes. Any already resolved
 260 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
 261 ;;;
 262 ;;; After reading of the #= form is completed, we add an entry to
 263 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
 264 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
 265 ;;; object is searched and any uses of the gensysm token are replaced
 266 ;;; with the actual value.
 267 (defvar *sharp-sharp-alist* ())
 268
 269 (defun sharp-equal (stream ignore label)
 270   (declare (ignore ignore))
 271   (when *read-suppress* (return-from sharp-equal (values)))
 272   (unless label
 273     (%reader-error stream "missing label for #=" label))
 274   (when (or (assoc label *sharp-sharp-alist*)
 275             (assoc label *sharp-equal-alist*))
 276     (%reader-error stream "multiply defined label: #~D=" label))
 277   (let* ((tag (gensym))
 278          (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
 279          (obj (read stream t nil t)))
 280     (when (eq obj tag)
 281       (%reader-error stream
 282                      "must tag something more than just #~D#"
 283                      label))
 284     (push (list label tag obj) *sharp-equal-alist*)
 285     (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
 286       (circle-subst *sharp-equal-alist* obj))))
 287
 288 (defun sharp-sharp (stream ignore label)
 289   (declare (ignore ignore))
 290   (when *read-suppress* (return-from sharp-sharp nil))
 291   (unless label
 292     (%reader-error stream "missing label for ##" label))
 293
 294   (let ((entry (assoc label *sharp-equal-alist*)))
 295     (if entry
 296         (third entry)
 297         (let ((pair (assoc label *sharp-sharp-alist*)))
 298           (unless pair
 299             (%reader-error stream "object is not labelled #~S#" label))
 300           (cdr pair)))))
 301 \f
 302 ;;;; conditional compilation: the #+ and #- readmacros
 303
 304 (flet ((guts (stream not-p)
 305          (unless (if (handler-case
 306                          (let ((*package* *keyword-package*)
 307                                (*read-suppress* nil))
 308                            (featurep (read stream t nil t)))
 309                        (reader-package-error
 310                         (condition)
 311                         (declare (ignore condition))
 312                         nil))
 313                      (not not-p)
 314                      not-p)
 315            (let ((*read-suppress* t))
 316              (read stream t nil t)))
 317          (values)))
 318
 319   (defun sharp-plus (stream sub-char numarg)
 320     (ignore-numarg sub-char numarg)
 321     (guts stream nil))
 322
 323   (defun sharp-minus (stream sub-char numarg)
 324     (ignore-numarg sub-char numarg)
 325     (guts stream t)))
 326 \f
 327 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
 328
 329 (defun sharp-P (stream sub-char numarg)
 330   (ignore-numarg sub-char numarg)
 331   (let ((namestring (read stream t nil t)))
 332     (unless *read-suppress*
 333       (parse-namestring namestring))))
 334
 335 (defun sharp-backslash (stream backslash numarg)
 336   (ignore-numarg backslash numarg)
 337   (let ((charstring (read-extended-token-escaped stream)))
 338     (declare (simple-string charstring))
 339     (cond (*read-suppress* nil)
 340           ((= (the fixnum (length charstring)) 1)
 341            (char charstring 0))
 342           ((name-char charstring))
 343           (t
 344            (%reader-error stream "unrecognized character name: ~S"
 345                           charstring)))))
 346
 347 (defun sharp-vertical-bar (stream sub-char numarg)
 348   (ignore-numarg sub-char numarg)
 349   (let ((stream (in-synonym-of stream)))
 350     (if (ansi-stream-p stream)
 351         (prepare-for-fast-read-char stream
 352           (do ((level 1)
 353                (prev (fast-read-char) char)
 354                (char (fast-read-char) (fast-read-char)))
 355               (())
 356             (cond ((and (char= prev #\|) (char= char #\#))
 357                    (setq level (1- level))
 358                    (when (zerop level)
 359                      (done-with-fast-read-char)
 360                      (return (values)))
 361                    (setq char (fast-read-char)))
 362                   ((and (char= prev #\#) (char= char #\|))
 363                    (setq char (fast-read-char))
 364                    (setq level (1+ level))))))
 365         ;; fundamental-stream
 366         (do ((level 1)
 367              (prev (read-char stream t) char)
 368              (char (read-char stream t) (read-char stream t)))
 369             (())
 370           (cond ((and (char= prev #\|) (char= char #\#))
 371                  (setq level (1- level))
 372                  (when (zerop level)
 373                    (return (values)))
 374                  (setq char (read-char stream t)))
 375                 ((and (char= prev #\#) (char= char #\|))
 376                  (setq char (read-char stream t))
 377                  (setq level (1+ level))))))))
 378 \f
 379 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
 380
 381 (defun sharp-quote (stream sub-char numarg)
 382   (ignore-numarg sub-char numarg)
 383   ;; The fourth arg tells READ that this is a recursive call.
 384   `(function ,(read stream t nil t)))
 385
 386 (defun sharp-colon (stream sub-char numarg)
 387   (ignore-numarg sub-char numarg)
 388   (multiple-value-bind (token escapep colon) (read-extended-token stream)
 389     (declare (simple-string token) (ignore escapep))
 390     (cond
 391      (*read-suppress* nil)
 392      (colon
 393       (%reader-error stream
 394                      "The symbol following #: contains a package marker: ~S"
 395                      token))
 396      (t
 397       (make-symbol token)))))
 398
 399 (defvar *read-eval* t
 400   #!+sb-doc
 401   "If false, then the #. read macro is disabled.")
 402
 403 (defun sharp-dot (stream sub-char numarg)
 404   (ignore-numarg sub-char numarg)
 405   (let ((token (read stream t nil t)))
 406     (unless *read-suppress*
 407       (unless *read-eval*
 408         (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
 409       (eval token))))
 410 \f
 411 (defun sharp-illegal (stream sub-char ignore)
 412   (declare (ignore ignore))
 413   (%reader-error stream "illegal sharp macro character: ~S" sub-char))
 414
 415 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
 416 (defun !sharpm-cold-init ()
 417   (make-dispatch-macro-character #\# t)
 418   (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
 419   (set-dispatch-macro-character #\# #\' #'sharp-quote)
 420   (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
 421   (set-dispatch-macro-character #\# #\* #'sharp-star)
 422   (set-dispatch-macro-character #\# #\: #'sharp-colon)
 423   (set-dispatch-macro-character #\# #\. #'sharp-dot)
 424   (set-dispatch-macro-character #\# #\R #'sharp-R)
 425   (set-dispatch-macro-character #\# #\r #'sharp-R)
 426   (set-dispatch-macro-character #\# #\B #'sharp-B)
 427   (set-dispatch-macro-character #\# #\b #'sharp-B)
 428   (set-dispatch-macro-character #\# #\O #'sharp-O)
 429   (set-dispatch-macro-character #\# #\o #'sharp-O)
 430   (set-dispatch-macro-character #\# #\X #'sharp-X)
 431   (set-dispatch-macro-character #\# #\x #'sharp-X)
 432   (set-dispatch-macro-character #\# #\A #'sharp-A)
 433   (set-dispatch-macro-character #\# #\a #'sharp-A)
 434   (set-dispatch-macro-character #\# #\S #'sharp-S)
 435   (set-dispatch-macro-character #\# #\s #'sharp-S)
 436   (set-dispatch-macro-character #\# #\= #'sharp-equal)
 437   (set-dispatch-macro-character #\# #\# #'sharp-sharp)
 438   (set-dispatch-macro-character #\# #\+ #'sharp-plus)
 439   (set-dispatch-macro-character #\# #\- #'sharp-minus)
 440   (set-dispatch-macro-character #\# #\C #'sharp-C)
 441   (set-dispatch-macro-character #\# #\c #'sharp-C)
 442   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
 443   (set-dispatch-macro-character #\# #\p #'sharp-p)
 444   (set-dispatch-macro-character #\# #\P #'sharp-p)
 445   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
 446   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
 447   (set-dispatch-macro-character #\# #\Space #'sharp-illegal)
 448   (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code
 449                        line-feed-char-code backspace-char-code))
 450     (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))