
;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

#lang racket

(provide (all-defined-out))

(provide theme-read 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 theme-d-racket/runtime/theme-d-special)
(require (except-in rnrs assert))
(require rnrs/mutable-pairs-6)
;; (require rnrs/exceptions-6)
;; (require rnrs/io/ports-6)
(require (only-in racket/fixnum fxabs))


;; It seems that i/o-error-filename is not supported by Racket.
(define (i/o-error-filename1 exn) "")


(define (raise-simple s-kind)
  (raise (make-theme-d-condition s-kind '())))


;; *** Primitive definitions needed by the Theme-D standard library ***


;; *** (standard-library core) ***


(define _b_raise
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object>)
    _b_none
    #t)
   raise))


(define (theme-exit i-exit-code)
  (raise (make-theme-d-condition 'exit
				 (list (cons 'i-exit-code i-exit-code)))))


(define (theme-debug-print x)
  (display x)
  (flush-output))


(define (theme-enable-rte-exception-info)
  (set-rte-exception-info! #t))


(define (theme-disable-rte-exception-info)
  (set-rte-exception-info! #f))


(define (theme-d-condition-kind1 exc)
  (assert (theme-d-condition? exc))
  (theme-d-condition-kind exc))


(define (theme-d-condition-info1 exc)
  (assert (theme-d-condition? exc))
  (theme-d-condition-info exc))


(define (_i_vector-ref uv i)
  (vector-ref uv (+ i 1)))


(define (_i_mutable-vector-ref vec i)
  (vector-ref vec (+ i 1)))


(define (_i_mutable-vector-set! vec i item)
  ;; The result of this procedure is undefined.
  (vector-set! vec (+ i 1) item))


(define (_i_value-vector-ref vec i)
  (vector-ref vec (+ i 1)))


(define (_i_mutable-value-vector-ref vec i)
  (vector-ref vec (+ i 1)))


(define (_i_mutable-value-vector-set! vec i item)
  (vector-set! vec (+ i 1) item))


(define (_b_vector-length vec)
  ;; The first element of a vector is its class.
  (let ((raw-len (vector-length vec)))
    (assert (> raw-len 0))
    (- raw-len 1)))


(define (integer->real n)
  (assert (integer? n))
  (exact->inexact n))


(define (real->integer r)
  (if (integer-valued? r)
      (inexact->exact r)
      (raise-simple 'numeric-type-mismatch)))


(define (theme-round r)
  (inexact->exact (r-round r)))


(define (theme-truncate r)
  (inexact->exact (r-truncate r)))


(define (theme-floor r)
  (inexact->exact (r-floor r)))


(define (theme-ceiling r)
  (inexact->exact (r-ceiling r)))


(define inf? infinite?)


(define xor
  (lambda (b1 b2)
    (or (and b1 (not b2))
	(and (not b1) b2))))


(define (theme-real-integer/ r n)
  (if (= n 0)
      ;; guile-2.2 returns +-inf in this case, too.
      ;; guile-2.0 raises exception numerical-overflow.
      ;; We follow the former convention.
      (cond
       ((> r 0.0) (inf))
       ((< r 0.0) (- (inf)))
       (else (nan)))
      (/ r n)))


(define (theme-call/cc normal-type jump-type body-proc)
  (let* ((proc-type
	  (_i_make-procedure-type (_i_make-tuple-type jump-type)
				  _b_none #t #f #t #f #t))
	 (result
	  (call/cc
	   (lambda (proc)
	     (let ((my-proc (_i_make-procedure proc-type proc)))
	       (_i_call-proc body-proc (list my-proc) (list proc-type)))))))
    result))


(define (theme-call/cc-without-result body-proc)
  (let* ((proc-type
	  (_i_make-procedure-type (_i_make-tuple-type)
				  _b_none #t #f #t #f #t))
	 (result
	  (call/cc
	   (lambda (proc)
	     (let* ((actual-proc (lambda () (proc '())))
		    (my-proc (_i_make-procedure proc-type
						actual-proc)))
	       (_i_call-proc body-proc (list my-proc) (list proc-type)))))))
    result))


(define (theme-with-exception-handler type-result proc-handler proc-body)
  (with-exception-handler
   (lambda (variable)
     (_i_call-proc proc-handler (list variable) (list _b_<object>)))
   (lambda ()
     (_i_call-proc proc-body '() '()))))


;; *** (standard-library math) ***


(define (real-to-rational-impl r)
  (let ((nr-result (inexact->exact r)))
    (cons (numerator nr-result) (denominator nr-result))))


;; *** (standard-library text-file-io) ***


(define (make-file-exception exc-type filename)
  (make-theme-d-condition 'io-error
			  (list
			   (cons 's-subkind exc-type)
			   (cons 'str-filename filename))))


(define (theme-open-output-file filename)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-opening-output-file filename))))
;;  	 (open-output-file filename #:exists 'replace)))
;;  	 (open-output-file filename)))
  	 (open-file-output-port filename (file-options no-fail) 'block
				(native-transcoder))))


(define (theme-open-input-file filename)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-opening-input-file filename))))
  	 (open-input-file filename)))


(define (theme-close-output-port op)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-closing-output-port
		       (i/o-error-filename1 exc)))))
  	 (close-output-port op)))


(define (theme-close-input-port ip)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-closing-input-port
		       (i/o-error-filename1 exc)))))
  	 (close-input-port ip)))


(define (theme-prim-write obj op)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-writing-object
		       (i/o-error-filename1 exc)))))
  	 (write obj op)))


(define (theme-prim-display obj op)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-displaying-object
		       (i/o-error-filename1 exc)))))
  	 (display obj op)))


(define (theme-newline op)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-displaying-newline
		       (i/o-error-filename1 exc)))))
  	 (newline op)))


(define (theme-read-character ip)
  (guard (exc
  	  (else
  	   (raise
  	    (make-file-exception
  	     'read-character:io-error
  	     (i/o-error-filename1 exc)))))
  	 (let* ((ch (read-char ip))
  		(result
  		 (cond
  		  ((eof-object? ch) ch)
  		  ((char? ch) ch)
  		  (else (raise-simple 'read-character:data-error)))))
  	   result)))


(define (theme-peek-character ip)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'peek-character:io-error
  		       (i/o-error-filename1 exc)))))
	 (let* ((ch (peek-char ip))
		(result
		 (cond
		  ((eof-object? ch) ch)
		  ((char? ch) ch)
		  (else (raise-simple 'peek-character:data-error)))))
	   result)))


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


(define (theme-char-ready? ip)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'character-ready?:runtime-error
  		       (i/o-error-filename1 exc)))))
  	 (char-ready? ip)))


;; Filename makes probably no sense in the following three procedures.
(define (theme-current-output-port)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'current-output-port:runtime-error ""))))
  	 (current-output-port)))


(define (theme-current-error-port)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'current-error-port:runtime-error ""))))
  	 (current-error-port)))


(define (theme-current-input-port)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'current-input-port:runtime-error ""))))
  	 (current-input-port)))


(define (theme-call-with-input-string str proc)
  (let ((result
	 (call-with-input-string
	  str
	  (lambda (port)
	    (_i_call-proc proc (list port) (list (theme-class-of port)))))))
    (check-read-data? result)
    result))


(define (theme-call-with-output-string proc)
  (call-with-output-string
   (lambda (port)
     (_i_call-proc proc (list port) (list (theme-class-of port))))))


;; *** (standard-library console-io) ***


(define (theme-prim-console-display obj)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-displaying-object ""))))
  	 (display obj)))


(define (theme-console-newline)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'error-displaying-newline ""))))
  	 (newline)))


(define (theme-console-read-character)
  (theme-read-character (current-input-port)))


(define (theme-console-read)
  (theme-read (current-input-port)))


(define (theme-console-char-ready?)
  (guard (exc (else
  	       (raise (make-file-exception
  		       'char-ready?:runtime-error ""))))
  	 (char-ready?)))


;; *** (standard-library system) ***


(define (theme-getenv str-var)
  (let ((str-value (getenv str-var)))
    (if (not (eqv? str-value #f))
	str-value
	'())))


(define (theme-delete-file str-filename)
  (guard (exc
  	  (else
  	   (raise (make-file-exception 'error-deleting-file str-filename))))
	 (delete-file str-filename)))


;; *** (standard-library dynamic-list) ***


(define (d-car obj)
  (if (pair? obj)
      (car obj)
      (raise-simple 'd-car:type-mismatch)))


(define (d-cdr obj)
  (if (pair? obj)
      (cdr obj)
      (raise-simple 'd-cdr:type-mismatch)))


;; *** (standard-library goops-classes) ***


(define (reverse-search-goops-class clas)
  ;; (let ((l-desc (hashq-ref gl-ht-goops-classes clas)))
  ;;   (if (not (eq? l-desc #f))
  ;; 	(car l-desc)
  ;; 	#f)))
  (raise (make-theme-d-condition
	  'not-implemented
	  (list (cons 's-feature 'reverse-search-goops-class)))))

(define (reverse-get-goops-class clas)
  ;; (let ((o (reverse-search-goops-class clas)))
  ;;   (if (not (eq? o #f))
  ;; 	o
  ;; 	(raise (make-theme-d-condition 'undefined-goops-class
  ;; 				       (list (cons 'cl clas)))))))
  (raise (make-theme-d-condition
	  'not-implemented
	  (list (cons 's-feature 'reverse-get-goops-class)))))


;; *** (standard-library hash-table2) ***


(define (hashq x i-size)
  (remainder (fxabs (eq-hash-code x)) i-size))


(define (hashv x i-size)
  (remainder (fxabs (eqv-hash-code x)) i-size))


(define (hash-contents x i-size)
  (remainder (fxabs (equal-hash-code x)) i-size))


(define (theme-string-hash x i-size)
  (remainder (fxabs (string-hash x)) i-size))


;; *** (standard-library object-string-conversion) ***


(define (theme-string->integer str)
  (let ((nr (string->number str)))
    (if (integer? nr)
	nr
	(raise (make-theme-d-condition 'string-to-integer-conv-error
				       (list (cons 'str str)))))))


(define (theme-string->real str)
  (let ((nr (string->number str)))
    (cond
     ((integer? nr) (exact->inexact nr))
     ((rational? nr) (exact->inexact nr))
     ((and (real? nr) (not (exact? nr))) nr)
     (else
      (raise (make-theme-d-condition 'string-to-real-conv-error
				     (list (cons 'str str))))))))


(define (theme-string->real-number str)
  (let ((nr (string->number str)))
    (cond
     ((integer? nr) nr)
     ((and (real? nr) (not (exact? nr))) nr)
     ((rational? nr) (cons (numerator nr) (denominator nr)))
     (else
      (raise (make-theme-d-condition 'string-to-real-conv-error
				     (list (cons 'str str))))))))
