(read-from-string string) => form
Purpose
Read a datum from a string.
Read-from-string is like read but
it takes its input from a string instead of a port.
It returns a pair containing the expression read in case
of success. If there are any trailing characters after
the extracted datum, the trailing string is placed in
the cdr part of the returned pair. If the trailing string
is empty, the cdr part is set to ().
When an empty string or a string consisting of a comment
exclusively is passed to read-from-string,
it returns ().
In case of an error, a string explaining the cause of the
error is returned.
Arguments
Example
(read-from-string " (this \"is\" #(a) (list)) ; comment")
=> ((this "is" #(a) (list)))
(read-from-string " (this \"is\" #(a) (list)) comment")
=> ((this "is" #(a) (list)) . " comment")
(read-from-string ")")
=> "unexpected closing parenthesis"
(define separator?
(let ((separators (list #\# #\' #\( #\) #\, #\; #\`
#\space
(integer->char 9)
(integer->char 10)
(integer->char 12)
(integer->char 13))))
(lambda (c)
(and (memv c separators) #t))))
(define (skip-blanks s)
(cond ((null? s) '())
((char-whitespace? (car s))
(skip-blanks (cdr s)))
(else s)))
(define (digit-value c)
(- (char->integer c)
(char->integer #\0)))
(define (read-number s)
(letrec
((read-n
(lambda (s n)
(cond ((null? s) (cons n s))
((char-numeric? (car s))
(read-n (cdr s)
(+ (digit-value (car s)) (* 10 n))))
(else (cons n s))))))
(read-n s 0)))
(define (char-symbolic? c)
(or (char-alphabetic? c)
(and (memv c '(#\+ #\- #\. #\* #\/ #\< #\= #\> #\!
#\? #\: #\$ #\% #\_ #\& #\~ #\^))
#t)))
(define (read-symbol s)
(letrec
((rlst->sym
(lambda (s)
(string->symbol
(list->string (reverse s)))))
(read-sym
(lambda (s sym)
(cond ((null? s) (cons (rlst->sym sym) s))
((char-symbolic? (car s))
(read-sym (cdr s) (cons (car s) sym)))
(else (cons (rlst->sym sym) s))))))
(read-sym s '())))
(define (read-number-or-symbol s)
(let ((s0 (car s))
(s1 (if (pair? (cdr s)) (cadr s) #\x)))
(if (char-numeric? s1)
(if (char=? #\- s0)
(let ((r (read-number (cdr s))))
(cons (- (car r)) (cdr r)))
(read-number (cdr s)))
(read-symbol s))))
(define (read-string s)
(letrec
((rlst->str
(lambda (s)
(list->string (reverse s))))
(read-str
(lambda (s t q)
(cond ((null? s)
"unterminated string literal")
((and (not q) (char=? #\" (car s)))
(cons (rlst->str t) (cdr s)))
((char=? #\\ (car s))
(read-str (cdr s)
(cons (car s) t) #t))
(else
(read-str (cdr s)
(cons (car s) t) #f))))))
(read-str (cdr s) '() #f)))
(define (read-character s)
(cond ((null? (cddr s)) "bad char literal")
((null? (cdddr s)) (cons (caddr s) (cdddr s)))
((separator? (cadddr s)) (cons (caddr s) (cdddr s)))
(else (let ((r (read-symbol (cddr s))))
(case (car r)
((space) (cons #\space (cdr r)))
((newline) (cons #\newline (cdr r)))
(else "bad character name"))))))
(define (read-dotted-cdr s lst)
(let ((s (skip-blanks (cdr s))))
(if (or (null? s) (char=? #\) (car s))
"missing cdr part in dotted pair")
(let ((x (char-list->datum s)))
(if (pair? x)
(let ((s (skip-blanks (cdr x))))
(if (or (null? s) (not (char=? #\) (car s))))
"missing closing parenthesis in dotted list"
(cons (append (reverse lst) (car x)) (cdr s))))
x)))))
(define (read-pair s)
(letrec
((read-list
(lambda (s lst)
(let ((s (if (and (pair? s) (char-whitespace? (car s)))
(skip-blanks (cdr s))
s)))
(cond ((null? s)
"missing closing parenthesis")
((char=? #\) (car s))
(cons (reverse lst) (cdr s)))
((and (char=? #\. (car s))
(pair? (cdr s))
(separator? (cadr s)))
(read-dotted-cdr s lst))
(else (let ((x (char-list->datum s)))
(if (pair? x)
(read-list (cdr x)
(cons (car x) lst))))))))))
(read-list (cdr s) '())))
(define (read-hash s)
(let ((s1 (if (pair? (cdr s)) (cadr s) #\<)))
(case s1
((#\t) (cons #t (cddr s)))
((#\f) (cons #f (cddr s)))
((#\\) (read-character s))
((#\() (let ((x (read-pair (cdr s))))
(if (pair? x)
(if (list? (car x))
(cons (list->vector (car x)) (cdr x))
"bad vector syntax")
x)))
(else "bad # syntax"))))
(define (read-quote s q)
(let ((x (char-list->datum (cdr s))))
(if (pair? x)
(cons (list q (car x)) (cdr x))
x)))
(define (char-list->datum s)
(let ((s (skip-blanks s)))
(cond ((null? s)
'())
((char=? #\; (car s))
'())
((char-symbolic? (car s))
(read-symbol s))
((char-numeric? (car s))
(read-number s))
((or (char=? #\+ (car s))
(char=? #\- (car s)))
(read-number-or-symbol s))
((char=? #\" (car s))
(read-string s))
((char=? #\# (car s))
(read-hash s))
((char=? #\' (car s))
(read-quote s 'quote))
((char=? #\` (car s))
(read-quote s 'quasiquote))
((char=? #\, (car s))
(read-quote s 'unquote))
((char=? #\( (car s))
(read-pair s))
((char=? #\) (car s))
"unexpected closing parenthesis")
(else (wrong "can't parse this"
(list->string s))))))
(define (string->datum s)
(char-list->datum (string->list s)))
(define (read-from-string s)
(let ((r (string->datum s)))
(if (pair? r)
(if (null? (cdr r))
(list (car r))
(let ((r2 (char-list->datum (cdr r))))
(if (null? r2)
(list (car r))
(cons (car r) (list->string (cdr r))))))
r)))
Copyright (C) 2007 Nils M Holm <nmh @ t3x . org>