Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

added simple number parsing

  • Loading branch information...
commit f4f15d5a3393be9d979458d3cc94b1d0ebd0128b 1 parent e5e52e5
Mike Aizatsky authored
9 parser-lib-tests.scm
View
@@ -108,6 +108,15 @@
c <- any-char
return c)))
(p "abc" 0)))
+ (test #f (let ((p (parser c1 <- any-char
+ c2 <- (char "a")
+ return (string-append c1 c2))))
+ (p "abc" 0)))
+ (test #f (let ((p (parser c1 <- any-char
+ c2 <- (char "b")
+ c3 <- (char "a")
+ return (string-append c1 c2))))
+ (p "abc" 0)))
)
(test-exit)
8 parser-lib.scm
View
@@ -111,7 +111,9 @@
(tail-parser (parser . tail))
(head-pos (cdr head-result))
(tail-result (tail-parser s head-pos)))
- (cons (car tail-result) (cdr tail-result)))
+ (if tail-result
+ (cons (car tail-result) (cdr tail-result))
+ #f))
#f))))
((parser return e) (lambda (s p) (cons e p)))
((parser head-parser . tail)
@@ -122,7 +124,9 @@
(tail-parser (parser . tail))
(head-pos (cdr head-result))
(tail-result (tail-parser s head-pos)))
- (cons (car tail-result) (cdr tail-result)))
+ (if tail-result
+ (cons (car tail-result) (cdr tail-result))
+ #f))
#f))))
))
9 scheme-parser-tests.scm
View
@@ -24,6 +24,15 @@
(test-group "literal"
(test '((literal string . "abc") . 5) (literal "\"abc\"" 0))
(test '((literal quote id . "abc") . 4) (literal "'abc" 0))
+ (test '((literal quote id . "abc") . 11) (literal "(quote abc)" 0))
+ (test '((literal quote id . "abc") . 14) (literal "(quote abc)" 0))
+)
+
+(test-group "number"
+ (test '((number . 123) . 3) (number "123" 0))
+ (test '((number . 64) . 5) (number "#o100" 0))
+ (test '((number . 4) . 5) (number "#b100" 0))
+ (test '((number . 256) . 5) (number "#x100" 0))
)
(test-exit)
134 scheme-parser.scm
View
@@ -1,4 +1,5 @@
(require-extension syntax-case)
+(require-extension srfi-1)
(load "parser-lib.scm")
(import parser-lib)
@@ -40,10 +41,28 @@
(define (!whitespace? c)
(not (whitespace? c)))
+(define (digitr? r)
+ (lambda (c)
+ (case r
+ ((2) (and (char<=? #\0 c) (char>=? #\1 c)))
+ ((8) (and (char<=? #\0 c) (char>=? #\7 c)))
+ ((10) (and (char<=? #\0 c) (char>=? #\9 c)))
+ ((16) (or (and (char<=? #\0 c) (char>=? #\9 c))
+ (and (char<=? #\a c) (char>=? #\f c))))
+ (else #f))))
+
+(define (hash? c)
+ (char=? #\# c))
+
+(define (token s)
+ (parser t <- (matches s)
+ (while-char whitespace?)
+ return t))
+
(define peculiar-identifier
- (choice (matches "+")
- (matches "-")
- (matches "...")))
+ (choice (token "+")
+ (token "-")
+ (token "...")))
(define identifier
(parser i <- (choice (str-seq (if-char initial?) (while-char subsequent?))
@@ -61,13 +80,111 @@
(define string
(parser (matches "\"")
s <- (while string-element)
- (matches "\"")
+ (token "\"")
return (cons 'string (apply string-append s))))
(define boolean fail) ;; TODO
-(define number fail) ;; TODO
(define character fail) ;; TODO
+(define (digit r)
+ (parser c <- (if-char (digitr? r))
+ return (- (char->integer (string-ref c 0)) (char->integer #\0))))
+
+(define sign
+ (choice (parser (token "+")
+ return 1)
+ (parser (token "-")
+ return -1)
+ (parser nop
+ return 1)))
+
+(define exponent-marker
+ (choice (token "e")
+ (token "s")
+ (token "f")
+ (token "d")
+ (token "l")))
+
+(define suffix
+ (choice (seq exponent-marker sign (while (digit 10)))
+ nop))
+
+(define (decimal r)
+ (case r
+ ((10) (choice (seq (uinteger 10) suffix)
+ (seq (token ".") (while1 (digit 10)) (while-char hash?) suffix)
+ (seq (while1 (digit 10)) (token ".") (while (digit 10))
+ (while-char hash?) suffix)
+ (seq (while1 (digit 10)) (while1-char hash?) (token ".")
+ (while-char hash?) suffix)))
+ (else fail)))
+
+
+(define (uinteger r)
+ (parser d <- (while1 (digit r))
+ h <- (while-char hash?)
+ return (let ((i1 (fold (lambda (d1 d2) (+ (* d2 r) d1)) 0 d))
+ (h (expt r (string-length h))))
+ (* i1 h))))
+
+(define (ureal r)
+ (choice (seq (uinteger r) (token "/") (uinteger r))
+ (uinteger r)
+ (decimal r)))
+
+(define (real r)
+ (parser s <- sign
+ u <- (ureal r)
+ return (* s u)))
+
+(define (complex r)
+ (choice (seq (real r) (token "@") (real r))
+ (seq (real r) (token "+") (ureal r) (token "i"))
+ (seq (real r) (token "-") (ureal r) (token "i"))
+ (seq (real r) (token "+") (token "i"))
+ (seq (real r) (token "-") (token "i"))
+ (seq (token "+") (ureal r) (token "i"))
+ (seq (token "-") (ureal r) (token "i"))
+ (seq (token "+") (token "i"))
+ (seq (token "-") (token "i"))
+ (real r)))
+
+(define exactness
+ (choice (parser (matches "#i")
+ return (lambda (n) (exact->inexact n)))
+ (parser (matches "#e")
+ return (lambda (n) (inexact->exact n)))
+ (parser nop
+ return (lambda (n) n))))
+
+(define (radix r)
+ (case r
+ ((2) (matches "#b"))
+ ((8) (matches "#o"))
+ ((16) (matches "#x"))
+ ((10) (choice (matches "#d")
+ nop))
+ (else fail)))
+
+(define (prefix r)
+ (choice (parser r <- (radix r)
+ e <- exactness
+ return (cons e r))
+ (parser e <- exactness
+ r <- (radix r)
+ return (cons e r))))
+
+(define (num r)
+ (parser p <- (prefix r)
+ n <- (complex r)
+ return (cons 'number ((car p) n))))
+
+(define number
+ (choice (num 2)
+ (num 8)
+ (num 10)
+ (num 16)))
+
;; External representations
(define symbol identifier)
@@ -90,9 +207,10 @@
(choice (parser (matches "'")
d <- datum
return (cons 'quote d))
- (seq (matches "(quote")
- datum
- (matches ")"))))
+ (parser (token "(quote")
+ d <- datum
+ (token ")")
+ return (cons 'quote d))))
(define self-evaluating
(choice boolean
number
Please sign in to comment.
Something went wrong with that request. Please try again.