
#lang racket

(provide theme-read check-read-data? theme-string-match)

(require theme-d-racket/th-scheme-utilities/stdutils)
(require theme-d-racket/runtime/runtime-theme-d-environment)
(require theme-d-racket/runtime/theme-d-alt-support)
(require rnrs/exceptions-6)


(define (mlist . l)
  (cond
   ((null? l) '())
   ((pair? l) (mcons (car l) (apply mlist (cdr l))))
   (else l)))


(define (list->mlist l)
  (cond
   ((mpair? l) (mcons (list->mlist (mcar l)) (list->mlist (mcdr l))))
   ((pair? l) (mcons (list->mlist (car l)) (list->mlist (cdr l))))
   (else l)))


(define (make-file-exception1 exc-type filename)
  (make-theme-d-condition 'io-error
			  (list->mlist
			   (list
			    (mcons 's-subkind exc-type)
			    (mcons 'str-filename filename)))))


(define (i/o-error-filename2 exn) "")


(define (check-read-data? data)
  (cond
   ((or (symbol? data)
	(boolean? data)
	(is-real? data)
	(is-integer? data)
	(string? data)
	(char? data)
	(null? data))
    #t)
   ((vector? data)
    (raise
     (make-file-exception1
      'io:illegal-vector
      "")))
   ((and (complex? data) (not (real? data)))
    (raise
     (make-file-exception1
      'io:illegal-complex-number
      "")))
   ((pair? data) (begin (check-read-data? (car data))
			(check-read-data? (cdr data))
			#t))
   ((mpair? data) (begin (check-read-data? (mcar data))
   			 (check-read-data? (mcdr data))
   			 #t))
   (else
    (display data)
    (newline)
    (raise
     (make-file-exception1
      'io:illegal-data-type
      "")))))    


(define (theme-read2 ip)
  (list->mlist (read ip)))


(define (theme-read ip)
  (let ((data
  	 (guard (exc
  	 	 (else
  	 	  (raise
  	 	   (make-file-exception1
  	 	    'read:io-error
  	 	    (i/o-error-filename2 exc)))))
  		(theme-read2 ip))))
    (if (eof-object? data)
  	theme-eof
  	(begin
  	  (check-read-data? data)
  	  data))))


(define (theme-string-match str-pattern str-source)
  (let ((match-result (regexp-match-positions str-pattern str-source)))
    (if (not (eq? match-result #f))
     	(let* ((p-ind (car match-result))
     	       (i-start (car p-ind))
     	       (i-end (cdr p-ind))
     	       (str-substring (substring str-source i-start i-end)))
     	  (mlist str-substring i-start i-end))
    '())))
