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