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        (eval (ls-read stream)))
 210       (#\(
 211        (do ((elements nil)
 212             (result nil)
 213             (index 0 (1+ index)))
 214            ((progn (skip-whitespaces-and-comments stream)
 215                    (or (null (%peek-char stream))
 216                        (char= (%peek-char stream) #\))))
 217             (discard-char stream #\))
 218             (setf result (make-array index))
 219             (dotimes (i index)
 220               (aset result (decf index) (pop elements)))
 221             result)
 222          (let* ((ix index) ; Can't just use index: the same var would be captured in all fixups
 223                 (*make-fixup-function* (lambda ()
 224                                          (lambda (obj)
 225                                            (aset result ix obj))))
 226                 (eof (gensym))
 227                 (value (ls-read stream nil eof t)))
 228            (push value elements))))
 229       (#\:
 230        (make-symbol
 231         (unescape-token
 232          (string-upcase-noescaped
 233           (read-escaped-until stream #'terminalp)))))
 234       (#\\
 235        (let ((cname
 236               (concat (string (%read-char stream))
 237                       (read-until stream #'terminalp))))
 238          (cond
 239            ((string= cname "space") #\space)
 240            ((string= cname "tab") #\tab)
 241            ((string= cname "newline") #\newline)
 242            (t (char cname 0)))))
 243       ((#\+ #\-)
 244        (let ((feature (let ((symbol (ls-read stream eof-error-p eof-value t)))
 245                         (unless (symbolp symbol)
 246                           (error "Invalid feature ~S" symbol))
 247                         (intern (string symbol) "KEYWORD"))))
 248          (if (eql (char= ch #\+)
 249                   (and (find feature *features*) t))
 250              (ls-read stream eof-error-p eof-value t)
 251              (prog2 (ls-read stream)
 252                  (ls-read stream eof-error-p eof-value t)))))
 253       ((#\J #\j)
 254        (unless (char= (%peek-char stream) #\:)
 255          (error "FFI descriptor must start with a semicolon."))
 256        (let ((descriptor (subseq (read-until stream #'terminalp) 1))
 257              (subdescriptors nil))
 258          (do* ((start 0 (1+ end))
 259                (end (position #\: descriptor :start start)
 260                     (position #\: descriptor :start start)))
 261               ((null end)
 262                (push (subseq descriptor start) subdescriptors)
 263                `(oget *root* ,@(reverse subdescriptors)))
 264            (push (subseq descriptor start end) subdescriptors))))
 265       (otherwise
 266        (cond
 267          ((and ch (digit-char-p ch))
 268           (let ((id (digit-char-p ch)))
 269             (while (and (%peek-char stream)
 270                         (digit-char-p (%peek-char stream)))
 271               (setf id (+ (* id 10) (digit-char-p (%read-char stream)))))
 272             (ecase (%peek-char stream)
 273               (#\=
 274                (%read-char stream)
 275                (if (find-labelled-object id)
 276                    (error "Duplicated label #~S=" id)
 277                    (progn
 278                      (add-labelled-object id *future-value*)
 279                      (let ((obj (ls-read stream eof-error-p eof-value t)))
 280                        ;; FIXME: somehow the more natural
 281                        ;;    (setf (cdr (find-labelled-object id)) obj)
 282                        ;; doesn't work
 283                        (rplacd (find-labelled-object id) obj)
 284                        obj))))
 285               (#\#
 286                (%read-char stream)
 287                (let ((cell (find-labelled-object id)))
 288                  (if cell
 289                      (if (eq (cdr cell) *future-value*)
 290                          (progn
 291                            (push (cons (funcall *make-fixup-function*)
 292                                        id)
 293                                  *fixup-locations*)
 294                            *fixup-value*)
 295                          (cdr cell))
 296                      (error "Invalid labelled object #~S#" id)))))))
 297          (t
 298           (error "Invalid dispatch character after #")))))))
 299
 300 (defun unescape-token (x)
 301   (let ((result ""))
 302     (dotimes (i (length x))
 303       (unless (char= (char x i) #\\)
 304         (setq result (concat result (string (char x i))))))
 305     result))
 306
 307 (defun string-upcase-noescaped (s)
 308   (let ((result "")
 309         (last-escape nil))
 310     (dotimes (i (length s))
 311       (let ((ch (char s i)))
 312         (if last-escape
 313            (progn
 314               (setf last-escape nil)
 315               (setf result (concat result (string ch))))
 316             (if (char= ch #\\)
 317                 (setf last-escape t)
 318                 (setf result (concat result (string-upcase (string ch))))))))
 319     result))
 320
 321 ;;; Parse a string of the form NAME, PACKAGE:NAME or
 322 ;;; PACKAGE::NAME and return the name. If the string is of the
 323 ;;; form 1) or 3), but the symbol does not exist, it will be created
 324 ;;; and interned in that package.
 325 (defun read-symbol (string)
 326   (let ((size (length string))
 327         package name internalp index)
 328     (setq index 0)
 329     (while (and (< index size)
 330                 (not (char= (char string index) #\:)))
 331       (when (char= (char string index) #\\)
 332         (incf index))
 333       (incf index))
 334     (cond
 335       ;; No package prefix
 336       ((= index size)
 337        (setq name string)
 338        (setq package (package-name *package*))
 339        (setq internalp t))
 340       (t
 341        ;; Package prefix
 342        (if (zerop index)
 343            (setq package "KEYWORD")
 344            (setq package (string-upcase-noescaped (subseq string 0 index))))
 345        (incf index)
 346        (when (char= (char string index) #\:)
 347          (setq internalp t)
 348          (incf index))
 349        (setq name (subseq string index))))
 350     ;; Canonalize symbol name and package
 351     (setq name (if (string= package "JS")
 352                    (setq name (unescape-token name))
 353                    (setq name (string-upcase-noescaped name))))
 354     (setq package (find-package package))
 355     (if (or internalp
 356             (eq package (find-package "KEYWORD"))
 357             (eq package (find-package "JS")))
 358         (intern name package)
 359         (multiple-value-bind (symbol external)
 360             (find-symbol name package)
 361           (if (eq external :external)
 362               symbol
 363               (error "The symbol `~S' is not external in the package ~S." name package))))))
 364
 365 (defun read-integer (string)
 366   (let ((sign 1)
 367         (number nil)
 368         (size (length string)))
 369     (dotimes (i size)
 370       (let ((elt (char string i)))
 371         (cond
 372           ((digit-char-p elt)
 373            (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
 374           ((zerop i)
 375            (case elt
 376              (#\+ nil)
 377              (#\- (setq sign -1))
 378              (t (return-from read-integer))))
 379           ((and (= i (1- size)) (char= elt #\.)) nil)
 380           (t (return-from read-integer)))))
 381     (and number (* sign number))))
 382
 383 (defun read-float (string)
 384   (block nil
 385     (let ((sign 1)
 386           (integer-part nil)
 387           (fractional-part nil)
 388           (number 0)
 389           (divisor 1)
 390           (exponent-sign 1)
 391           (exponent 0)
 392           (size (length string))
 393           (index 0))
 394       (when (zerop size) (return))
 395       ;; Optional sign
 396       (case (char string index)
 397         (#\+ (incf index))
 398         (#\- (setq sign -1)
 399              (incf index)))
 400       (unless (< index size) (return))
 401       ;; Optional integer part
 402       (awhen (digit-char-p (char string index))
 403         (setq integer-part t)
 404         (while (and (< index size)
 405                     (setq it (digit-char-p (char string index))))
 406           (setq number (+ (* number 10) it))
 407           (incf index)))
 408       (unless (< index size) (return))
 409       ;; Decimal point is mandatory if there's no integer part
 410       (unless (or integer-part (char= #\. (char string index))) (return))
 411       ;; Optional fractional part
 412       (when (char= #\. (char string index))
 413         (incf index)
 414         (unless (< index size) (return))
 415         (awhen (digit-char-p (char string index))
 416           (setq fractional-part t)
 417           (while (and (< index size)
 418                       (setq it (digit-char-p (char string index))))
 419             (setq number (+ (* number 10) it))
 420             (setq divisor (* divisor 10))
 421             (incf index))))
 422       ;; Either left or right part of the dot must be present
 423       (unless (or integer-part fractional-part) (return))
 424       ;; Exponent is mandatory if there is no fractional part
 425       (when (and (= index size) (not fractional-part)) (return))
 426       ;; Optional exponent part
 427       (when (< index size)
 428         ;; Exponent-marker
 429         (unless (find (char-upcase (char string index)) "ESFDL")
 430           (return))
 431         (incf index)
 432         (unless (< index size) (return))
 433         ;; Optional exponent sign
 434         (case (char string index)
 435           (#\+ (incf index))
 436           (#\- (setq exponent-sign -1)
 437                (incf index)))
 438         (unless (< index size) (return))
 439         ;; Exponent digits
 440         (let ((value (digit-char-p (char string index))))
 441           (unless value (return))
 442           (while (and (< index size)
 443                       (setq value (digit-char-p (char string index))))
 444             (setq exponent (+ (* exponent 10) value))
 445             (incf index))))
 446       (unless (= index size) (return))
 447       ;; Everything went ok, we have a float
 448       ;; XXX: Use FLOAT when implemented.
 449       (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor 1.0))))
 450
 451 (defun !parse-integer (string junk-allow)
 452   (block nil
 453     (let ((value 0)
 454           (index 0)
 455           (size (length string))
 456           (sign 1))
 457       ;; Leading whitespace
 458       (while (and (< index size)
 459                   (whitespacep (char string index)))
 460         (incf index))
 461       (unless (< index size) (return (values nil 0)))
 462       ;; Optional sign
 463       (case (char string 0)
 464         (#\+ (incf index))
 465         (#\- (setq sign -1)
 466              (incf index)))
 467       ;; First digit
 468       (unless (and (< index size)
 469                    (setq value (digit-char-p (char string index))))
 470         (return (values nil index)))
 471       (incf index)
 472       ;; Other digits
 473       (while (< index size)
 474         (let ((digit (digit-char-p (char string index))))
 475           (unless digit (return))
 476           (setq value (+ (* value 10) digit))
 477           (incf index)))
 478       ;; Trailing whitespace
 479       (do ((i index (1+ i)))
 480           ((or (= i size) (not (whitespacep (char string i))))
 481            (and (= i size) (setq index i))))
 482       (if (or junk-allow
 483               (= index size))
 484           (values (* sign value) index)
 485           (values nil index)))))
 486
 487 #+jscl
 488 (defun parse-integer (string &key junk-allowed)
 489   (multiple-value-bind (num index)
 490       (!parse-integer string junk-allowed)
 491     (if num
 492         (values num index)
 493         (error "Junk detected."))))
 494
 495
 496 (defun interpret-token (string)
 497   (or (read-integer string)
 498       (read-float string)
 499       (read-symbol string)))
 500
 501 (defun ls-read (stream &optional (eof-error-p t) eof-value recursive-p)
 502   (let ((save-labelled-objects *labelled-objects*)
 503         (save-fixup-locations *fixup-locations*))
 504     (unless recursive-p
 505       (setf *fixup-locations* nil)
 506       (setf *labelled-objects* (new-labelled-objects-table)))
 507     (prog1
 508         (progn
 509           (skip-whitespaces-and-comments stream)
 510           (let ((ch (%peek-char stream)))
 511             (cond
 512               ((or (null ch) (char= ch #\)))
 513                (if eof-error-p
 514                    (error "End of file")
 515                    eof-value))
 516               ((char= ch #\()
 517                (%read-char stream)
 518                (%read-list stream eof-error-p eof-value))
 519               ((char= ch #\')
 520                (%read-char stream)
 521                (list 'quote (ls-read stream eof-error-p eof-value t)))
 522               ((char= ch #\`)
 523                (%read-char stream)
 524                (list 'backquote (ls-read stream eof-error-p eof-value t)))
 525               ((char= ch #\")
 526                (%read-char stream)
 527                (read-string stream))
 528               ((char= ch #\,)
 529                (%read-char stream)
 530                (if (eql (%peek-char stream) #\@)
 531                    (progn (%read-char stream) (list 'unquote-splicing
 532                                                     (ls-read stream eof-error-p eof-value t)))
 533                    (list 'unquote (ls-read stream eof-error-p eof-value t))))
 534               ((char= ch #\#)
 535                (read-sharp stream eof-error-p eof-value))
 536               (t
 537                (let ((string (read-escaped-until stream #'terminalp)))
 538                  (interpret-token string))))))
 539       (unless recursive-p
 540         (fixup-backrefs)
 541         (setf *labelled-objects* save-labelled-objects)
 542         (setf *fixup-locations* save-fixup-locations)))))
 543
 544 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
 545   (ls-read (make-string-stream string) eof-error-p eof-value))
 546
 547 #+jscl
 548 (defun read-from-string (string &optional (eof-errorp t) eof-value)
 549   (ls-read-from-string string eof-errorp eof-value))