
;; Copyright (C) 2008-2019, 2022, 2025, 2026 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!
            _b_vector-length
            theme-string-match
            integer->real
            theme-round
            theme-truncate
            theme-floor
            theme-ceiling
            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-standard-output-port
            theme-standard-error-port
            theme-standard-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
            theme-apply-append
            load-module
            module-var-exists?
            _vector-raw-contents
            _vector-with-raw-contents0
            _mutable-vector-with-raw-contents0
            check-source-expr))


(eval-when (expand load eval)
           (use-modules ((rnrs) #:select (assert))))

(use-modules (rnrs exceptions))
(use-modules (rnrs conditions))
(use-modules (rnrs base))
(use-modules (rnrs lists))
(use-modules (rnrs io ports))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-43))
(use-modules (ice-9 regex))
(use-modules (oop goops))

(use-modules (th-scheme-utilities stdutils))
(use-modules (theme-d runtime theme-d-support))
(use-modules (theme-d runtime runtime-theme-d-environment))
(use-modules (theme-d runtime rte-base))
(use-modules (theme-d runtime rte-object))
(use-modules (theme-d runtime rte-vectors))
(use-modules (theme-d runtime rte-globals))


(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 vec i)
  (vector-ref (slot-ref vec 'v-field-values) i))


(define (_i_mutable-vector-ref vec i)
  (vector-ref (slot-ref vec 'v-field-values) i))


(define (_i_mutable-vector-set! vec i item)
  ;; The result of this procedure is undefined.
  (vector-set! (slot-ref vec 'v-field-values) i item))


(define (_b_vector-length vec)
  (vector-length (slot-ref vec 'v-field-values)))


(define (theme-string-match str-pattern str-source)
  (let ((match-result (string-match str-pattern str-source)))
    (if (regexp-match? match-result)
      (let ((str-sub (match:substring match-result))
            (i-start (match:start match-result))
            (i-end (match:end match-result)))
        (if (and (string? str-sub)
                 (is-integer? i-start)
                 (is-integer? i-end))
          (list str-sub i-start i-end)
          (raise (make-theme-d-condition
                  'theme-string-match:internal-error
                  (list (cons 'str-pattern str-pattern)
                        (cons 'str-source str-source))))))
      (begin
       (assert (eq? match-result #f))
       '()))))


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


(define (theme-round r)
  (real->integer (r-round r)))


(define (theme-truncate r)
  (real->integer (r-truncate r)))


(define (theme-floor r)
  (real->integer (r-floor r)))


(define (theme-ceiling r)
  (real->integer (r-ceiling r)))


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


;; The _i_call-proc calls in the following two procedures take procedure
;; arguments so the unit type dispatch argument has no effect.


(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)
                             #f))))))
    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)
                             #f))))))
    result))


(define (theme-with-exception-handler proc-handler proc-body)
  (with-exception-handler
    (lambda (variable)
      (_i_call-simple-proc proc-handler (list variable)))
    (lambda ()
      (_i_call-simple-proc proc-body '()))))


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


(define (real-to-rational-impl r)
  (let* ((nr-result (inexact->exact r))
         (i-numer (numerator nr-result))
         (i-denom (denominator nr-result)))
    (if (and (is-integer? i-numer) (is-integer? i-denom))
      (cons (numerator nr-result) (denominator nr-result))
      (raise (make-theme-d-condition 'real-to-rational-impl:internal-error
                                     (list (cons 'r-value r)))))))


;; *** (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-source-expr data)
  (cond
    ((or (symbol? data)
         (boolean? data)
         (is-real? data)
         (is-integer? data)
         (string? data)
         (char? data)
         (null? data)
         (keyword? data))
     #t)
    ((vector? data)
     (raise
      (make-theme-d-condition
       'source-expr:illegal-vector
       '())))
    ((and (complex? data) (not (real? data)))
     (raise
      (make-theme-d-condition
       'source-expr:illegal-complex-number
       '())))
    ((pair? data) (begin (check-source-expr (car data))
                         (check-source-expr (cdr data))
                         #t))
    (else
     (raise
      (make-theme-d-condition
       'source-expr: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-source-expr 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 ""))))
         (let ((port (current-output-port)))
           (if (output-port? port)
             port
             (raise-simple 'theme-current-output-port:internal-error)))))


(define (theme-current-error-port)
  (guard (exc (else
               (raise (make-file-exception
                       'current-error-port:runtime-error ""))))
         (let ((port (current-error-port)))
           (if (output-port? port)
             port
             (raise-simple 'theme-current-error-port:internal-error)))))


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


(define (theme-standard-output-port)
  (let ((port (standard-output-port)))
    (if (output-port? port)
      port
      (raise-simple 'theme-standard-output-port:internal-error))))


(define (theme-standard-error-port)
  (let ((port (standard-error-port)))
    (if (output-port? port)
      port
      (raise-simple 'theme-standard-error-port:internal-error))))


(define (theme-standard-input-port)
  (let ((port (standard-input-port)))
    (if (input-port? port)
      port
      (raise-simple 'theme-standard-input-port:internal-error))))


;; The _i_call-proc calls in the following two procedures don't take
;; primitive class arguments so the unit type dispatch argument has no
;; effect.


(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))
                          #f)))))
    (check-source-expr 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))
                   #f))))


;; *** (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)
  (hashq-ref gl-ht-goops-classes clas))


(define (reverse-get-goops-class clas)
  (let ((o (reverse-search-goops-class clas)))
    (if (not (eq? o #f))
      (if (is-a? o <class>)
        o
        (raise (make-theme-d-condition 'internal-error-with-goops-class
                                       (list (cons 'cl clas)))))
      (raise (make-theme-d-condition 'undefined-goops-class
                                     (list (cons 'cl clas)))))))


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


;; Disabling unit type dispatch in these procedures may not be the best
;; alternative but module hash-table0 is deprecated, anyway.


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

(define (theme-hashx-ref
         %key %value %default
         proc-hash proc-assoc hashtable obj-key obj-default)
  (let* ((raw-proc-hash
          (lambda lst-args
            (_i_call-proc proc-hash lst-args (list %key _b_<integer>) #f)))
         (raw-proc-assoc
          (lambda lst-args
            (_i_call-proc proc-assoc lst-args
                          (list %key
                                (_i_make-concrete-uniform-list
                                 (_i_make-pair-class-inst %key %value)))
                          #f)))
         (o-res
          (hashx-ref raw-proc-hash raw-proc-assoc hashtable obj-key
                     obj-default)))
    o-res))

(define (theme-hashx-exists? %key %value
                             proc-hash proc-assoc hashtable obj-key)
  (let* ((raw-proc-hash
          (lambda lst-args
            (_i_call-proc proc-hash lst-args (list %key _b_<integer>) #f)))
         (raw-proc-assoc
          (lambda lst-args
            (_i_call-proc proc-assoc lst-args
                          (list %key
                                (_i_make-concrete-uniform-list
                                 (_i_make-pair-class-inst %key %value)))
                          #f)))
         (o-res
          (hashx-ref raw-proc-hash raw-proc-assoc hashtable obj-key '())))
    (not-null? o-res)))

(define (theme-hashx-set! %key %value
                          proc-hash proc-assoc hashtable obj-key obj-value)
  ;; (display "theme-hashx-set! ENTER\n")
  (let* ((raw-proc-hash
          (lambda lst-args
            ;; (display "raw-proc-hash\n")
            ;; (display (length lst-args))
            ;; (newline)
            (_i_call-proc proc-hash lst-args (list %key _b_<integer>) #f)))
         (raw-proc-assoc
          (lambda lst-args
            ;; (display "raw-proc-assoc\n")
            ;; (display (length lst-args))
            ;; (newline)
            (_i_call-proc proc-assoc lst-args
                          (list %key
                                (_i_make-concrete-uniform-list
                                 (_i_make-pair-class-inst %key %value)))
                          #f))))
    (hashx-set! raw-proc-hash raw-proc-assoc hashtable obj-key obj-value)))

(define (theme-hashx-remove! %key %value
                             proc-hash proc-assoc hashtable obj-key)
  (let* ((raw-proc-hash
          (lambda lst-args
            (_i_call-proc proc-hash lst-args (list %key _b_<integer>) #f)))
         (raw-proc-assoc
          (lambda lst-args
            (_i_call-proc proc-assoc lst-args
                          (list %key
                                (_i_make-concrete-uniform-list
                                 (_i_make-pair-class-inst %key %value)))
                          #f))))
    (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 %key %value proc ht)
  (let ((pc-raw
         (lambda l-args
           (_i_call-proc proc l-args (list %key %value) #f))))
    (hash-for-each pc-raw ht)))


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

(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 (is-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))
         (r-result
          (cond
            ((is-integer? nr) (exact->inexact nr))
            ((rational? nr) (exact->inexact nr))
            ((is-real? nr) nr)
            (else
             (raise (make-theme-d-condition 'string-to-real-conv-error
                                            (list (cons 'str str))))))))
    (if (is-real? r-result)
      r-result
      (raise (make-theme-d-condition 'theme-string->real:internal-error
                                     (list (cons 'str str)))))))


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


(define (theme-apply-append l)
  (apply append l))


;; *** (standard-library plugins) ***


(define (load-module l-s-module)
  (resolve-module l-s-module #:ensure #f))


(define (module-var-exists? mod s-var-name)
  (if (module-variable mod s-var-name) #t #f))


;; *** (standard-library raw-vector) ***


;; Result type checking is handled by importing the procedure to Theme-D
;; using prim-proc.
(define (_vector-raw-contents v)
  (slot-ref v 'v-field-values))


(define (_vector-with-raw-contents0 tt-component rv)
  (if (vector-every
       (lambda (x) (is-instance? x tt-component))
       rv)
    (let ((cl (_i_make-param-class-inst1 _b_:vector (list tt-component))))
      (make <rte-object> #:rcl-actual cl #:v-field-values rv))
    (raise (make-theme-d-condition 'raw-vector-component-type-mismatch '()))))


(define (_mutable-vector-with-raw-contents0 tt-component rv)
  (if (vector-every
       (lambda (x) (is-instance? x tt-component))
       rv)
    (let ((cl (_i_make-param-class-inst1 _b_:mutable-vector
                                         (list tt-component))))
      (make <rte-object> #:rcl-actual cl #:v-field-values rv))
    (raise (make-theme-d-condition 'raw-vector-component-type-mismatch '()))))
