binary number

binnum.scm

; positive binary number
; https://gist.github.com/yamasushi/bb2728ca917c677eea1b6aa07f180358
; Compilers 2nd ed. ex. 5.4.3 (p. 337)

; B -> B1 0 { B.syn = 2 * B1.syn }
;    | B1 1 { B.syn = 2 * B1.syn + 1}
;    | 1 {B.syn = 1}

; B -> 1 {R.inh = 1} R {B.syn = R.syn}
; R -> 0 {R1.inh = R.inh * 2} R1 {R.syn = R1.syn}
; R -> 1 {R1.inh = R.inh * 2 + 1} R1 {R.syn = R1.syn}
; R -> ε {R.syn = R.inh}

(define (test str)
  (let-values ( [ (n xs) (B (undefined) (string->list str) ) ] ) 
    (format #t "result=~d ( ~b ) xs=~s~%" n n xs)
  ) )

; B -> 1 {R.inh = 1} R {B.syn = R.syn}
(define (B inh xs)
;  (format #t "B : inh=~s xs=~s~%" inh xs)
  (if (null? xs)
    (error "B: xs=" xs)
    ( (.$
      R
      (^[ _ xs_ ] (values 1 xs_) )
      (cut match-terminal #\1 <> <>)
    ) inh xs) ) )

; R -> 0 {R1.inh = R.inh * 2} R1 {R.syn = R1.syn}
; R -> 1 {R1.inh = R.inh * 2 + 1} R1 {R.syn = R1.syn}
; R -> ε {R.syn = R.inh}
(define (R inh xs)
;  (format #t "R : inh=~s xs=~s~%" inh xs)
  (if (null? xs)
    (values inh xs)
    (case (car xs)
      {(#\0)
        ( (.$
            R
            (^[syn_ xs_] (values (* 2 inh) xs_))
            (cut match-terminal #\0 <> <>) ) inh xs ) }
      {(#\1)
        ( (.$
            R
            (^[syn_ xs_] (values (+ 1 (* 2 inh)) xs_))
            (cut match-terminal #\1 <> <>) ) inh xs ) }
      {else (values inh xs)} ) ) )

(define (match-terminal t inh xs)
;  (format #t "match-terminal(t=~s) : inh=~s xs=~s~%" t inh xs)
  (if (null? xs)
  	(error "syntax error xs=" xs)
	  (if (eqv? t (car xs))
	  	(values inh (cdr xs))
		  (error "syntax error xs=" xs) ) ) )