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-float (string)
 167   (block nil
 168     (let ((sign 1)
 169           (integer-part nil)
 170           (fractional-part nil)
 171           (number 0)
 172           (divisor 1)
 173           (exponent-sign 1)
 174           (exponent 0)
 175           (size (length string))
 176           (index 0))
 177       (when (zerop size) (return))
 178       ;; Optional sign
 179       (case (char string index)
 180         (#\+ (incf index))
 181         (#\- (setq sign -1)
 182              (incf index)))
 183       (unless (< index size) (return))
 184       ;; Optional integer part
 185       (let ((value (digit-char-p (char string index))))
 186         (when value
 187           (setq integer-part t)
 188           (while (and (< index size)
 189                       (setq value (digit-char-p (char string index))))
 190             (setq number (+ (* number 10) value))
 191             (incf index))))
 192       (unless (< index size) (return))
 193       ;; Decimal point is mandatory if there's no integer part
 194       (unless (or integer-part (char= #\. (char string index))) (return))
 195       ;; Optional fractional part
 196       (when (char= #\. (char string index))
 197         (incf index)
 198         (unless (< index size) (return))
 199         (let ((value (digit-char-p (char string index))))
 200           (when value
 201             (setq fractional-part t)
 202             (while (and (< index size)
 203                         (setq value (digit-char-p (char string index))))
 204               (setq number (+ (* number 10) value))
 205               (setq divisor (* divisor 10))
 206               (incf index)))))
 207       ;; Either left or right part of the dot must be present
 208       (unless (or integer-part fractional-part) (return))
 209       ;; Exponent is mandatory if there is no fractional part
 210       (when (and (= index size) (not fractional-part)) (return))
 211       ;; Optional exponent part
 212       (when (< index size)
 213         ;; Exponent-marker
 214         (unless (member (string-upcase (string (char string index)))
 215                         '("E" "S" "F" "D" "L"))
 216           (return))
 217         (incf index)
 218         (unless (< index size) (return))
 219         ;; Optional exponent sign
 220         (case (char string index)
 221           (#\+ (incf index))
 222           (#\- (setq exponent-sign -1)
 223                (incf index)))
 224         (unless (< index size) (return))
 225         ;; Exponent digits
 226         (let ((value (digit-char-p (char string index))))
 227           (unless value (return))
 228           (while (and (< index size)
 229                       (setq value (digit-char-p (char string index))))
 230             (setq exponent (+ (* exponent 10) value))
 231             (incf index))))
 232       (unless (= index size) (return))
 233       ;; Everything went ok, we have a float
 234       (/ (* sign (expt 10 (* exponent-sign exponent)) number) divisor))))
 235
 236
 237 (defun !parse-integer (string junk-allow)
 238   (block nil
 239     (let ((value 0)
 240           (index 0)
 241           (size (length string))
 242           (sign 1))
 243       ;; Leading whitespace
 244       (while (and (< index size)
 245                   (whitespacep (char string index)))
 246         (incf index))
 247       (unless (< index size) (return (values nil 0)))
 248       ;; Optional sign
 249       (case (char string 0)
 250         (#\+ (incf index))
 251         (#\- (setq sign -1)
 252              (incf index)))
 253       ;; First digit
 254       (unless (and (< index size)
 255                    (setq value (digit-char-p (char string index))))
 256         (return (values nil index)))
 257       (incf index)
 258       ;; Other digits
 259       (while (< index size)
 260         (let ((digit (digit-char-p (char string index))))
 261           (unless digit (return))
 262           (setq value (+ (* value 10) digit))
 263           (incf index)))
 264       ;; Trailing whitespace
 265       (do ((i index (1+ i)))
 266           ((or (= i size) (not (whitespacep (char string i))))
 267            (and (= i size) (setq index i))))
 268       (if (or junk-allow
 269               (= index size))
 270           (values (* sign value) index)
 271           (values nil index)))))
 272
 273 #+jscl
 274 (defun parse-integer (string &key junk-allowed)
 275   (multiple-value-bind (num index)
 276       (!parse-integer string junk-allowed)
 277     (when num
 278       (values num index)
 279       (error "junk detected."))))
 280
 281 (defvar *eof* (gensym))
 282 (defun ls-read-1 (stream)
 283   (skip-whitespaces-and-comments stream)
 284   (let ((ch (%peek-char stream)))
 285     (cond
 286       ((or (null ch) (char= ch #\)))
 287        *eof*)
 288       ((char= ch #\()
 289        (%read-char stream)
 290        (%read-list stream))
 291       ((char= ch #\')
 292        (%read-char stream)
 293        (list 'quote (ls-read-1 stream)))
 294       ((char= ch #\`)
 295        (%read-char stream)
 296        (list 'backquote (ls-read-1 stream)))
 297       ((char= ch #\")
 298        (%read-char stream)
 299        (read-string stream))
 300       ((char= ch #\,)
 301        (%read-char stream)
 302        (if (eql (%peek-char stream) #\@)
 303            (progn (%read-char stream) (list 'unquote-splicing (ls-read-1 stream)))
 304            (list 'unquote (ls-read-1 stream))))
 305       ((char= ch #\#)
 306        (read-sharp stream))
 307       (t
 308        (let ((string (read-until stream #'terminalp)))
 309          (or (values (!parse-integer string nil))
 310              (read-float string)
 311              (read-symbol string)))))))
 312
 313 (defun ls-read (stream &optional (eof-error-p t) eof-value)
 314   (let ((x (ls-read-1 stream)))
 315     (if (eq x *eof*)
 316         (if eof-error-p (error "EOF") eof-value)
 317         x)))
 318
 319 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
 320   (ls-read (make-string-stream string) eof-error-p eof-value))