src/read.lisp

   1 ;;; read.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; This program 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 ;; This program 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 this program.  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)))
  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 skip-whitespaces-and-comments (stream)
  61   (let (ch)
  62     (skip-whitespaces stream)
  63     (setq ch (%peek-char stream))
  64     (while (and ch (char= ch #\;))
  65       (read-until stream (lambda (x) (char= x #\newline)))
  66       (skip-whitespaces stream)
  67       (setq ch (%peek-char stream)))))
  68
  69 (defun %read-list (stream)
  70   (skip-whitespaces-and-comments stream)
  71   (let ((ch (%peek-char stream)))
  72     (cond
  73       ((null ch)
  74        (error "Unspected EOF"))
  75       ((char= ch #\))
  76        (%read-char stream)
  77        nil)
  78       ((char= ch #\.)
  79        (%read-char stream)
  80        (prog1 (ls-read-1 stream)
  81          (skip-whitespaces-and-comments stream)
  82          (unless (char= (%read-char stream) #\))
  83            (error "')' was expected."))))
  84       (t
  85        (cons (ls-read-1 stream) (%read-list stream))))))
  86
  87 (defun read-string (stream)
  88   (let ((string "")
  89         (ch nil))
  90     (setq ch (%read-char stream))
  91     (while (not (eql ch #\"))
  92       (when (null ch)
  93         (error "Unexpected EOF"))
  94       (when (eql ch #\\)
  95         (setq ch (%read-char stream)))
  96       (setq string (concat string (string ch)))
  97       (setq ch (%read-char stream)))
  98     string))
  99
 100 (defun read-sharp (stream)
 101   (%read-char stream)
 102   (ecase (%read-char stream)
 103     (#\'
 104      (list 'function (ls-read-1 stream)))
 105     (#\( (list-to-vector (%read-list stream)))
 106     (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
 107     (#\\
 108      (let ((cname
 109             (concat (string (%read-char stream))
 110                     (read-until stream #'terminalp))))
 111        (cond
 112          ((string= cname "space") (char-code #\space))
 113          ((string= cname "tab") (char-code #\tab))
 114          ((string= cname "newline") (char-code #\newline))
 115          (t (char-code (char cname 0))))))
 116     (#\+
 117      (let ((feature (read-until stream #'terminalp)))
 118        (cond
 119          ((string= feature "common-lisp")
 120           (ls-read-1 stream)              ;ignore
 121           (ls-read-1 stream))
 122          ((string= feature "jscl")
 123           (ls-read-1 stream))
 124          (t
 125           (error "Unknown reader form.")))))))
 126
 127 ;;; Parse a string of the form NAME, PACKAGE:NAME or
 128 ;;; PACKAGE::NAME and return the name. If the string is of the
 129 ;;; form 1) or 3), but the symbol does not exist, it will be created
 130 ;;; and interned in that package.
 131 (defun read-symbol (string)
 132   (let ((size (length string))
 133         package name internalp index)
 134     (setq index 0)
 135     (while (and (< index size)
 136                 (not (char= (char string index) #\:)))
 137       (incf index))
 138     (cond
 139       ;; No package prefix
 140       ((= index size)
 141        (setq name string)
 142        (setq package *package*)
 143        (setq internalp t))
 144       (t
 145        ;; Package prefix
 146        (if (zerop index)
 147            (setq package "KEYWORD")
 148            (setq package (string-upcase (subseq string 0 index))))
 149        (incf index)
 150        (when (char= (char string index) #\:)
 151          (setq internalp t)
 152          (incf index))
 153        (setq name (subseq string index))))
 154     ;; Canonalize symbol name and package
 155     (when (not (eq package "JS"))
 156       (setq name (string-upcase name)))
 157     (setq package (find-package package))
 158     ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
 159     ;; external symbol from PACKAGE.
 160     (if (or internalp
 161             (eq package (find-package "KEYWORD"))
 162             (eq package (find-package "JS")))
 163         (intern name package)
 164         (find-symbol name package))))
 165
 166 (defun read-integer (string)
 167   (let ((sign 1)
 168         (number nil)
 169         (size (length string)))
 170     (dotimes (i size)
 171       (let ((elt (char string i)))
 172         (cond
 173           ((digit-char-p elt)
 174            (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
 175           ((zerop i)
 176            (case elt
 177              (#\+ nil)
 178              (#\- (setq sign -1))
 179              (otherwise (return-from read-integer))))
 180           ((and (= i (1- size)) (char= elt #\.)) nil)
 181           (t (return-from read-integer)))))
 182     (and number (* sign number))))
 183
 184 (defun read-float (string)
 185   (block nil
 186     (let ((sign 1)
 187           (integer-part nil)
 188           (fractional-part nil)
 189           (number 0)
 190           (divisor 1)
 191           (exponent-sign 1)
 192           (exponent 0)
 193           (size (length string))
 194           (index 0))
 195       (when (zerop size) (return))
 196       ;; Optional sign
 197       (case (char string index)
 198         (#\+ (incf index))
 199         (#\- (setq sign -1)
 200              (incf index)))
 201       (unless (< index size) (return))
 202       ;; Optional integer part
 203       (awhen (digit-char-p (char string index))
 204         (setq integer-part t)
 205         (while (and (< index size)
 206                     (setq it (digit-char-p (char string index))))
 207           (setq number (+ (* number 10) it))
 208           (incf index)))
 209       (unless (< index size) (return))
 210       ;; Decimal point is mandatory if there's no integer part
 211       (unless (or integer-part (char= #\. (char string index))) (return))
 212       ;; Optional fractional part
 213       (when (char= #\. (char string index))
 214         (incf index)
 215         (unless (< index size) (return))
 216         (awhen (digit-char-p (char string index))
 217           (setq fractional-part t)
 218           (while (and (< index size)
 219                       (setq it (digit-char-p (char string index))))
 220             (setq number (+ (* number 10) it))
 221             (setq divisor (* divisor 10))
 222             (incf index))))
 223       ;; Either left or right part of the dot must be present
 224       (unless (or integer-part fractional-part) (return))
 225       ;; Exponent is mandatory if there is no fractional part
 226       (when (and (= index size) (not fractional-part)) (return))
 227       ;; Optional exponent part
 228       (when (< index size)
 229         ;; Exponent-marker
 230         (unless (member (string-upcase (string (char string index)))
 231                         '("E" "S" "F" "D" "L"))
 232           (return))
 233         (incf index)
 234         (unless (< index size) (return))
 235         ;; Optional exponent sign
 236         (case (char string index)
 237           (#\+ (incf index))
 238           (#\- (setq exponent-sign -1)
 239                (incf index)))
 240         (unless (< index size) (return))
 241         ;; Exponent digits
 242         (let ((value (digit-char-p (char string index))))
 243           (unless value (return))
 244           (while (and (< index size)
 245                       (setq value (digit-char-p (char string index))))
 246             (setq exponent (+ (* exponent 10) value))
 247             (incf index))))
 248       (unless (= index size) (return))
 249       ;; Everything went ok, we have a float
 250       ;; XXX: Use FLOAT when implemented.
 251       (/ (* sign (expt 10.0d0 (* exponent-sign exponent)) number) divisor))))
 252
 253
 254 (defun !parse-integer (string junk-allow)
 255   (block nil
 256     (let ((value 0)
 257           (index 0)
 258           (size (length string))
 259           (sign 1))
 260       ;; Leading whitespace
 261       (while (and (< index size)
 262                   (whitespacep (char string index)))
 263         (incf index))
 264       (unless (< index size) (return (values nil 0)))
 265       ;; Optional sign
 266       (case (char string 0)
 267         (#\+ (incf index))
 268         (#\- (setq sign -1)
 269              (incf index)))
 270       ;; First digit
 271       (unless (and (< index size)
 272                    (setq value (digit-char-p (char string index))))
 273         (return (values nil index)))
 274       (incf index)
 275       ;; Other digits
 276       (while (< index size)
 277         (let ((digit (digit-char-p (char string index))))
 278           (unless digit (return))
 279           (setq value (+ (* value 10) digit))
 280           (incf index)))
 281       ;; Trailing whitespace
 282       (do ((i index (1+ i)))
 283           ((or (= i size) (not (whitespacep (char string i))))
 284            (and (= i size) (setq index i))))
 285       (if (or junk-allow
 286               (= index size))
 287           (values (* sign value) index)
 288           (values nil index)))))
 289
 290 #+jscl
 291 (defun parse-integer (string &key junk-allowed)
 292   (multiple-value-bind (num index)
 293       (!parse-integer string junk-allowed)
 294     (when num
 295       (values num index)
 296       (error "junk detected."))))
 297
 298 (defvar *eof* (gensym))
 299 (defun ls-read-1 (stream)
 300   (skip-whitespaces-and-comments stream)
 301   (let ((ch (%peek-char stream)))
 302     (cond
 303       ((or (null ch) (char= ch #\)))
 304        *eof*)
 305       ((char= ch #\()
 306        (%read-char stream)
 307        (%read-list stream))
 308       ((char= ch #\')
 309        (%read-char stream)
 310        (list 'quote (ls-read-1 stream)))
 311       ((char= ch #\`)
 312        (%read-char stream)
 313        (list 'backquote (ls-read-1 stream)))
 314       ((char= ch #\")
 315        (%read-char stream)
 316        (read-string stream))
 317       ((char= ch #\,)
 318        (%read-char stream)
 319        (if (eql (%peek-char stream) #\@)
 320            (progn (%read-char stream) (list 'unquote-splicing (ls-read-1 stream)))
 321            (list 'unquote (ls-read-1 stream))))
 322       ((char= ch #\#)
 323        (read-sharp stream))
 324       (t
 325        (let ((string (read-until stream #'terminalp)))
 326          (or (read-integer string)
 327              (read-float string)
 328              (read-symbol string)))))))
 329
 330 (defun ls-read (stream &optional (eof-error-p t) eof-value)
 331   (let ((x (ls-read-1 stream)))
 332     (if (eq x *eof*)
 333         (if eof-error-p (error "EOF") eof-value)
 334         x)))
 335
 336 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
 337   (ls-read (make-string-stream string) eof-error-p eof-value))
 338
 339 #+jscl
 340 (defun read-from-string (string &optional (eof-errorp t) eof-value)
 341   (ls-read-from-string string eof-errorp eof-value))