;;;;
;;;; runtime.stk        -- Stuff necessary for bootstaping the system
;;;;
;;;; Copyright © 2001-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 15-Mar-2001 22:49 (eg)
;;;;

;; ----------------------------------------------------------------------
;;
;; List functions
;;
;; ----------------------------------------------------------------------
(define caar   (lambda (x) (%cxr x #:aa)))
(define cdar   (lambda (x) (%cxr x #:ad)))
(define cadr   (lambda (x) (%cxr x #:da)))
(define cddr   (lambda (x) (%cxr x #:dd)))
(define caaar  (lambda (x) (%cxr x #:aaa)))
(define cdaar  (lambda (x) (%cxr x #:aad)))
(define cadar  (lambda (x) (%cxr x #:ada)))
(define cddar  (lambda (x) (%cxr x #:add)))
(define caadr  (lambda (x) (%cxr x #:daa)))
(define cdadr  (lambda (x) (%cxr x #:dad)))
(define caddr  (lambda (x) (%cxr x #:dda)))
(define cdddr  (lambda (x) (%cxr x #:ddd)))
(define caaaar (lambda (x) (%cxr x #:aaaa)))
(define cdaaar (lambda (x) (%cxr x #:aaad)))
(define cadaar (lambda (x) (%cxr x #:aada)))
(define cddaar (lambda (x) (%cxr x #:aadd)))
(define caadar (lambda (x) (%cxr x #:adaa)))
(define cdadar (lambda (x) (%cxr x #:adad)))
(define caddar (lambda (x) (%cxr x #:adda)))
(define cdddar (lambda (x) (%cxr x #:addd)))
(define caaadr (lambda (x) (%cxr x #:daaa)))
(define cdaadr (lambda (x) (%cxr x #:daad)))
(define cadadr (lambda (x) (%cxr x #:dada)))
(define cddadr (lambda (x) (%cxr x #:dadd)))
(define caaddr (lambda (x) (%cxr x #:ddaa)))
(define cdaddr (lambda (x) (%cxr x #:ddad)))
(define cadddr (lambda (x) (%cxr x #:ddda)))
(define cddddr (lambda (x) (%cxr x #:dddd)))

(define (map* fn . l)           ; A map which accepts dotted lists (arg lists
  (cond                         ; must be "isomorph")
   ((null? (car l)) '())
   ((pair? (car l)) (cons (apply fn      (map car l))
                          (apply map* fn (map cdr l))))
   (else            (apply fn l))))

(define (for-each* fn . l)      ; A for-each which accepts dotted lists (arg lists
  (cond                         ; must be "isomorph")
   ((null? (car l)) '())
   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
   (else            (apply fn l))))


(define (filter-map func . args)
  (filter (lambda (x) x)
          (apply map func args)))
#| example
  (filter-map (lambda (x) (and (number? x) (+ x 1)))
            '(1 2 foo "bar" 7))
|#

(define (append-map proc . args)
  (apply append (apply map proc args)))

(define (append-map! proc . args)
  (apply append! (apply map proc args)))


;; ----------------------------------------------------------------------
;;
;; SETTERS
;;
;; ----------------------------------------------------------------------
#|
<doc EXT setter
 * (setter proc)
 *
 * Returns the setter associated to a |proc|. Setters are defined in the
 * {{link-srfi 17}} document. A setter proc, can be used in a generalized
 * assignment, as described in |set!|.
 *
 * To associate |s| to the procedure |p|, use the following form:
 * @lisp
 * (set! (setter p) s)
 * @end lisp
 * For instance, we can write
 * @lisp
 * (set! (setter car) set-car!)
 * @end lisp
 *
 * The following standard procedures have pre-defined setters:
 * @lisp
 * (set! (car x) v)              == (set-car! x v)
 * (set! (cdr x) v)              == (set-cdr! x v)
 * (set! (string-ref x i) v)     == (string-set! x i v)
 * (set! (vector-ref x i) v)     == (vector-set! x i v)!
 * (set! (slot-ref x 'name) v)   == (slot-set! x 'name v)
 * (set! (struct-ref x 'name) v) == (struct-set! x 'name v)
 * (set! (list-ref x i) v)       == (list-set! x i v)
 * @end lisp
 * Furhermore, Parameter Objects (see _<<_parameter_objects>>_) are
 * their own setter:
 * @lisp
 * (real-precision)              => 15
 * (set! (real-precision) 12)
 * (real-precision)              => 12
 * @end lisp
doc>
|#
(define (setter proc)
  (if (or (generic? proc) (parameter? proc))
      proc
      (or (key-get (%procedure-plist proc) :setter #f)
          (error 'setter "no setter defined for ~S" proc))))


;; Initialize the setter of setter !!
(%set-procedure-plist!
         setter
         (list :setter
               (lambda (proc setter)
                 (%set-procedure-plist! proc
                                        (key-set! (%procedure-plist proc)
                                                  :setter
                                                  setter)))))

;; And now set some setter for primitive functions
(set! (setter car)              set-car!)
(set! (setter cdr)              set-cdr!)
(set! (setter vector-ref)       vector-set!)
(set! (setter string-ref)       string-set!)
(set! (setter slot-ref)         slot-set!)
(set! (setter struct-ref)       struct-set!)
(set! (setter list-ref)         list-set!)

;; ----------------------------------------------------------------------
;;      symbol-append
;; ----------------------------------------------------------------------
(define (symbol-append . args)
  (let loop ((args args)
             (res  ""))
    (if (null? args)
        (string->symbol res)
        (loop (cdr args)
              (string-append res (format "~a" (car args)))))))


;; ----------------------------------------------------------------------
;;      parameters
;; ----------------------------------------------------------------------
;; ----------------------------------------------------------------------
;; define-parameter
;; ----------------------------------------------------------------------
#|
<doc EXT-SYNTAX define-parameter
 * (define-parameter var val)
 * (define-parameter var val thunk)
 *
 * This form is a shortcut to define a new parameter named |var|. It also adds
 * a name to the created parameter object, which can be useful for debugging.
doc>
|#
(define-macro (define-parameter name . args)
  (if (<= 1 (length args) 2)
      (let ((tmp (gensym 'param)))
        `(define ,name (let ((,tmp (make-parameter ,@args)))
                         (%set-parameter-name! ,tmp ',name)
                         ,tmp)))
      (syntax-error 'define-parameter
               "bad number of arguments (must be 2 or 3)")))



#|
<doc EXT stklos-debug-level
 * (stklos-debug-level)
 *
 * |stklos-debug-level| is a parameter objet. It permits to know the current
 * debugging level. The default value of this parameter is 0 (meaning "no debug").
 * Note that the debugging level can also be set by the |--debug| option of the
 * |stklos(1)| command.
doc>
|#
(define-parameter stklos-debug-level 0
  (lambda (x)
    (if (integer? x) x (error 'stklos-debug-level "bad integer" x))))

;; ----------------------------------------------------------------------
;;      management of globals ...
;; ----------------------------------------------------------------------
;; This should be in compiler module but it a nightmare with bootstrap.
(define-parameter compiler-known-globals '())

(define (register-new-global! symbol)
  (let ((lst (compiler-known-globals)))
    (unless (memq symbol lst)
      (compiler-known-globals (cons symbol lst)))))


(define (register-new-globals! symbols)
  (let ((lst (compiler-known-globals)))
    (for-each (lambda (symbol)
                (unless (memq symbol lst)
                  (set! lst (cons symbol lst))))
              symbols)
    (compiler-known-globals lst)))

;; ----------------------------------------------------------------------
;;      Module management
;;----------------------------------------------------------------------
(define %modules-stack  '())
(define %module-create  (lambda (name)
                          (set! %modules-stack (cons (current-module)
                                                     %modules-stack))
                          (%create-module name)))

(define %module-restore (lambda ()
                          (let ((previous (car %modules-stack)))
                            (set! %modules-stack (cdr %modules-stack))
                            previous)))

(define %module-handler (lambda (c)
                          (let ((mod (%module-restore)))
                            ;; Push c on the module stack since env will be broken
                            ;; by the module reset!
                            (set! %modules-stack (cons c %modules-stack))
                            (%%set-current-module mod)
                            ;; Hack: Here %module-restore will get back the old c
                            (raise (%module-restore)))))

;; ----------------------------------------------------------------------
;;      A trace function, defined early to permit some traces
;;----------------------------------------------------------------------
(define (%debug fmt . args)
  (let ((out (current-error-port)))
    (display "\x1b;[33m" out)                  ;; yellow
    (display (apply format fmt args) out)
    (display  "\x1b;[0m" out)
    (newline out)))

(define (%trace . l)
  (when (> (stklos-debug-level) 0)
    (apply %debug l)))
