src/read.lisp

   1 ;;; read.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; JSCL is free software: you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation, either version 3 of the
   9 ;; License, or (at your option) any later version.
  10 ;;
  11 ;; JSCL is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (/debug "loading read.lisp!")
  20
  21 ;;;; Reader
  22
  23 ;;; The Lisp reader, parse strings and return Lisp objects. The main
  24 ;;; entry points are `ls-read' and `ls-read-from-string'.
  25
  26 ;;; #= / ## implementation
  27
  28 ;; For now associations label->object are kept in a plist
  29 ;; May be it makes sense to use a vector instead if speed
  30 ;; is considered a problem with many labelled objects
  31 (defvar *labelled-objects* nil)
  32
  33 (defun new-labelled-objects-table ()
  34   (setf *labelled-objects* nil))
  35
  36 (defun find-labelled-object (id)
  37   (assoc id *labelled-objects*))
  38
  39 (defun add-labelled-object (id value)
  40   (push (cons id value) *labelled-objects*))
  41
  42 ;; A unique value used to mark in the labelled objects
  43 ;; table an object that is being constructed
  44 ;; (e.g. #1# while reading elements of "#1=(#1# #1# #1#)")
  45 (defvar *future-value* (make-symbol "future"))
  46
  47 ;; A unique value used to mark temporary values that will
  48 ;; be replaced when fixups are run.
  49 (defvar *fixup-value* (make-symbol "fixup"))
  50
  51 ;; Fixup locations keeps a list of conses where the CAR
  52 ;; is a callable to be called with the value of the object
  53 ;; associated to label stored in CDR once reading is completed
  54 (defvar *fixup-locations* nil)
  55
  56 (defun fixup-backrefs ()
  57   (while *fixup-locations*
  58     (let* ((fixup (pop *fixup-locations*))
  59            (callable (car fixup))
  60            (cell (find-labelled-object (cdr fixup))))
  61       (if cell
  62           (funcall callable (cdr cell))
  63           (error "Internal error in fixup-backrefs: object #~S# not found"
  64                  (cdr fixup))))))
  65
  66 ;; A function that will need to return a fixup callback
  67 ;; for the object that is being read. The returned callback will
  68 ;; be called with the result of reading.
  69 (defvar *make-fixup-function*
  70   (lambda ()
  71     (error "Internal error in fixup creation during read")))
  72
  73 (defun make-string-stream (string)
  74   (cons string 0))
  75
  76 (defun %peek-char (stream)
  77   (and (< (cdr stream) (length (car stream)))
  78        (char (car stream) (cdr stream))))
  79
  80 (defun %read-char (stream)
  81   (and (< (cdr stream) (length (car stream)))
  82        (prog1 (char (car stream) (cdr stream))
  83          (rplacd stream (1+ (cdr stream))))))
  84
  85 (defun whitespacep (ch)
  86   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
  87
  88 (defun skip-whitespaces (stream)
  89   (let (ch)
  90     (setq ch (%peek-char stream))
  91     (while (and ch (whitespacep ch))
  92       (%read-char stream)
  93       (setq ch (%peek-char stream)))))
  94
  95 (defun terminalp (ch)
  96   (or (null ch) (whitespacep ch) (char= #\" ch) (char= #\) ch) (char= #\( ch)))
  97
  98 (defun read-until (stream func)
  99   (let ((string "")
 100         (ch))
 101     (setq ch (%peek-char stream))
 102     (while (and ch (not (funcall func ch)))
 103       (setq string (concat string (string ch)))
 104       (%read-char stream)
 105       (setq ch (%peek-char stream)))
 106     string))
 107
 108 (defun read-escaped-until (stream func)
 109   (let ((string "")
 110         (ch (%peek-char stream))
 111         (multi-escape nil))
 112     (while (and ch (or multi-escape (not (funcall func ch))))
 113       (cond
 114         ((char= ch #\|)
 115          (if multi-escape
 116              (setf multi-escape nil)
 117              (setf multi-escape t)))
 118         ((char= ch #\\)
 119          (%read-char stream)
 120          (setf ch (%peek-char stream))
 121          (setf string (concat string "\\" (string ch))))
 122         (t
 123          (if multi-escape
 124              (setf string (concat string "\\" (string ch)))
 125              (setf string (concat string (string ch))))))
 126       (%read-char stream)
 127       (setf ch (%peek-char stream)))
 128     string))
 129
 130 (defun skip-whitespaces-and-comments (stream)
 131   (let (ch)
 132     (skip-whitespaces stream)
 133     (setq ch (%peek-char stream))
 134     (while (and ch (char= ch #\;))
 135       (read-until stream (lambda (x) (char= x #\newline)))
 136       (skip-whitespaces stream)
 137       (setq ch (%peek-char stream)))))
 138
 139 (defun discard-char (stream expected)
 140   (let ((ch (%read-char stream)))
 141     (when (null ch)
 142       (error "End of file when character ~S was expected." expected))
 143     (unless (char= ch expected)
 144       (error "Character ~S was found but ~S was expected." ch expected))))
 145
 146 (defun %read-list (stream &optional (eof-error-p t) eof-value)
 147   (skip-whitespaces-and-comments stream)
 148   (let ((ch (%peek-char stream)))
 149     (cond
 150       ((null ch)
 151        (error "Unspected EOF"))
 152       ((char= ch #\))
 153        (discard-char stream #\))
 154        nil)
 155       (t
 156        (let* ((cell (cons nil nil))
 157               (*make-fixup-function* (lambda ()
 158                                        (lambda (obj)
 159                                          (rplaca cell obj))))
 160               (eof (gensym))
 161               (next (ls-read stream nil eof t)))
 162          (rplaca cell next)
 163          (skip-whitespaces-and-comments stream)
 164          (cond
 165            ((eq next eof)
 166             (discard-char stream #\))
 167             nil)
 168            (t
 169             (if (char= (%peek-char stream) #\.)
 170                 (progn
 171                   (discard-char stream #\.)
 172                   (if (terminalp (%peek-char stream))
 173                       (let ((*make-fixup-function* (lambda ()
 174                                                      (lambda (obj)
 175                                                        (rplacd cell obj)))))
 176                         ;; Dotted pair notation
 177                         (rplacd cell (ls-read stream eof-error-p eof-value t))
 178                         (skip-whitespaces-and-comments stream)
 179                         (let ((ch (%peek-char stream)))
 180                           (if (or (null ch) (char= #\) ch))
 181                               (discard-char stream #\))
 182                               (error "Multiple objects following . in a list"))))
 183                       (let ((token (concat "." (read-escaped-until stream #'terminalp))))
 184                         (rplacd cell (cons (interpret-token token)
 185                                            (%read-list stream eof-error-p eof-value))))))
 186                 (rplacd cell (%read-list stream eof-error-p eof-value)))
 187             cell)))))))
 188
 189 (defun read-string (stream)
 190   (let ((string "")
 191         (ch nil))
 192     (setq ch (%read-char stream))
 193     (while (not (eql ch #\"))
 194       (when (null ch)
 195         (error "Unexpected EOF"))
 196       (when (eql ch #\\)
 197         (setq ch (%read-char stream)))
 198       (setq string (concat string (string ch)))
 199       (setq ch (%read-char stream)))
 200     string))
 201
 202 (defun read-sharp (stream &optional eof-error-p eof-value)
 203   (%read-char stream)
 204   (let ((ch (%read-char stream)))
 205     (case ch
 206       (#\'
 207        (list 'function (ls-read stream eof-error-p eof-value t)))
 208       (#\(
 209        (do ((elements nil)
 210             (result nil)
 211             (index 0 (1+ index)))
 212            ((progn (skip-whitespaces-and-comments stream)
 213                    (or (null (%peek-char stream))
 214                        (char= (%peek-char stream) #\))))
 215             (discard-char stream #\))
 216             (setf result (make-array index))
 217             (dotimes (i index)
 218               (aset result (decf index) (pop elements)))
 219             result)
 220          (let* ((ix index) ; Can't just use index: the same var would be captured in all fixups
 221                 (*make-fixup-function* (lambda ()
 222                                          (lambda (obj)
 223                                            (aset result ix obj))))
 224                 (eof (gensym))
 225                 (value (ls-read stream nil eof t)))
 226            (push value elements))))
 227       (#\:
 228        (make-symbol
 229         (unescape-token
 230          (string-upcase-noescaped
 231           (read-escaped-until stream #'terminalp)))))
 232       (#\\
 233        (let ((cname
 234               (concat (string (%read-char stream))
 235                       (read-until stream #'terminalp))))
 236          (cond
 237            ((string= cname "space") #\space)
 238            ((string= cname "tab") #\tab)
 239            ((string= cname "newline") #\newline)
 240            (t (char cname 0)))))
 241       ((#\+ #\-)
 242        (let ((feature (let ((symbol (ls-read stream eof-error-p eof-value t)))
 243                         (unless (symbolp symbol)
 244                           (error "Invalid feature ~S" symbol))
 245                         (intern (string symbol) "KEYWORD"))))
 246          (if (eql (char= ch #\+)
 247                   (and (find feature *features*) t))
 248              (ls-read stream eof-error-p eof-value t)
 249              (prog2 (ls-read stream)
 250                  (ls-read stream eof-error-p eof-value t)))))
 251       ((#\J #\j)
 252        (unless (char= (%peek-char stream) #\:)
 253          (error "FFI descriptor must start with a semicolon."))
 254        (let ((descriptor (subseq (read-until stream #'terminalp) 1))
 255              (subdescriptors nil))
 256          (do* ((start 0 (1+ end))
 257                (end (position #\: descriptor :start start)
 258                     (position #\: descriptor :start start)))
 259               ((null end)
 260                (push (subseq descriptor start) subdescriptors)
 261                `(oget *root* ,@(reverse subdescriptors)))
 262            (push (subseq descriptor start end) subdescriptors))))
 263       (otherwise
 264        (cond
 265          ((and ch (digit-char-p ch))
 266           (let ((id (digit-char-p ch)))
 267             (while (and (%peek-char stream)
 268                         (digit-char-p (%peek-char stream)))
 269               (setf id (+ (* id 10) (digit-char-p (%read-char stream)))))
 270             (ecase (%peek-char stream)
 271               (#\=
 272                (%read-char stream)
 273                (if (find-labelled-object id)
 274                    (error "Duplicated label #~S=" id)
 275                    (progn
 276                      (add-labelled-object id *future-value*)
 277                      (let ((obj (ls-read stream eof-error-p eof-value t)))
 278                        ;; FIXME: somehow the more natural
 279                        ;;    (setf (cdr (find-labelled-object id)) obj)
 280                        ;; doesn't work
 281                        (rplacd (find-labelled-object id) obj)
 282                        obj))))
 283               (#\#
 284                (%read-char stream)
 285                (let ((cell (find-labelled-object id)))
 286                  (if cell
 287                      (if (eq (cdr cell) *future-value*)
 288                          (progn
 289                            (push (cons (funcall *make-fixup-function*)
 290                                        id)
 291                                  *fixup-locations*)
 292                            *fixup-value*)
 293                          (cdr cell))
 294                      (error "Invalid labelled object #~S#" id)))))))
 295          (t
 296           (error "Invalid dispatch character after #")))))))
 297
 298 (defun unescape-token (x)
 299   (let ((result ""))
 300     (dotimes (i (length x))
 301       (unless (char= (char x i) #\\)
 302         (setq result (concat result (string (char x i))))))
 303     result))
 304
 305 (defun string-upcase-noescaped (s)
 306   (let ((result "")
 307         (last-escape nil))
 308     (dotimes (i (length s))
 309       (let ((ch (char s i)))
 310         (if last-escape
 311            (progn
 312               (setf last-escape nil)
 313               (setf result (concat result (string ch))))
 314             (if (char= ch #\\)
 315                 (setf last-escape t)
 316                 (setf result (concat result (string-upcase (string ch))))))))
 317     result))
 318
 319 ;;; Parse a string of the form NAME, PACKAGE:NAME or
 320 ;;; PACKAGE::NAME and return the name. If the string is of the
 321 ;;; form 1) or 3), but the symbol does not exist, it will be created
 322 ;;; and interned in that package.
 323 (defun read-symbol (string)
 324   (let ((size (length string))
 325         package name internalp index)
 326     (setq index 0)
 327     (while (and (< index size)
 328                 (not (char= (char string index) #\:)))
 329       (when (char= (char string index) #\\)
 330         (incf index))
 331       (incf index))
 332     (cond
 333       ;; No package prefix
 334       ((= index size)
 335        (setq name string)
 336        (setq package (package-name *package*))
 337        (setq internalp t))
 338       (t
 339        ;; Package prefix
 340        (if (zerop index)
 341            (setq package "KEYWORD")
 342            (setq package (string-upcase-noescaped (subseq string 0 index))))
 343        (incf index)
 344        (when (char= (char string index) #\:)
 345          (setq internalp t)
 346          (incf index))
 347        (setq name (subseq string index))))
 348     ;; Canonalize symbol name and package
 349     (setq name (if (string= package "JS")
 350                    (setq name (unescape-token name))
 351                    (setq name (string-upcase-noescaped name))))
 352     (setq package (find-package package))
 353     (if (or internalp
 354             (eq package (find-package "KEYWORD"))
 355             (eq package (find-package "JS")))
 356         (intern name package)
 357         (multiple-value-bind (symbol external)
 358             (find-symbol name package)
 359           (if (eq external :external)
 360               symbol
 361               (error "The symbol `~S' is not external in the package ~S." name package))))))
 362
 363 (defun read-integer (string)
 364   (let ((sign 1)
 365         (number nil)
 366         (size (length string)))
 367     (dotimes (i size)
 368       (let ((elt (char string i)))
 369         (cond
 370           ((digit-char-p elt)
 371            (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
 372           ((zerop i)
 373            (case elt
 374              (#\+ nil)
 375              (#\- (setq sign -1))
 376              (t (return-from read-integer))))
 377           ((and (= i (1- size)) (char= elt #\.)) nil)
 378           (t (return-from read-integer)))))
 379     (and number (* sign number))))
 380
 381 (defun read-float (string)
 382   (block nil
 383     (let ((sign 1)
 384           (integer-part nil)
 385           (fractional-part nil)
 386           (number 0)
 387           (divisor 1)
 388           (exponent-sign 1)
 389           (exponent 0)
 390           (size (length string))
 391           (index 0))
 392       (when (zerop size) (return))
 393       ;; Optional sign
 394       (case (char string index)
 395         (#\+ (incf index))
 396         (#\- (setq sign -1)
 397              (incf index)))
 398       (unless (< index size) (return))
 399       ;; Optional integer part
 400       (awhen (digit-char-p (char string index))
 401         (setq integer-part t)
 402         (while (and (< index size)
 403                     (setq it (digit-char-p (char string index))))
 404           (setq number (+ (* number 10) it))
 405           (incf index)))
 406       (unless (< index size) (return))
 407       ;; Decimal point is mandatory if there's no integer part
 408       (unless (or integer-part (char= #\. (char string index))) (return))
 409       ;; Optional fractional part
 410       (when (char= #\. (char string index))
 411         (incf index)
 412         (unless (< index size) (return))
 413         (awhen (digit-char-p (char string index))
 414           (setq fractional-part t)
 415           (while (and (< index size)
 416                       (setq it (digit-char-p (char string index))))
 417             (setq number (+ (* number 10) it))
 418             (setq divisor (* divisor 10))
 419             (incf index))))
 420       ;; Either left or right part of the dot must be present
 421       (unless (or integer-part fractional-part) (return))
 422       ;; Exponent is mandatory if there is no fractional part
 423       (when (and (= index size) (not fractional-part)) (return))
 424       ;; Optional exponent part
 425       (when (< index size)
 426         ;; Exponent-marker
 427         (unless (find (char-upcase (char string index)) "ESFDL")
 428           (return))
 429         (incf index)
 430         (unless (< index size) (return))
 431         ;; Optional exponent sign
 432         (case (char string index)
 433           (#\+ (incf index))
 434           (#\- (setq exponent-sign -1)
 435                (incf index)))
 436         (unless (< index size) (return))
 437         ;; Exponent digits
 438         (let ((value (digit-char-p (char string index))))
 439           (unless value (return))
 440           (while (and (< index size)
 441                       (setq value (digit-char-p (char string index))))
 442             (setq exponent (+ (* exponent 10) value))
 443             (incf index))))
 444       (unless (= index size) (return))
 445       ;; Everything went ok, we have a float
 446       ;; XXX: Use FLOAT when implemented.
 447       (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor 1.0))))
 448
 449 (defun !parse-integer (string junk-allow)
 450   (block nil
 451     (let ((value 0)
 452           (index 0)
 453           (size (length string))
 454           (sign 1))
 455       ;; Leading whitespace
 456       (while (and (< index size)
 457                   (whitespacep (char string index)))
 458         (incf index))
 459       (unless (< index size) (return (values nil 0)))
 460       ;; Optional sign
 461       (case (char string 0)
 462         (#\+ (incf index))
 463         (#\- (setq sign -1)
 464              (incf index)))
 465       ;; First digit
 466       (unless (and (< index size)
 467                    (setq value (digit-char-p (char string index))))
 468         (return (values nil index)))
 469       (incf index)
 470       ;; Other digits
 471       (while (< index size)
 472         (let ((digit (digit-char-p (char string index))))
 473           (unless digit (return))
 474           (setq value (+ (* value 10) digit))
 475           (incf index)))
 476       ;; Trailing whitespace
 477       (do ((i index (1+ i)))
 478           ((or (= i size) (not (whitespacep (char string i))))
 479            (and (= i size) (setq index i))))
 480       (if (or junk-allow
 481               (= index size))
 482           (values (* sign value) index)
 483           (values nil index)))))
 484
 485 #+jscl
 486 (defun parse-integer (string &key junk-allowed)
 487   (multiple-value-bind (num index)
 488       (!parse-integer string junk-allowed)
 489     (if num
 490         (values num index)
 491         (error "Junk detected."))))
 492
 493
 494 (defun interpret-token (string)
 495   (or (read-integer string)
 496       (read-float string)
 497       (read-symbol string)))
 498
 499 (defun ls-read (stream &optional (eof-error-p t) eof-value recursive-p)
 500   (let ((save-labelled-objects *labelled-objects*)
 501         (save-fixup-locations *fixup-locations*))
 502     (unless recursive-p
 503       (setf *fixup-locations* nil)
 504       (setf *labelled-objects* (new-labelled-objects-table)))
 505     (prog1
 506         (progn
 507           (skip-whitespaces-and-comments stream)
 508           (let ((ch (%peek-char stream)))
 509             (cond
 510               ((or (null ch) (char= ch #\)))
 511                (if eof-error-p
 512                    (error "End of file")
 513                    eof-value))
 514               ((char= ch #\()
 515                (%read-char stream)
 516                (%read-list stream eof-error-p eof-value))
 517               ((char= ch #\')
 518                (%read-char stream)
 519                (list 'quote (ls-read stream eof-error-p eof-value t)))
 520               ((char= ch #\`)
 521                (%read-char stream)
 522                (list 'backquote (ls-read stream eof-error-p eof-value t)))
 523               ((char= ch #\")
 524                (%read-char stream)
 525                (read-string stream))
 526               ((char= ch #\,)
 527                (%read-char stream)
 528                (if (eql (%peek-char stream) #\@)
 529                    (progn (%read-char stream) (list 'unquote-splicing
 530                                                     (ls-read stream eof-error-p eof-value t)))
 531                    (list 'unquote (ls-read stream eof-error-p eof-value t))))
 532               ((char= ch #\#)
 533                (read-sharp stream eof-error-p eof-value))
 534               (t
 535                (let ((string (read-escaped-until stream #'terminalp)))
 536                  (interpret-token string))))))
 537       (unless recursive-p
 538         (fixup-backrefs)
 539         (setf *labelled-objects* save-labelled-objects)
 540         (setf *fixup-locations* save-fixup-locations)))))
 541
 542 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
 543   (ls-read (make-string-stream string) eof-error-p eof-value))
 544
 545 #+jscl
 546 (defun read-from-string (string &optional (eof-errorp t) eof-value)
 547   (ls-read-from-string string eof-errorp eof-value))