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


(define-module (theme-d runtime theme-d-stdlib-support)
  #:duplicates (merge-generics replace last)
  #:export (_b_raise
	    theme-exit 
	    ;; theme-command-line
	    theme-debug-print
	    theme-enable-rte-exception-info
	    theme-disable-rte-exception-info
	    theme-d-condition-kind1
	    theme-d-condition-info1
	    _i_vector-ref
	    _i_mutable-vector-ref
	    _i_mutable-vector-set!
	    _i_value-vector-ref
	    _i_mutable-value-vector-ref
	    _i_mutable-value-vector-set!
	    _b_vector-length
	    theme-string-match
	    integer->real
	    real->integer
	    theme-round
	    theme-truncate
	    theme-floor
	    theme-ceiling
	    xor
	    theme-real-integer/
	    real-to-rational-impl
	    theme-open-output-file
	    theme-open-input-file
	    theme-close-output-port
	    theme-close-input-port
	    theme-prim-write
	    theme-prim-display
	    theme-newline
	    theme-read-character
	    theme-peek-character
	    theme-read
	    theme-char-ready?
	    theme-current-output-port
	    theme-current-error-port
	    theme-current-input-port
	    theme-call-with-input-string
	    theme-call-with-output-string
	    theme-prim-console-display
	    theme-console-newline
	    theme-console-read-character
	    theme-console-read
	    theme-console-char-ready?
	    theme-getenv
	    theme-delete-file
	    d-car
	    d-cdr
	    reverse-search-goops-class
	    reverse-get-goops-class
	    make-hash-table-with-size
	    theme-hashx-ref
	    theme-hashx-exists?
	    theme-hashx-set!
	    theme-hashx-remove!
	    hash-count-elements
	    theme-string-assoc
	    theme-hash-for-each
	    hash-contents
	    theme-string-hash
	    theme-string->integer
	    theme-string->real
	    theme-string->real-number
	    theme-call/cc
	    theme-call/cc-without-result
	    theme-with-exception-handler))


(eval-when (expand load eval)
	   (import (only (rnrs) assert)))

(import (except (rnrs) map))
(import (srfi srfi-1))
(import (ice-9 regex))
(import (oop goops))

(import (th-scheme-utilities stdutils))
(import (theme-d runtime runtime-theme-d-environment))
(import (theme-d runtime theme-d-support))

(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-command-line)
;;   gl-l-command-line)


(define (theme-debug-print x)
  (display x)
  (flush-all-ports))


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


(define (theme-disable-rte-exception-info)
  (set! gl-enable-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 (theme-string-match str-pattern str-source)
  (let ((match-result (string-match str-pattern str-source)))
    (if (regexp-match? match-result)
	(list
	 (match:substring match-result)
	 (match:start match-result)
	 (match:end match-result))
	(begin
	  (assert (eq? match-result #f))
	  '()))))


(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 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-file-output-port filename (file-options no-fail))))


(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-filename 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-filename exc)))))
  	 (close-input-port ip)))


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


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


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


(define (theme-read-character ip)
  (guard (exc
  	  (else
  	   (raise
  	    (make-file-exception
  	     'read-character:io-error
  	     (i/o-error-filename 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-filename exc)))))
	 (let* ((ch (peek-char ip))
		(result
		 (cond
		  ((eof-object? ch) ch)
		  ((char? ch) ch)
		  (else (raise-simple 'peek-character:data-error)))))
	   result)))


(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-exception
      'io:illegal-vector
      "")))
   ((and (complex? data) (not (real? data)))
    (raise
     (make-file-exception
      'io:illegal-complex-number
      "")))
   ((pair? data) (begin (check-read-data? (car data))
			(check-read-data? (cdr data))
			#t))
   (else
    (raise
     (make-file-exception
      'io:illegal-data-type
      "")))))    


(define (theme-read ip)
  (let ((data
  	 (guard (exc
  		 (else
  		  (raise
  		   (make-file-exception
  		    'read:io-error
  		    (i/o-error-filename exc)))))
  		(read ip))))
    (if (eof-object? data)
  	data
  	(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-filename 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)))

(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)))))))


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


(define (make-hash-table-with-size i-size)
  (make-hash-table i-size))

(define (theme-hashx-ref proc-hash proc-assoc hashtable obj-key obj-default)
  (let* ((raw-proc-hash
	  (lambda lst-args
	    (_i_call-proc proc-hash lst-args
			   (list _b_<object> _b_<integer>))))
	 (raw-proc-assoc
	  (lambda lst-args
	    (_i_call-proc proc-assoc lst-args
			   ;; Maybe the second type should be more exact.
			   (list _b_<object> _b_<object>))))
	 (o-res
	  (hashx-ref raw-proc-hash raw-proc-assoc hashtable obj-key
		     obj-default)))
    o-res))

(define (theme-hashx-exists? proc-hash proc-assoc hashtable obj-key)
  (let* ((raw-proc-hash
	  (lambda lst-args
	    (_i_call-proc proc-hash lst-args
			   (list _b_<object> _b_<integer>))))
	 (raw-proc-assoc
	  (lambda lst-args
	    (_i_call-proc proc-assoc lst-args
			   ;; Maybe the second type should be more exact.
			   (list _b_<object> _b_<object>))))
	 (o-res
	  (hashx-ref raw-proc-hash raw-proc-assoc hashtable obj-key '())))
    (not-null? o-res)))

(define (theme-hashx-set! proc-hash proc-assoc hashtable obj-key obj-value)
  (let* ((raw-proc-hash
	  (lambda lst-args
	    (_i_call-proc proc-hash lst-args
			   (list _b_<object> _b_<integer>))))
	 (raw-proc-assoc
	  (lambda lst-args
	    (_i_call-proc proc-assoc lst-args
			   ;; Maybe the second type should be more exact.
			   (list _b_<object> _b_<object>)))))
    (hashx-set! raw-proc-hash raw-proc-assoc hashtable obj-key obj-value)))

(define (theme-hashx-remove! proc-hash proc-assoc hashtable obj-key)
  (let* ((raw-proc-hash
	  (lambda lst-args
	    (_i_call-proc proc-hash lst-args
			   (list _b_<object> _b_<integer>))))
	 (raw-proc-assoc
	  (lambda lst-args
	    (_i_call-proc proc-assoc lst-args
			   ;; Maybe the second type should be more exact.
			   (list _b_<object> _b_<object>)))))
    (hashx-remove! raw-proc-hash raw-proc-assoc hashtable obj-key)))

(define (hash-count-elements ht)
  (hash-count (const #t) ht))


(define (theme-string-assoc str al) 
  (assert (string? str))
  (assoc str al string=?))


(define (theme-hash-for-each proc ht)
  (let ((pc-raw
	 (lambda l-args
	   (_i_call-proc proc l-args (list _b_<object> _b_<object>)))))
    (hash-for-each pc-raw ht)))


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

(define hash-contents hash)

(define theme-string-hash string-hash)



;; *** (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))))))))
