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 stream)
  81          (skip-whitespaces-and-comments stream)
  82          (unless (char= (%read-char stream) #\))
  83            (error "')' was expected."))))
  84       (t
  85        (cons (ls-read 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 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 stream)              ;ignore
 121           (ls-read stream))
 122          ((string= feature "ecmalisp")
 123           (ls-read 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
 167 (defun !parse-integer (string junk-allow)
 168   (block nil
 169     (let ((value 0)
 170           (index 0)
 171           (size (length string))
 172           (sign 1))
 173       ;; Leading whitespace
 174       (while (and (< index size)
 175                   (whitespacep (char string index)))
 176         (incf index))
 177       (unless (< index size) (return (values nil 0)))
 178       ;; Optional sign
 179       (case (char string 0)
 180         (#\+ (incf index))
 181         (#\- (setq sign -1)
 182              (incf index)))
 183       ;; First digit
 184       (unless (and (< index size)
 185                    (setq value (digit-char-p (char string index))))
 186         (return (values nil index)))
 187       (incf index)
 188       ;; Other digits
 189       (while (< index size)
 190         (let ((digit (digit-char-p (char string index))))
 191           (unless digit (return))
 192           (setq value (+ (* value 10) digit))
 193           (incf index)))
 194       ;; Trailing whitespace
 195       (do ((i index (1+ i)))
 196           ((or (= i size) (not (whitespacep (char string i))))
 197            (and (= i size) (setq index i))))
 198       (if (or junk-allow
 199               (= index size))
 200           (values (* sign value) index)
 201           (values nil index)))))
 202
 203 #+ecmalisp
 204 (defun parse-integer (string &key junk-allowed)
 205   (multiple-value-bind (num index)
 206       (!parse-integer string junk-allowed)
 207     (when num
 208       (values num index)
 209       (error "junk detected."))))
 210
 211 (defvar *eof* (gensym))
 212 (defun ls-read (stream)
 213   (skip-whitespaces-and-comments stream)
 214   (let ((ch (%peek-char stream)))
 215     (cond
 216       ((or (null ch) (char= ch #\)))
 217        *eof*)
 218       ((char= ch #\()
 219        (%read-char stream)
 220        (%read-list stream))
 221       ((char= ch #\')
 222        (%read-char stream)
 223        (list 'quote (ls-read stream)))
 224       ((char= ch #\`)
 225        (%read-char stream)
 226        (list 'backquote (ls-read stream)))
 227       ((char= ch #\")
 228        (%read-char stream)
 229        (read-string stream))
 230       ((char= ch #\,)
 231        (%read-char stream)
 232        (if (eql (%peek-char stream) #\@)
 233            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 234            (list 'unquote (ls-read stream))))
 235       ((char= ch #\#)
 236        (read-sharp stream))
 237       (t
 238        (let ((string (read-until stream #'terminalp)))
 239          (or (values (!parse-integer string nil))
 240              (read-symbol string)))))))
 241
 242 (defun ls-read-from-string (string)
 243   (ls-read (make-string-stream string)))