;;;;
;;;; boot.stk                                   -- Default boot file
;;;;
;;;; Copyright © 2000-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: 01-Jan-2000 15:04 (eg)
;;;;
 
;;
;; Following code is in the STklos module and is needed to ensure STklos
;; bootstrap
;;
(include "runtime.stk")         ; Definitions necessary for the bootstrap
(include "runtime-macros.stk")  ; Macros necessary for the bootstrap
(include "module.stk")          ; All the macros for defining modules

;; ----------------------------------------------------------------------
;;      SCHEME Module
;; ----------------------------------------------------------------------
;;
;; Start to build the SCHEME module. This module contains a copy of the STklos
;; module before the user may have the possibility to modify standard
;; bindings. If a module needs to be sure to have the original bindings, it
;; can import this module which will be visible before the STklos module.
;; Note that module SCHEME was already created in C, before loading this file<

;; 1. Populate the Scheme module with STklos bindings (C primitives, and runtime
;;    bindings)
;; 2. Set the export list of SCHEME to the one of STklos
(%populate-scheme-module)
(%module-exports-set! (find-module 'SCHEME)
                      (%module-exports (find-module 'STklos)))

;; NOTE: This include MUST be done early (and not earlier). See why.
(include "compiler.stk")        ; VM Compiler (this include MUST be done early)


(define-module SCHEME
  (include "r5rs.stk")            ; R5RS stuff written in Scheme
  (include "str.stk")             ; String functions UTF-8 aware
  (include "callcc.stk")          ; Call/cc support
  (include "struct.stk")          ; STklos structures
  (include "bonus.stk")           ; Extended functions and syntaxes
  (include "regexp.stk")          ; Regular expressions
  (include "process.stk")         ; Processes from Scheme
  (include "time.stk")            ; Dates & Time
  (include "logical.stk")         ; Logical operations
  (unless (eq? (%thread-system)
               'none)
    (include "thread.stk"))       ; Thread support
  (include "ffi.stk")             ; FFI support
  (include "r7rs.stk")            ; Support of R7RS
  (include "load.stk")            ; Extended load dealing with paths and suffixes
  (include "library.stk")         ; R7RS define-library
  (include "obsolete.stk")        ; Obsolete functions. Candidates to disappear
)

;;
;; The following included files (except "autoloads.stk") define their own
;; module. Autoloaods must be in a non locked module since, relay functions
;; are overloaded by their "true" definition.
;;
(include "object.stk")          ; CLOS like object system
(include "mbe.stk")             ; A simple R5RS macro system
(include "srfi-0.stk")          ; Implementation of SRFI-0
(include "repl.stk")            ; Read Eval Print Loop
(include "readline.stk")        ; Readline support
(include "repl-readline.stk")   ; REPL + readline
(include "autoloads.stk")       ; Autoloads functions

;;
;; Import these new modules in STklos
;;
(import STKLOS-OBJECT MBE SRFI-0 REPL REPL-READLINE)

;;
;; Add all the exported bindings in SCHEME module to STklos. Don't use import
;; here, since import makes new bindings read-only (and we want that bindings
;; in STklos can be broken if needed).
;;
(let ((STklos (find-module 'STklos))
      (SCHEME (find-module 'SCHEME)))
  (for-each (lambda(v) (%symbol-define v (symbol-value v SCHEME) STklos))
            (module-exports SCHEME)))

;;
;; Define common standard libraries to minimize file accesses at runtime
;;
(include "./scheme/base.stk")
(include "./scheme/write.stk")

;;
;; It's time to lock the SCHEME module, that is make bindings in it read-only
;; and forbid further definitions.
(define-module SCHEME
  (import STKLOS-COMPILER STKLOS-OBJECT MBE SRFI-0 REPL REPL-READLINE)

  ;; During he bootstap, the module SCHEME is present and all the definitions
  ;; made above (yes above!!), need an unlocked SCHEME module. So, the module
  ;; SCHEME is closed only for user programs (in this case STKLOS_BUILDING is
  ;; not defined)
  (unless (getenv "STKLOS_BUILDING")
    ;; We are not bootstapping
    (module-immutable! (current-module))))


;; ======================================================================
;;
;; Define exception handlers, analyze options
;;
;; Execute the REPL only if a file was not given on the command line
;; ======================================================================

(define %before-exit-hook void)
(define main void) ;; A main function which will probably overloaded by the user

;; ----------------------------------------------------------------------
;;      %display-backtrace ...
;; ----------------------------------------------------------------------
(define (%display-backtrace bt useless-frames)
  (define (hack-bt)
    ;; Backtrace show things that the user probably don't need to see
    ;; (the internal of the repl in particular. Delete the bottom of the stack
    ;; and replace it by EVAL
    (if (>= (length bt) useless-frames)
        (let ((bt (list-tail (reverse bt) useless-frames)))
          (reverse! (cons (cons eval #f) bt)))
        bt))

  (define (limit-bt bt)
    (let ((depth (or (let ((x (getenv "STKLOS_FRAMES")))
                       (and x (string->number x)))
                     10))
          (len (length bt)))
      (if (and (> depth 0) (> len depth))
          (reverse!
           (cons "  - ...\nSet shell variable STKLOS_FRAMES to set visible frames\n"
                 (list-tail (reverse! bt) (- len depth))))
          bt)))

  (let ((p (current-error-port)))
    (for-each (lambda (x)
                (if (string? x)
                    (display x p)
                    (begin
                      (display "  - " p)
                      ;; Print the procedure name
                      (let ((who (car x)))
                        (display (cond
                                   ((procedure? who) (%procedure-name who))
                                   ((not who)        "<<let/call>>")
                                   (else             who))
                                 p))
                      ;; Print (eventually) the position
                      (if (cdr x)
                          (format p " @ [~A:~A]\n" (cadr x) (cddr x))
                          (newline p)))))
              (limit-bt (hack-bt)))
    (flush-output-port p)))

;; ----------------------------------------------------------------------
;;      %build-error-location ...
;; ----------------------------------------------------------------------
(define (%build-error-location who bt)
  (if who
      (list who
            (if (null? bt) #f (cdar bt)))
      (let Loop ((bt bt) (info #f))
        (cond
          ((null? bt)
           (list "???" #f))
          ((procedure? (caar bt))
           (let ((name (%procedure-name (caar bt))))
             (if (or (and (string? name) (not (string=? name "error")))
                     (cdar bt))
                 ;; We have either a "pretty name" or a line information
                 ;; Note: if name is "error", the real culprit is probably
                 ;; below in the backtrace => skip this element
                 (list name
                       (or info (cdar bt)))
                 ;; Nothing interesting, continue to go down the stack
                 (Loop (cdr bt) info))))
          ((not (caar bt))
           ;; We have a let. Go down the stack (but keep the info -- if this
           ;; is the first time we have an info)
           (Loop (cdr bt)
                 (or info (cdar bt))))))))

;; ----------------------------------------------------------------------
;;      %simple-fatal-exception-handler ...
;; ----------------------------------------------------------------------
(define (%simple-fatal-exception-handler what who c useless-frames)
  ;; We arrive here when we have a not caught exception
  ;; Two cases:
  ;;  - if condition is of type &exit-r7rs, we come from a call to exit
  ;;    => run the %pre-exit functions and exit
  ;;  - else we are in serious trouble => display a message and abort

  ;;  Case 1: Is it a simple R7RS exit call
  (when (and (condition? c) (condition-has-type? c &exit-r7rs))
    (let ((retcode (condition-ref c 'retcode)))
      (%pre-exit retcode)
      (emergency-exit retcode)))

  ;; Case 2: A really unattended condition
  (let ((port (current-error-port))
        (bt   #f))
    ;; Display the message
    (format port "**** Error while ~A ~S\n" what who)
    (when (condition? c)
      (when (condition-has-type? c &error-message)
        (set! bt (condition-ref c 'backtrace)) ;; will be displayed later
        (let ((loc (%build-error-location #f bt)))
          (format port "\t Where: in ~A" (car loc))
          (when (cadr loc)
            (format port " (near line ~a in file ~s)" (cdadr loc) (caadr loc)))
          (newline port)))
      (when (condition-has-type? c &message)
        (format port "\tReason: ~A\n" (condition-ref c 'message))))
    ;; Show a backtrace
    (newline port)
    (when bt
      (%display-backtrace bt useless-frames))
    (format port "EXIT\n")
    (emergency-exit 70)))   ; 70 seems to be required by SRFI-22


;; ----------------------------------------------------------------------
;;      Set the default module for the compiler to (current-module)
;; ----------------------------------------------------------------------
(compiler-current-module (current-module))

;; ----------------------------------------------------------------------
;;      option analysis and REPL launching
;; ----------------------------------------------------------------------
(let ((no-init (key-get *%system-state-plist* :no-init-file #f))
      (ld      (key-get *%system-state-plist* :load  #f))
      (s176    (key-get *%system-state-plist* :srfi-176 #f))
      (file    (key-get *%system-state-plist* :file #f))
      (expr    (key-get *%system-state-plist* :sexpr #f))
      (confdir (key-get *%system-state-plist* :conf-dir #f))
      (debug   (key-get *%system-state-plist* :debug 0))
      (cflags  (key-get *%system-state-plist* :comp-flags #f))
      (Idirs   (key-get *%system-state-plist* :prepend-dirs '()))
      (Adirs   (key-get *%system-state-plist* :append-dirs '())))

  ;; Test if we have the -V flag (SRFI-176 version flag)
  (when s176
    (for-each (lambda (line)
                (write line)
                (newline))
              (version-alist))
    (flush-output-port (current-output-port))
    (emergency-exit 0))

  ;; Set the configuration directory if needed
  (when confdir
    (%stklos-conf-dir confdir))

  ;; Set compiler flags
  (when cflags
    (%compiler-set-flags cflags))

  ;; Add the paths given in the -I and -A options
  (unless (and (null? Idirs) (null? Adirs))
    (load-path (append Idirs
                       (load-path)
                       (reverse Adirs))))

  ;; Look at the debug flag
  (when (> debug 0)
    (stklos-debug-level debug)
    (compiler:warn-use-undefined #t)    ; Signal usage of still undefined symbols
    (compiler:gen-line-number #t)       ; Generate line numbers
    (compiler:keep-source #t)           ; Keep function source
    (when (> debug 1)                   ; Load-verbose when debug >= 2
      (load-verbose debug)))

  ;; Eventually try to create the configuratioon directory
  (let ((dir (%stklos-conf-dir)))
    (unless (file-is-directory? dir)
      (with-handler
       (lambda (c)
         (eprintf "Warning: cannot create configuration directory ~S\n" dir))
       (make-directories dir))))

  ;; Try to load the user initialization file except if "--no-init-file"
  (unless no-init
    (try-load (%stklos-conf-file "stklosrc")))

  (when ld
    ;; "--load" option
    (with-handler
      (lambda (c) (%simple-fatal-exception-handler "loading file" ld c 7))
      (load ld)))

  (cond
    ;; "--file" option
    (file (with-handler
           (lambda (c) (%simple-fatal-exception-handler "executing command"
                                                   (cons file (command-args)) c 2))
            (load file)
            ;; Try to execute the main procedure with the given arguments
            (let ((ret-code (main (cons (program-name) (command-args)))))
              (%before-exit-hook)
              (if (integer? ret-code) ret-code 0))))
    ;; "--expression" option
    (expr (with-handler
            (lambda (c) (%simple-fatal-exception-handler "evaluating" expr c 4))
            (eval (read-from-string expr))
            0))
    (else  ;; Try to initialize GNU readline and starts the main REPL
           (try-initialize-repl-with-readline)
           (main-repl))))

; LocalWords:  VM EVAL SRFI REPL
