;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Read/reader.scm              */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Tue Dec 27 11:16:00 1994                          */
;*    Last change :  Fri Oct 31 17:14:28 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    Bigloo's reader                                                  */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    Le module                                                        */
;*---------------------------------------------------------------------*/
(module __reader
   
   (import  __error
	    __rgc)
   
   (use     __type
	    __bigloo
	    __structure
	    __tvector
	    __dsssl
	    __ucs2
	    __unicode
	    __bexit
	    __binary
	    
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_numbers_6_5
	    __r4_characters_6_6
	    __r4_equivalence_6_2
	    __r4_booleans_6_1
	    __r4_symbols_6_4
	    __r4_strings_6_7
	    __r4_pairs_and_lists_6_3
	    __r4_control_features_6_9
	    __r4_vectors_6_8
	    __r4_ports_6_10_1
	    __r4_input_6_10_2
	    __r4_output_6_10_3
	    
	    __evenv)
   
   (extern (macro unspec::obj "BUNSPEC")
	   (macro boptional::obj "BOPTIONAL")
	   (macro brest::obj "BREST")
	   (macro bkey::obj "BKEY")
	   (macro make-cnst::obj (::long) "BCNST")
	   
	   (export symbol-case-sensitive?  "symbol_case_sensitivep"))
   
   (java   (class foreign
	      (field static unspec::obj "BUNSPEC")
	      (field static boptional::obj "BOPTIONAL")
	      (field static brest::obj "BREST")
	      (field static bkey::obj "BKEY")
	      (method static make-cnst::obj (::long) "BCNST")))
	   
   (export  *bigloo-interpreter*
	    (bigloo-case-sensitivity::symbol)
	    (bigloo-case-sensitivity-set! ::symbol)
	    (read . port)
	    (bigloo-regular-grammar)
	    (read/case case . port)
	    (read-case-sensitive . port)
	    (read-case-insensitive . port)
	    (reader-reset!)
	    (symbol-case-sensitive?::bool ::symbol)))

;*---------------------------------------------------------------------*/
;*    bigloo-case-sensitivity ...                                      */
;*---------------------------------------------------------------------*/
(define (bigloo-case-sensitivity)
   *rgc-case*)

;*---------------------------------------------------------------------*/
;*    bigloo-case-sensitivity-set! ...                                 */
;*---------------------------------------------------------------------*/
(define (bigloo-case-sensitivity-set! val)
   (case val
      ((sensitive)
       (set! *rgc-case* 'sensitive))
      ((downcase)
       (set! *rgc-case* 'downcase))
      ((upcase)
       (set! *rgc-case* 'upcase))
      (else
       (error "bigloo-sensitivity-set!" "Illegal sensitivity" val))))

;*---------------------------------------------------------------------*/
;*    *bigloo-interpreter* ...                                         */
;*---------------------------------------------------------------------*/
(define *bigloo-interpreter* #f)

;*---------------------------------------------------------------------*/
;*    Les variables de control du lecteur                              */
;*---------------------------------------------------------------------*/
(define *par-open*  0)
(define *bra-open*  0)

;*---------------------------------------------------------------------*/
;*    Parenthesis mismatch (or unclosing) errors.                      */
;*---------------------------------------------------------------------*/
(define *list-error-level* 20)
(define *list-errors*      (make-vector *list-error-level* #unspecified))
(define *vector-errors*    (make-vector *list-error-level* #unspecified))

;*---------------------------------------------------------------------*/
;*    Control variables.                                               */
;*---------------------------------------------------------------------*/
(define *cyclic-references* '())
(define *position?*         #f)
(define *line-number*       1)
(define *end-of-list*       (cons 0 0))
(define *dotted-mark*       (cons 1 1))

;*---------------------------------------------------------------------*/
;*    reader-reset! ...                                                */
;*---------------------------------------------------------------------*/
(define (reader-reset!)
   (set! *line-number* 1)
   (set! *par-open* 0)
   (set! *bra-open* 0))

;*---------------------------------------------------------------------*/
;*    string-newline-number ...                                        */
;*    -------------------------------------------------------------    */
;*    The number of occurrence of the Newline character inside the     */
;*    string.                                                          */
;*---------------------------------------------------------------------*/
(define (string-newline-number string)
   (let loop ((i (-fx (string-length string) 1))
	      (occ 0))
      (cond
	 ((=fx i -1)
	  occ)
	 ((char=? (string-ref string i) #\Newline)
	  (loop (-fx i 1) (+fx occ 1)))
	 (else
	  (loop (-fx i 1) occ)))))

;*---------------------------------------------------------------------*/
;*    read-error ...                                                   */
;*---------------------------------------------------------------------*/
(define (read-error msg obj port)
   (let* ((obj-loc (if (epair? obj)
		       (match-case (cer obj)
			  ((at ?fname ?pos ?-)
			   pos)
			  (else
			   #f))
		       #f))
	  (loc (if (number? obj-loc)
		   obj-loc
		   (cond
		      ((>fx *par-open* 0)
		       (let ((open-key (-fx *par-open* 1)))
			  (if (<fx open-key (vector-length *list-errors*))
			      (c-vector-ref *list-errors* open-key)
			      #f)))
		      ((>fx *bra-open* 0)
		       (let ((open-key (-fx *bra-open* 1)))
			  (if (<fx open-key (vector-length *vector-errors*))
			      (c-vector-ref *vector-errors* open-key)
			      #f)))
		      (else
		       #f)))))
      (if (fixnum? loc)
	  (error/location "read" msg obj (input-port-name port) loc)
	  (error "read" msg obj))))

;*---------------------------------------------------------------------*/
;*    unreference! ...                                                 */
;*---------------------------------------------------------------------*/
(define (unreference! obj port)
   (let loop ((obj obj))
      (cond
	 ((procedure? obj)
	  (let* ((no   (obj))
		 (cell (assq no *cyclic-references*)))
	     (if (not (pair? cell))
		 (error/location "read"
				 "no target for graph reference"
				 no
				 (input-port-name port)
				 (input-port-position port))
		 (cdr cell))))
	 ((pair? obj)
	  (set-car! obj (loop (car obj)))
	  (set-cdr! obj (loop (cdr obj)))
	  obj)
	 ((vector? obj)
	  (let ((len (vector-length obj)))
	     (let laap ((i 0))
		(if (<fx i len)
		    (begin
		       (vector-set! obj i (loop (vector-ref obj i)))
		       (laap (+fx i 1)))
		    obj))))
	 ((struct? obj)
	  (let ((len (vector-length obj)))
	     (let laap ((i 0))
		(if (<fx i len)
		    (begin
		       (struct-set! obj i (loop (struct-ref obj i)))
		       (laap (+fx i 1)))
		    obj))))
	 (else
	  obj))))
   
;*---------------------------------------------------------------------*/
;*    make-list! ...                                                   */
;*---------------------------------------------------------------------*/
(define (make-list! l port)
   (define (reverse-proper-list! l)
      (let nr ((l l)
	       (r '()))
	 (cond
	    ((eq? (car l) *dotted-mark*)
	     (read-error "Illegal pair" r port))
	    ((null? (cdr l))
	     (set-cdr! l r)
	     l)
	    (else
	     (let ((cdrl (cdr l)))
		(nr cdrl
		    (begin (set-cdr! l r)
			   l)))))))
   (define (reverse-improper-list! l)
      (let nr ((l (cddr l))
	       (r (car l)))
	 (cond
	    ((eq? (car l) *dotted-mark*)
	     (read-error "Illegal pair" r port))
	    ((null? (cdr l))
	     (set-cdr! l r)
	     l)
	    (else
	     (let ((cdrl (cdr l)))
		(nr cdrl
		    (begin (set-cdr! l r)
			   l)))))))
   (cond
      ((null? l)
       l)
      ((and (pair? l) (pair? (cdr l)) (eq? (cadr l) *dotted-mark*))
       (if (null? (cddr l))
	   (car l)
	   (reverse-improper-list! l)))
      (else
       (reverse-proper-list! l)))) 
	   
;*---------------------------------------------------------------------*/
;*    collect-up-to ...                                                */
;*    -------------------------------------------------------------    */
;*    The first pair of the list is special because of source file     */
;*    location. We want the location to be associated to the first     */
;*    open parenthesis, not the last character of the car of the list. */
;*---------------------------------------------------------------------*/
(define-inline (collect-up-to ignore kind port)
   (let ((name (input-port-name port)))
      (let* ((pos  (input-port-position port))
	     (line *line-number*)
	     (item (ignore)))
	 (if (eq? item *end-of-list*)
	     '()
	     (let loop ((acc (if *position?*
				 (econs item '() (list 'at name pos line))
				 (cons item '()))))
		(let ((item (ignore)))
		   (if (eq? item *end-of-list*)
		       acc
		       (loop (if *position?*
				 (let ((new-pos  (input-port-position port))
				       (new-line *line-number*))
				    (econs item
					   acc
					   (list 'at name new-pos new-line)))
				 (cons item acc))))))))))

;*---------------------------------------------------------------------*/
;*    read-quote ...                                                   */
;*---------------------------------------------------------------------*/
(define (read-quote kwote port ignore)
   (if *position?*
       (let* ((pos (input-port-position port))
	      (obj (ignore)))
	  (if (or (eof-object? obj) (eq? obj *end-of-list*))
	      (error/location "read"
			      "Illegal quotation"
			      kwote
			      (input-port-name port)
			      pos))
	  (econs kwote
		 (cons obj '())
		 (list 'at (input-port-name port) pos *line-number*)))
       (let ((obj (ignore)))
	  (if (or (eof-object? obj) (eq? obj *end-of-list*))
	      (error "read" "Illegal quotation" kwote)
	      (cons kwote (cons obj '()))))))

;*---------------------------------------------------------------------*/
;*    read-multi-line-comment ...                                      */
;*---------------------------------------------------------------------*/
(define (read-multi-line-comment port)
   (let ((g (regular-grammar ()
	       ("#|"
		(read-multi-line-comment input-port)
		(ignore))
	       ((+ (or (out #\# #\|) (: #\# (out #\|)) (: #\| (out #\#))))
		(ignore))
	       ("|#"
		#unspecified)
	       (else
		(let ((c (the-failure)))
		   (if (eof-object? c)
		       (error/location "read"
				       "EOF inside block comment -- #| missing a closing |#"
				       c
				       (input-port-name input-port)
				       (input-port-position input-port))))))))
      (read/rp g port)))

;*---------------------------------------------------------------------*/
;*    bigloo-regular-grammar ...                                       */
;*---------------------------------------------------------------------*/
(define (bigloo-regular-grammar)
   *bigloo-grammar*)

;*---------------------------------------------------------------------*/
;*    *bigloo-grammar* ...                                             */
;*---------------------------------------------------------------------*/
(define *bigloo-grammar*
   (regular-grammar ((float    (or (: (* digit) "." (+ digit))
			 	   (: (+ digit) "." (* digit))))
		     (letter   (in ("azAZ") (#a128 #a255)))
		     (special  (in "!@~$%^&*></-_+\\=?.:"))
		     (kspecial (in "!@~$%^&*></-_+\\=?."))
		     (quote    (in "\",'`"))
		     (paren    (in "()[]{}"))
		     (id       (: (* digit)
				  (or letter special)
				  (* (or letter special digit (in ",'`")))))
		     (kid      (: (* digit)
				  (or letter kspecial)
				  (* (or letter kspecial digit (in ",'`")))))
		     (blank    (in #\Space #\Tab #a012 #a013)))
      
      ;; newlines
      ((+ #\Newline)
       (set! *line-number* (+fx *line-number* (the-length)))
       (ignore))
      
      ;; blank lines
      ((+ blank)
       (ignore))
      
      ;; comments
      ((: ";" (* all))
       (ignore))

      ;; multi-line comment (SRFI-30)
      ("#|"
       (read-multi-line-comment (the-port))
       (ignore))

      ;; srfi-22 support
      ((bol (: "#!" #\space (in digit letter special "|,'`") (* all)))
       (ignore))
      
      ;; the interpreter header or the dsssl named constants
      ((: "#!" (+ (in digit letter special "|,'`")))
       (let* ((str (the-string)))
	  (cond
	     ((string=? str "#!optional")
	      boptional)
	     ((string=? str "#!rest")
	      brest)
	     ((string=? str "#!key")
	      bkey)
	     (else
	      (set! *bigloo-interpreter* #t)
	      (ignore)))))
      
      ;; characters
      ((: (uncase "#a") (= 3 digit))
       (let ((string (the-string)))
	  (if (not (=fx (the-length) 5))
	      (error/location "read"
			      "Illegal ascii character"
			      string
			      (input-port-name     (the-port))
			      (input-port-position (the-port)))
	      (integer->char (string->integer (the-substring 2 5))))))
      ((: "#\\" (or letter digit special (in "|#; " quote paren)))
       (string-ref (the-string) 2))
      ((: "#\\" (>= 2 letter))
       (let ((char-name (string->symbol
			 (string-upcase!
			  (the-substring 2 (the-length))))))
	  (case char-name
	     ((NEWLINE)
	      #\Newline)
	     ((TAB)
	      #\tab)
	     ((SPACE)
	      #\space)
	     ((RETURN)
	      (integer->char 13))
	     (else
	      (error/location "read"
			      "Illegal character"
			      (the-string)
			      (input-port-name     (the-port))
			      (input-port-position (the-port)))))))
      
      ;; ucs-2 characters
      ((: "#u" (= 4 xdigit))
       (integer->ucs2 (string->integer (the-substring 2 6) 16)))
      
      ;; strings with newline in them in addition to compute
      ;; the string, we have to count the number of newline
      ;; in order to increment the line-num variable strings
      ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
       (let ((str (the-substring 1 (-fx (the-length) 1))))
	  (set! *line-number* (+fx *line-number* (string-newline-number str)))
	  (if *bigloo-strict-r5rs-strings*
	      (let ((str (the-substring 1 (-fx (the-length) 1))))
		 (escape-scheme-string str))
	      (let ((str (the-substring 0 (-fx (the-length) 1))))
		 (escape-C-string str)))))
      ;; foreign strings of char
      ((: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
       (let ((str (the-substring 1 (-fx (the-length) 1))))
	  (set! *line-number* (+fx *line-number* (string-newline-number str)))
	  (escape-C-string str)))
      ;; ucs2 strings
      ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
       (let ((str (the-substring 3 (-fx (the-length) 1))))
	  (set! *line-number* (+fx *line-number* (string-newline-number str)))
  	  (utf8-string->ucs2-string str)))
      
      ;; fixnums
      ((: (? "+") (+ digit))
       (the-integer))
;       (let ((n::bint (the-fixnum)))
;	  (if (<fx n 0)
;	      (string->llong (the-string))
;	      n)))
      ((: "-" (+ digit))
       (the-integer))
;       (let ((n::bint (the-fixnum)))
;	  (if (>fx n 0)
;	      (string->llong (the-string))
;	      n)))
      ((: "#o" (? (in "-+")) (+ (in ("07"))))
       (string->integer (the-substring 2 (the-length)) 8))
      ((: "#d" (? (in "-+")) (+ (in ("09"))))
       (string->integer (the-substring 2 (the-length)) 10))
      ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af"))))))
       (string->integer (the-substring 2 (the-length)) 16))
      ((: "#e" (? (in "-+")) (+ digit))
       (string->elong (the-substring 2 (the-length)) 10))
      ((: "#l" (? (in "-+")) (+ digit))
       (string->llong (the-substring 2 (the-length)) 10))
      
      ;; flonum
      ((: (? (in "-+"))
	  (or float
	      (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit))))
       (the-flonum))
      
      ;; doted pairs
      ("."
       (if (<=fx *par-open* 0)
	   (error/location "read"
			   "Illegal token"
			   #\.
			   (input-port-name     (the-port))
			   (input-port-position (the-port)))
	   *dotted-mark*))
      
      ;; unspecified and eof-object
      ((: "#" (in "ue") (+ (in "nspecified-objt")))
       (let ((symbol (string->symbol
		      (string-upcase!
		       (the-substring 1 (the-length))))))
	  (case symbol
	     ((UNSPECIFIED)
	      unspec)
	     ((EOF-OBJECT)
	      beof)
	     (else
	      (error/location "read"
			      "Illegal identifier"
			      symbol
			      (input-port-name     (the-port))
			      (input-port-position (the-port)))))))
      
      ;; booleans
      ((: "#" (uncase #\t))
       #t)
      ((: "#" (uncase #\f))
       #f)
      
      ;; constants
      ((: "#<" (+ (or digit (uncase (in "afAF")))) ">")
       (if (not (=fx (the-length) 7))
	   (error/location "read"
			   "Illegal constant"
			   (the-string)
			   (input-port-name     (the-port))
			   (input-port-position (the-port)))
	   (make-cnst (string->integer (the-substring 2 6) 16))))
      
      ;; keywords
      ((or (: ":" kid) (: kid ":"))
       ;; since the keyword expression is also matched by the id
       ;; rule, keyword rule has to be placed before the id rule.
       (the-keyword))
      
      ;; identifiers
      (id
       ;; this rule has to be placed after the rule matching the `.' char
       (the-symbol))
      ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|")
       (if (=fx (the-length) 2)
	   (the-symbol)
	   (let ((str (the-substring 0 (-fx (the-length) 1))))
	      (set! *line-number*
		    (+fx *line-number* (string-newline-number str)))
	      (string->symbol (escape-C-string str)))))
      
      ;; quotations 
      ("'"
       (read-quote 'quote (the-port) ignore))
      ("`"
       (read-quote 'quasiquote (the-port) ignore))
      (","
       (read-quote 'unquote (the-port) ignore))
      (",@"
       (read-quote 'unquote-splicing (the-port) ignore))
      
      ;; lists
      ((in "([")
       ;; if possible, we store the opening parenthesis.
       (if (and (vector? *list-errors*)
		(<fx *par-open* (vector-length *list-errors*)))
	   (c-vector-set! *list-errors*
			  *par-open*
			  (input-port-position (the-port))))
       ;; we increment the number of open parenthesis
       (set! *par-open* (+fx 1 *par-open*))
       ;; and then, we compute the result list...
       (make-list! (collect-up-to ignore "list" (the-port)) (the-port)))
      ((in ")]")
       ;; we decrement the number of open parenthesis
       (set! *par-open* (-fx *par-open* 1))
       (if (<fx *par-open* 0)
	   (begin
	      (warning/location (input-port-name (the-port))
				(input-port-position (the-port))
				"read"
				"Superfluous closing parenthesis `"
				(the-string)
				"'")
	      (set! *par-open* 0)
	      (ignore))
	   *end-of-list*))
      
      ;; vectors
      ("#("
       ;; if possible, we store the opening parenthesis.
       (if (and (vector? *vector-errors*)
		(<fx *par-open* (vector-length *vector-errors*)))
	   (let ((pos (input-port-position (the-port))))
	      (c-vector-set! *vector-errors* *par-open* pos)))
       ;; we increment the number of open parenthesis
       (set! *par-open* (+fx 1 *par-open*))
       (list->vector (reverse! (collect-up-to ignore "vector" (the-port)))))
      ((: "#" (: letter (* id)) "(")
       ;; we increment the number of open parenthesis
       (set! *par-open* (+fx 1 *par-open*))
       (let* ((id  (let ((str (the-substring 1 (-fx (the-length) 1))))
		      (string->symbol
		       (case (bigloo-case-sensitivity)
			  ((upcase)
			   (string-upcase! str))
			  ((downcase)
			   (string-downcase! str))
			  ((sensitive)
			   str)
			  (else
			   (string-upcase! str))))))
	      (l   (reverse! (collect-up-to ignore "vector" (the-port)))))
	  (list->tvector id l)))

      ;; structures
      ("#{"
       ;; if possible, we store the opening parenthesis.
       (if (and (vector? *vector-errors*)
		(<fx *bra-open* (vector-length *vector-errors*)))
	   (let ((pos (input-port-position (the-port))))
	      (c-vector-set! *vector-errors* *bra-open* pos)))
       ;; then, we compute the structure
       ;; we increment the number of open parenthesis
       (set! *bra-open* (+fx 1 *bra-open*))
       (let ((l (reverse! (collect-up-to ignore "structure" (the-port)))))
	  (cons '_structure_ l)))
      ("}"
       (set! *bra-open* (-fx *bra-open* 1))
       (if (<fx *bra-open* 0)
	   (begin
	      (set! *bra-open* 0)
	      (ignore))
	   *end-of-list*))

      ;; cyclic target mark
      ((: "#" (+ digit) "=")
       (let* ((no (string->integer (the-substring 1 (-fx (the-length) 1))))
	      (pos (input-port-position (the-port)))
	      (the-object (ignore)))
	  (if (eof-object? the-object)
	      (error/location "read"
			      "Illegal cyclic reference"
			      no
			      (input-port-name (the-port))
			      pos))
	  (set! *cyclic-references*
		(cons (cons no the-object) *cyclic-references*))
	  (unreference! the-object (the-port))))

      ;; cyclic target reference
      ((: "#" (+ digit) "#")
       (let* ((no (string->integer (the-substring 1 (-fx (the-length) 1))))
	      (cell (assq no *cyclic-references*)))
	  (if (not (pair? cell))
	      (lambda () no)
	      (cdr cell))))
      
      ;; error or eof
      (else
       (let ((char (the-failure)))
	  (if (eof-object? char)
	      (cond
		 ((>fx *par-open* 0)
		  (let ((open-key (-fx *par-open* 1)))
		     (reader-reset!)
		     (if (and (<fx open-key (vector-length *list-errors*))
			      (fixnum? (c-vector-ref *list-errors* open-key)))
			 (error/location "read"
					 "Unclosed list"
					 char
					 (input-port-name (the-port))
					 (c-vector-ref *list-errors* open-key))
			 (error "read"
				"Unexpected end-of-file"
				"Unclosed list"))))
		 ((>fx *bra-open* 0)
		  (let ((open-key (-fx *bra-open* 1)))
		     (reader-reset!)
		     (if (and (<fx open-key (vector-length *vector-errors*))
			      (fixnum? (c-vector-ref *vector-errors*
						     open-key)))
			 (error/location "read"
					 "Unclosed vector or structure"
					 char
					 (input-port-name (the-port))
					 (c-vector-ref *vector-errors*
						       open-key))
			 (error "read"
				"Unexpected end-of-file"
				"Unclosed vector or structure"))))
		 (else
		  (reset-eof (the-port))
		  char))
	      (error/location "read"
			      "Illegal char"
			      (illegal-char-rep char)
			      (input-port-name     (the-port))
			      (input-port-position (the-port))))))))

;*---------------------------------------------------------------------*/
;*    read ...                                                         */
;*---------------------------------------------------------------------*/
(define (read . input-port)
   (set! *position?* #f)
   (set! *cyclic-references* '())
   ;; read except an undocumented argument used by the compiler to
   ;; get line number associated with expressions.
   (cond
      ((null? input-port)
       (read/rp *bigloo-grammar* (current-input-port)))
      ((not (input-port? (car input-port)))
       (error "read" "type `input-port' expected" (car input-port)))
      (else
       (let ((port (car input-port)))
	  (if (closed-input-port? port)
	      ;; The reader is always compiled in unsafe mode then, the
	      ;; expansion of the *BIGLOO-GRAMMAR* never checks if the
	      ;; input port is not already closed. In consequence, we
	      ;; have to explicitly test the closeness before reading.
	      (error "read" "Illegal closed input port" port)
	      (if (null? (cdr input-port))
		  (read/rp *bigloo-grammar* port)
		  (begin
		     (set! *position?* #t)
		     (if (fixnum? (cadr input-port))
			 (set! *line-number* (cadr input-port)))
		     (read/rp *bigloo-grammar* port))))))))

;*---------------------------------------------------------------------*/
;*    read/case ...                                                    */
;*---------------------------------------------------------------------*/
(define (read/case case . input-port)
   (let ((old (bigloo-case-sensitivity)))
      (bigloo-case-sensitivity-set! case)
      (unwind-protect
	 (apply read input-port)
	 (bigloo-case-sensitivity-set! old))))
   
;*---------------------------------------------------------------------*/
;*    read-case-sensitiie ...                                          */
;*    -------------------------------------------------------------    */
;*    Case sensitive read.                                             */
;*---------------------------------------------------------------------*/
(define (read-case-sensitive . input-port)
   (apply read/case 'sensitive input-port))

;*---------------------------------------------------------------------*/
;*    read-case-insensitive ...                                        */
;*    -------------------------------------------------------------    */
;*    Case unsensitive read.                                           */
;*---------------------------------------------------------------------*/
(define (read-case-insensitive . input-port)
   (apply read/case 'downcase input-port))

;*---------------------------------------------------------------------*/
;*    symbol-case-sensitive? ...                                       */
;*---------------------------------------------------------------------*/
(define (symbol-case-sensitive? symb::symbol)
   (string-case (symbol->string symb)
      ((: (* all) (+ (out digit ("AZaz") "!@~$%^&*></-_+\\=?.:,'`")) (* all))
       #t)
      (else
       #f)))
