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