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 (defun make-string-stream (string)
  26   (cons string 0))
  27
  28 (defun %peek-char (stream)
  29   (and (< (cdr stream) (length (car stream)))
  30        (char (car stream) (cdr stream))))
  31
  32 (defun %read-char (stream)
  33   (and (< (cdr stream) (length (car stream)))
  34        (prog1 (char (car stream) (cdr stream))
  35          (rplacd stream (1+ (cdr stream))))))
  36
  37 (defun whitespacep (ch)
  38   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
  39
  40 (defun skip-whitespaces (stream)
  41   (let (ch)
  42     (setq ch (%peek-char stream))
  43     (while (and ch (whitespacep ch))
  44       (%read-char stream)
  45       (setq ch (%peek-char stream)))))
  46
  47 (defun terminalp (ch)
  48   (or (null ch) (whitespacep ch) (char= #\" ch) (char= #\) ch) (char= #\( ch)))
  49
  50 (defun read-until (stream func)
  51   (let ((string "")
  52         (ch))
  53     (setq ch (%peek-char stream))
  54     (while (and ch (not (funcall func ch)))
  55       (setq string (concat string (string ch)))
  56       (%read-char stream)
  57       (setq ch (%peek-char stream)))
  58     string))
  59
  60 (defun read-escaped-until (stream func)
  61   (let ((string "")
  62         (ch (%peek-char stream))
  63         (multi-escape nil))
  64     (while (and ch (or multi-escape (not (funcall func ch))))
  65       (cond
  66         ((char= ch #\|)
  67          (if multi-escape
  68              (setf multi-escape nil)
  69              (setf multi-escape t)))
  70         ((char= ch #\\)
  71          (%read-char stream)
  72          (setf ch (%peek-char stream))
  73          (setf string (concat string "\\" (string ch))))
  74         (t
  75          (if multi-escape
  76              (setf string (concat string "\\" (string ch)))
  77              (setf string (concat string (string ch))))))
  78       (%read-char stream)
  79       (setf ch (%peek-char stream)))
  80     string))
  81
  82 (defun skip-whitespaces-and-comments (stream)
  83   (let (ch)
  84     (skip-whitespaces stream)
  85     (setq ch (%peek-char stream))
  86     (while (and ch (char= ch #\;))
  87       (read-until stream (lambda (x) (char= x #\newline)))
  88       (skip-whitespaces stream)
  89       (setq ch (%peek-char stream)))))
  90
  91 (defun discard-char (stream expected)
  92   (let ((ch (%read-char stream)))
  93     (when (null ch)
  94       (error "End of file when character ~S was expected." expected))
  95     (unless (char= ch expected)
  96       (error "Character ~S was found but ~S was expected." ch expected))))
  97
  98 (defun %read-list (stream)
  99   (skip-whitespaces-and-comments stream)
 100   (let ((ch (%peek-char stream)))
 101     (cond
 102       ((null ch)
 103        (error "Unspected EOF"))
 104       ((char= ch #\))
 105        (discard-char stream #\))
 106        nil)
 107       (t
 108        (let* ((eof (gensym))
 109               (next (ls-read stream nil eof)))
 110          (skip-whitespaces-and-comments stream)
 111          (cond
 112            ((eq next eof)
 113             (discard-char stream #\)))
 114            (t
 115             (cons next
 116                   (if (char= (%peek-char stream) #\.)
 117                       (progn
 118                         (discard-char stream #\.)
 119                         (if (terminalp (%peek-char stream))
 120                             (prog1 (ls-read stream) ; Dotted pair notation
 121                               (skip-whitespaces-and-comments stream)
 122                               (let ((ch (%peek-char stream)))
 123                                 (if (or (null ch) (char= #\) ch))
 124                                     (discard-char stream #\))
 125                                     (error "Multiple objects following . in a list"))))
 126                             (let ((token (concat "." (read-escaped-until stream #'terminalp))))
 127                               (cons (interpret-token token)
 128                                     (%read-list stream)))))
 129                       (%read-list stream))))))))))
 130
 131 (defun read-string (stream)
 132   (let ((string "")
 133         (ch nil))
 134     (setq ch (%read-char stream))
 135     (while (not (eql ch #\"))
 136       (when (null ch)
 137         (error "Unexpected EOF"))
 138       (when (eql ch #\\)
 139         (setq ch (%read-char stream)))
 140       (setq string (concat string (string ch)))
 141       (setq ch (%read-char stream)))
 142     string))
 143
 144 (defun read-sharp (stream &optional eof-error-p eof-value)
 145   (%read-char stream)
 146   (ecase (%read-char stream)
 147     (#\'
 148      (list 'function (ls-read stream)))
 149     (#\( (list-to-vector (%read-list stream)))
 150     (#\: (make-symbol
 151           (unescape
 152            (string-upcase-noescaped
 153             (read-escaped-until stream #'terminalp)))))
 154     (#\\
 155      (let ((cname
 156             (concat (string (%read-char stream))
 157                     (read-until stream #'terminalp))))
 158        (cond
 159          ((string= cname "space") #\space)
 160          ((string= cname "tab") #\tab)
 161          ((string= cname "newline") #\newline)
 162          (t (char cname 0)))))
 163     (#\+
 164      (let ((feature (let ((symbol (ls-read stream)))
 165                       (unless (symbolp symbol)
 166                         (error "Invalid feature ~S" symbol))
 167                       (intern (string symbol) "KEYWORD"))))
 168        (ecase feature
 169          (:common-lisp
 170           (ls-read stream)
 171           (ls-read stream eof-error-p eof-value))
 172          (:jscl
 173           (ls-read stream eof-error-p eof-value)))))))
 174
 175 (defun unescape (x)
 176   (let ((result ""))
 177     (dotimes (i (length x))
 178       (unless (char= (char x i) #\\)
 179         (setq result (concat result (string (char x i))))))
 180     result))
 181
 182 (defun escape-all (x)
 183   (let ((result ""))
 184     (dotimes (i (length x))
 185       (setq result (concat result "\\"))
 186       (setq result (concat result (string (char x i)))))
 187     result))
 188
 189 (defun string-upcase-noescaped (s)
 190   (let ((result "")
 191         (last-escape nil))
 192     (dotimes (i (length s))
 193       (let ((ch (char s i)))
 194         (if last-escape
 195            (progn
 196               (setf last-escape nil)
 197               (setf result (concat result (string ch))))
 198             (if (char= ch #\\)
 199                 (setf last-escape t)
 200                 (setf result (concat result (string-upcase (string ch))))))))
 201     result))
 202
 203 ;;; Parse a string of the form NAME, PACKAGE:NAME or
 204 ;;; PACKAGE::NAME and return the name. If the string is of the
 205 ;;; form 1) or 3), but the symbol does not exist, it will be created
 206 ;;; and interned in that package.
 207 (defun read-symbol (string)
 208   (let ((size (length string))
 209         package name internalp index)
 210     (setq index 0)
 211     (while (and (< index size)
 212                 (not (char= (char string index) #\:)))
 213       (when (char= (char string index) #\\)
 214         (incf index))
 215       (incf index))
 216     (cond
 217       ;; No package prefix
 218       ((= index size)
 219        (setq name string)
 220        (setq package *package*)
 221        (setq internalp t))
 222       (t
 223        ;; Package prefix
 224        (if (zerop index)
 225            (setq package "KEYWORD")
 226            (setq package (string-upcase-noescaped (subseq string 0 index))))
 227        (incf index)
 228        (when (char= (char string index) #\:)
 229          (setq internalp t)
 230          (incf index))
 231        (setq name (subseq string index))))
 232     ;; Canonalize symbol name and package
 233     (setq name (if (equal package "JS")
 234                    (setq name (unescape name))
 235                    (setq name (string-upcase-noescaped name))))
 236     (setq package (find-package package))
 237     (if (or internalp
 238             (eq package (find-package "KEYWORD"))
 239             (eq package (find-package "JS")))
 240         (intern name package)
 241         (multiple-value-bind (symbol external)
 242             (find-symbol name package)
 243           (if (eq external :external)
 244               symbol
 245               (error "The symbol `~S' is not external in the package ~S." name package))))))
 246
 247 (defun read-integer (string)
 248   (let ((sign 1)
 249         (number nil)
 250         (size (length string)))
 251     (dotimes (i size)
 252       (let ((elt (char string i)))
 253         (cond
 254           ((digit-char-p elt)
 255            (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
 256           ((zerop i)
 257            (case elt
 258              (#\+ nil)
 259              (#\- (setq sign -1))
 260              (t (return-from read-integer))))
 261           ((and (= i (1- size)) (char= elt #\.)) nil)
 262           (t (return-from read-integer)))))
 263     (and number (* sign number))))
 264
 265 (defun read-float (string)
 266   (block nil
 267     (let ((sign 1)
 268           (integer-part nil)
 269           (fractional-part nil)
 270           (number 0)
 271           (divisor 1)
 272           (exponent-sign 1)
 273           (exponent 0)
 274           (size (length string))
 275           (index 0))
 276       (when (zerop size) (return))
 277       ;; Optional sign
 278       (case (char string index)
 279         (#\+ (incf index))
 280         (#\- (setq sign -1)
 281              (incf index)))
 282       (unless (< index size) (return))
 283       ;; Optional integer part
 284       (awhen (digit-char-p (char string index))
 285         (setq integer-part t)
 286         (while (and (< index size)
 287                     (setq it (digit-char-p (char string index))))
 288           (setq number (+ (* number 10) it))
 289           (incf index)))
 290       (unless (< index size) (return))
 291       ;; Decimal point is mandatory if there's no integer part
 292       (unless (or integer-part (char= #\. (char string index))) (return))
 293       ;; Optional fractional part
 294       (when (char= #\. (char string index))
 295         (incf index)
 296         (unless (< index size) (return))
 297         (awhen (digit-char-p (char string index))
 298           (setq fractional-part t)
 299           (while (and (< index size)
 300                       (setq it (digit-char-p (char string index))))
 301             (setq number (+ (* number 10) it))
 302             (setq divisor (* divisor 10))
 303             (incf index))))
 304       ;; Either left or right part of the dot must be present
 305       (unless (or integer-part fractional-part) (return))
 306       ;; Exponent is mandatory if there is no fractional part
 307       (when (and (= index size) (not fractional-part)) (return))
 308       ;; Optional exponent part
 309       (when (< index size)
 310         ;; Exponent-marker
 311         (unless (member (string-upcase (string (char string index)))
 312                         '("E" "S" "F" "D" "L"))
 313           (return))
 314         (incf index)
 315         (unless (< index size) (return))
 316         ;; Optional exponent sign
 317         (case (char string index)
 318           (#\+ (incf index))
 319           (#\- (setq exponent-sign -1)
 320                (incf index)))
 321         (unless (< index size) (return))
 322         ;; Exponent digits
 323         (let ((value (digit-char-p (char string index))))
 324           (unless value (return))
 325           (while (and (< index size)
 326                       (setq value (digit-char-p (char string index))))
 327             (setq exponent (+ (* exponent 10) value))
 328             (incf index))))
 329       (unless (= index size) (return))
 330       ;; Everything went ok, we have a float
 331       ;; XXX: Use FLOAT when implemented.
 332       (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor))))
 333
 334 (defun !parse-integer (string junk-allow)
 335   (block nil
 336     (let ((value 0)
 337           (index 0)
 338           (size (length string))
 339           (sign 1))
 340       ;; Leading whitespace
 341       (while (and (< index size)
 342                   (whitespacep (char string index)))
 343         (incf index))
 344       (unless (< index size) (return (values nil 0)))
 345       ;; Optional sign
 346       (case (char string 0)
 347         (#\+ (incf index))
 348         (#\- (setq sign -1)
 349              (incf index)))
 350       ;; First digit
 351       (unless (and (< index size)
 352                    (setq value (digit-char-p (char string index))))
 353         (return (values nil index)))
 354       (incf index)
 355       ;; Other digits
 356       (while (< index size)
 357         (let ((digit (digit-char-p (char string index))))
 358           (unless digit (return))
 359           (setq value (+ (* value 10) digit))
 360           (incf index)))
 361       ;; Trailing whitespace
 362       (do ((i index (1+ i)))
 363           ((or (= i size) (not (whitespacep (char string i))))
 364            (and (= i size) (setq index i))))
 365       (if (or junk-allow
 366               (= index size))
 367           (values (* sign value) index)
 368           (values nil index)))))
 369
 370 #+jscl
 371 (defun parse-integer (string &key junk-allowed)
 372   (multiple-value-bind (num index)
 373       (!parse-integer string junk-allowed)
 374     (if num
 375         (values num index)
 376         (error "Junk detected."))))
 377
 378
 379 (defun interpret-token (string)
 380   (or (read-integer string)
 381       (read-float string)
 382       (read-symbol string)))
 383
 384 (defun ls-read (stream  &optional (eof-error-p t) eof-value)
 385   (skip-whitespaces-and-comments stream)
 386   (let ((ch (%peek-char stream)))
 387     (cond
 388       ((or (null ch) (char= ch #\)))
 389        (if eof-error-p
 390            (error "End of file")
 391            eof-value))
 392       ((char= ch #\()
 393        (%read-char stream)
 394        (%read-list stream))
 395       ((char= ch #\')
 396        (%read-char stream)
 397        (list 'quote (ls-read stream)))
 398       ((char= ch #\`)
 399        (%read-char stream)
 400        (list 'backquote (ls-read stream)))
 401       ((char= ch #\")
 402        (%read-char stream)
 403        (read-string stream))
 404       ((char= ch #\,)
 405        (%read-char stream)
 406        (if (eql (%peek-char stream) #\@)
 407            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 408            (list 'unquote (ls-read stream))))
 409       ((char= ch #\#)
 410        (read-sharp stream))
 411       (t
 412        (let ((string (read-escaped-until stream #'terminalp)))
 413          (interpret-token string))))))
 414
 415 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
 416   (ls-read (make-string-stream string) eof-error-p eof-value))
 417
 418 #+jscl
 419 (defun read-from-string (string &optional (eof-errorp t) eof-value)
 420   (ls-read-from-string string eof-errorp eof-value))