;; ---- 1996 Scheme Workshop -- Compiling Scheme

;; -- scan-numlist.ss

;;; This file contains the definition for a scanner and a parser for a
;;; simple language of lists of positive binary or decimal numbers.

;; --------------------------------------------------
;; Lexical Structure (regular grammar)

;; <radix10>	--> <empty> | #d
;; <radix2>	--> #b

;; <digit2>	--> 0 | 1
;; <digit10>	--> <digit>
;; <digit>	--> 0 | 1 | ... | 9

;; <number>	--> <number2> | <number10>
;; <number2>	--> <radix2><digit2>+
;; <number10>	--> <radix10><digit10>+

;; <token>	--> <number> | `(' | `)'
;; <whitespace>	--> tab | space | newline


;; Datum Structure (context-free grammar)

;; <datum>	--> <number> | <list>
;; <list>	--> `(' <datum>* `)'
;; --------------------------------------------------

(define scan
  (let ([digit->value
	  (let ((zero (char->integer #\0)))
	    (lambda (c)
	      (- (char->integer c) zero)))]
	[scan-error
	  (lambda (c) (error 'scan "Unexpected character ~s" c))]
	[whitespace? (lambda (ch) (memv ch '(#\space #\newline #\tab)))]
	[digit? (lambda (ch) (<= (char->integer #\0)
			       (char->integer ch)
			       (char->integer #\9)))]
	[binary-digit? (lambda (ch)
			 (or (eqv? #\0 ch) (eqv? #\1 ch)))]
	[delimeter?
	  (lambda (ch)
	    (or (eof-object? ch)
		(memv ch
		  '(#\space #\newline #\tab #\( #\) ))))])
    (letrec
      ([s0
	 (lambda (ip)
	   (let ([c (read-char ip)])
	     (cond
	       ((whitespace? c) (s0 ip))
	       ((eof-object? c) '(eof))
	       ((eqv? #\( c) '(lparen))
	       ((eqv? #\) c) '(rparen))
	       ((eqv? #\# c) (s-hash ip))
	       ((digit? c) (s-decimal (digit->value c) ip))
	       (else (scan-error c)))))]
       [s-hash
	 (lambda (ip)
	   (let ([c (read-char ip)])
	     (cond
	       ((eqv? #\b c) (s-start-binary ip))
	       ((eqv? #\d c) (s-start-decimal ip))
	       (else (scan-error c)))))]
       [s-start-binary
	 (lambda (ip)
	   (let ([c (read-char ip)])
	     (cond
	       [(binary-digit? c) (s-binary (digit->value c) ip)]
	       [else (scan-error c)])))]
       [s-start-decimal
	 (lambda (ip)
	   (let ([c (read-char ip)])
	     (cond
	       [(digit? c) (s-decimal (digit->value c) ip)]
	       [else (scan-error c)])))]
       [s-binary
	 (lambda (acc ip)
	   (let ([c (peek-char ip)])
	     (cond
	       [(delimeter? c)
		`(datum ,acc)]
	       [(binary-digit? c)
		(read-char ip)
		(s-binary (+ (* 2 acc) (digit->value c)) ip)]
	       [else
		 (scan-error c)])))]
       [s-decimal
	 (lambda (acc ip)
	   (let ([c (peek-char ip)])
	     (cond
	       [(delimeter? c)
		`(datum ,acc)]
	       [(digit? c)
		(read-char ip)
		(s-decimal (+ (* 10 acc) (digit->value c)) ip)]
	       [else
		 (scan-error c)])))])
      (lambda (ip)
	(s0 ip)))))

(define parse
  (let ((parse-error
	  (lambda (tok)
	    (error 'parse "unexpected token ~s" tok))))
    (letrec
      ((p-list
	 (lambda (ip)
	   (let ([tok (scan ip)])
	     (record-case tok
	       (rparen () '())
	       (else 
		 (let ((head (p tok ip)))
		   (cons head (p-list ip))))))))
       (p (lambda (tok ip)
	    (record-case tok
	      (datum (d) d)
	      (lparen () (p-list ip))
	      (rparen () (parse-error tok))
	      (eof    () (parse-error tok))
	      (else (error 'parse "sanity-check: Bad token ~s" tok))))))
      (lambda (ip)
	(p (scan ip) ip)))))