;;; honu.scm - "honu"-syntax reader


(define read-honu
  (let ((comma (string->symbol ","))
	(semicolon (string->symbol ";"))
	(operator-chars
	 '(#\- #\+ #\/ #\? #\: #\* #\% #\& #\! #\. #\~ #\_ #\| #\> #\< #\= #\^) ))
    (define (read-token pred . port)
      (let* ((port (optional port (current-input-port)))
	     (out (open-output-string)))
	(let loop ()
	  (let ([c (peek-char port)])
	    (cond ((and (not (eof-object? c)) (pred c))
		   (write-char (read-char port) out)
		   (loop) )
		  (else (get-output-string out) ) ) ) ) ) )
    (define (read-line . port)
      (let ((in (optional port (current-input-port))))
	(let loop ((chars '()))
	  (let ((c (read-char in)))
	    (cond ((or (eof-object? c) (char=? #\newline c))
		   (list->string (reverse chars)))
		  (else (loop (cons c chars))))))))
    (define (reverse-list->string lst)
      (list->string (reverse lst)))
    (lambda port
      (let ((port (optional port (current-input-port))))
	(define (err msg . args)
	  (apply error 'read-honu msg args))
	(define (opchar? c) (memv c operator-chars))
	(define (skip)
	  (let ((c (peek-char port)))
	    (cond ((eof-object? c) c)
		  ((char-whitespace? c)
		   (read-char port)
		   (skip) )
		  ((char=? #\/ c)
		   (read-char port)
		   (let ((c (peek-char port)))
		     (case c
		       ((#\/) 
			(read-line port)
			(skip) )
		       ((#\*) (skip-comment) (skip))
		       (else
			(if (opchar? c)
			    (let ((s (read-token opchar? port)))
			      (string->symbol (string-append "/" s) ) )
			    '/) ) ) ) )
		  (else #f) ) ) )
	(define (scan)
	  (or (skip)
	      (let ((c (peek-char port)))
		(if (eof-object? c)
		    (err "unexpected end of input")
		    (case c
		      ((#\#)
		       (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" t)) ) ) ) ) ) )
		      ((#\') 
		       (read-char port)
		       (let ((s (read-escaped (lambda (c) (char=? #\' c)))))
			 (if (zero? (string-length s))
			     (err "empty character literal")
			     (string-ref s 0) ) ) )
		      ((#\,) (read-char port) comma)
		      ((#\;) (read-char port) semicolon)
		      ((#\") (read-char port) (read-escaped (lambda (c) (char=? #\" c))))
		      ((#\() (read-char port) (read-sequence '%parens #\)))
		      ((#\[) (read-char port) (read-sequence '%brackets #\]))
		      ((#\{) (read-char port) (read-sequence '%braces #\}))
		      ((#\) #\] #\}) (err "unexpected closing delimiter" c))
		      (else
		       (cond ((char-numeric? c) (read-num))
			     ((or (char-alphabetic? c) 
				  (char=? c #\_)
				  (char=? c #\$))
			      (string->symbol
			       (read-token
				(lambda (c)
				  (or (char-alphabetic? c)
				      (char-numeric? c)
				      (char=? #\_ c)
				      (char=? #\$ c)))
				port) ) )
			     ((opchar? c) (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)))
		 (if (eof-object? c)
		     (reverse-list->string lst)
		     (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)) ) ) ) )
		       ((#\.)
			(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)
	  (with-input-from-string
	      (with-output-to-string
		(lambda ()
		  (write-char #\")
		  (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) ) ) ) )
		  (write-char #\") ) )
	    read))
	(define (skip-comment)
	  (let ((c (read-char port)))
	    (if (eof-object? c)
		(err "unexpected end of comment")
		(case c
		  ((#\*)
		   (let loop ()
		     (case (read-char port)
		       ((#\*) (loop))
		       ((#\/) #f)
		       (else (skip-comment)) ) ))
		  ((#\/)
		   (case (read-char port)
		     ((#\*) (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) ))))