;;;; honu.scm


(module honu (read-honu)

(import scheme chicken)
(use extras ports data-structures)


(define-constant +operator-chars+
  '(#\- #\+ #\/ #\? #\: #\* #\% #\& #\! #\. #\~ #\_ #\| #\> #\< #\= #\^) )

(define (read-honu #!optional (port (current-input-port)) line-numbers lnwrap)
  (let ((ln (nth-value 0 (port-position port))))
    (define (lnw x)
      (if lnwrap (lnwrap x ln) x))
    (define (err msg . args)
      (apply 
       error 'read-honu
       (string-append msg (if line-numbers (conc " in line " ln) "")) args) )
    (define (opchar? c) (memq c +operator-chars+))
    (define (skip)
      (let ((c (peek-char port)))
	(cond ((eof-object? c) c)
	      ((char=? #\newline c)
	       (set! ln (fx+ ln 1)) 
	       (read-char port)
	       (skip) )
	      ((char-whitespace? c)
	       (read-char port)
	       (skip) )
	      ((char=? #\/ c)
	       (read-char port)
	       (let ((c (peek-char port)))
		 (case c
		   ((#\/) 
		    (read-line port)
		    (set! ln (fx+ ln 1))
		    (skip) )
		   ((#\*) (skip-comment) (skip))
		   (else
		    (if (opchar? c)
			(let ((s (read-token opchar? port)))
			  (string->symbol (string-append "/" s) ) )
			(lnw '/) ) ) ) ) )
	      (else #f) ) ) )
    (define (scan)
      (or (skip)
	  (let ((c (peek-char port)))
	    (case c
	      ((#!eof) (err "unexpected end of input"))
	      ((#\#)
	       (read-char port)
	       (let ((c (peek-char port)))
		 (case c
		   ((#\;)
		    (read-char port)
		    (let* ((x1 (scan))
			   (x2 (scan)) )
		      (if x1
			  x2
			  (scan) ) ) )
		   (else
		    (let ((t (read-token char-alphabetic? port)))
		      (cond ((string=? "hx" t) (scan))
			    ((string=? "sx" t) (read port)) 
			    (else (err "invalid escape syntax" (conc "#" t))) ) ) ) ) ) )
	      ((#\') 
	       (read-char port)
	       (let ((s (read-escaped (lambda (c) (char=? #\' c)))))
		 (if (zero? (string-length s))
		     (err "empty character literal")
		     (lnw (string-ref s 0) ) ) ) )
	      ((#\,) (read-char port) (lnw '|,|))
	      ((#\;) (read-char port) (lnw '|;|))
	      ((#\") (read-char port) (lnw (read-escaped (lambda (c) (char=? #\" c)))))
	      ((#\() (read-char port) (lnw (read-sequence '#%parens #\))))
	      ((#\[) (read-char port) (lnw (read-sequence '#%brackets #\])))
	      ((#\{) (read-char port) (lnw (read-sequence '#%braces #\})))
	      ((#\) #\] #\}) (err (sprintf "unexpected closing `~a'" c)))
	      (else
	       (cond ((char-numeric? c) (lnw (read-num)))
		     ((char-alphabetic? c) 
		      (lnw
		       (string->symbol
			(read-token
			 (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
			 port) ) ))
		     ((opchar? c) (lnw (string->symbol (read-token opchar? port))))
		     (else (err "invalid character" c)) ) ) ) ) ) )
    (define (read-num)
      (string->number
       (let ((e #f)
	     (d #f))
	 (let loop ((lst '()))
	   (let ((c (peek-char port)))
	     (case c 
	       ((#\e #\E)
		(cond (e (reverse-list->string lst))
		      (else
		       (set! e #t)
		       (read-char port)
		       (case (peek-char port)
			 ((#\+ #\-) (loop (cons (read-char port) lst)))
			 (else (reverse-list->string lst)) ) ) ) )
	       ((#!eof) (reverse-list->string lst))
	       ((#\.)
		(cond (d (reverse-list->string lst))
		      (else
		       (set! d #t)
		       (loop (cons (read-char port) lst)))))
	       (else
		(if (char-numeric? c)
		    (loop (cons (read-char port) lst))
		    (reverse-list->string lst) ) ) ) ) ) ) ) )
    (define (read-escaped pred)
      (##sys#read-from-string
       (string-append
	"\""
	(with-output-to-string
	  (lambda ()
	    (let loop ()
	      (let ((c (read-char port)))
		(cond ((eof-object? c) (err "unexpected end of character sequence"))
		      ((pred c))
		      ((char=? #\\ c)
		       (write-char #\\)
		       (write-char (read-char port))
		       (loop) )
		      (else 
		       (write-char c)
		       (loop) ) ) ) ) ) )
	"\"") ) )
    (define (skip-comment)
      (let ((c (read-char port)))
	(case c
	  ((#!eof) (err "unexpected end of comment"))
	  ((#\newline)
	   (set! ln (fx+ ln 1))
	   (skip-comment) )
	  ((#\*)
	   (case (read-char port)
	     ((#\newline)
	      (set! ln (fx+ ln 1))
	      (skip-comment) )
	     ((#\/) #f) 
	     (else (skip-comment)) ) )
	  ((#\/)
	   (case (read-char port)
	     ((#\newline)
	      (set! ln (fx+ ln 1))
	      (skip-comment) )
	     ((#\*) (skip-comment) (skip-comment))
	     (else (skip-comment)) ) )
	  (else (skip-comment)) ) ) )
    (define (read-sequence tok del)
      (cons
       tok
       (let loop ((lst '()))
	 (let ((s (skip)))
	   (if (and s (not (eof-object? s)))
	       (loop (cons s lst))
	       (let ((c (peek-char port)))
		 (cond ((eof-object? c) (err "unexpected end of sequence"))
		       ((char=? del c)
			(read-char port)
			(reverse lst) )
		       (else (loop (cons (scan) lst))) ) ) ) ) ) ) )
    (scan) ) )

)