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