;;;;
;;;; boot.stk					-- Default boot file
;;;;
;;;; Copyright © 2000-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; 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)
;;;; Last file update: 10-Aug-2011 00:15 (eg)
;;;;

(include "runtime.stk")		; Definition necessary for the bootstrap
(include "module.stk")		; All the macros for defining modules
(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 "load.stk")		; Extended load dealing with paths and suffixes
(include "srfi-0.stk")		; Implementation of SRFI-0
(include "mbe.stk")		; A simple R5RS macro system
(include "regexp.stk")		; Regular expressions
(include "process.stk")		; Processes from Scheme
(include "compiler.stk")	; VM Compiler
(include "object.stk")		; CLOS like object system
(include "date.stk")		; Dates
(include "logical.stk")		; Logical operations
(include "thread.stk")		; Thread support
(include "ffi.stk")		; FFI support
(include "r7rs.stk")		; Preliminary support of R7RS
(include "obsolete.stk")	; Obsolete functions. Candidates to disappear
(include "repl.stk")		; Read Eval Print Loop
(include "readline.stk")	; Readline support
(include "repl-readline.stk")	; REL + readline
(import REPL REPL-READLINE)

;==============================================================================
(autoload	 "compfile"	  compile-file)
(autoload	 "describe"	  describe)
(syntax-autoload "bigmatch"	  match-case match-lambda)
(autoload	 "getopt"	  %print-usage)
(syntax-autoload "getopt"	  parse-arguments)
(syntax-autoload "trace"	  trace untrace)
(autoload	 "pp"		  pp pretty-print)
(autoload	 "env"		  null-environment scheme-report-environment
			          interaction-environment)
(autoload	 "help"		  help)
(autoload	 "lex-rt"	  lexer-next-token)
(syntax-autoload "scmpkg-support" interface)
(autoload	 "srfi-27"        random-integer random-real)
(syntax-autoload "srfi-34"        with-exception-handler guard)
(syntax-autoload "srfi-35"        define-condition-type condition)
(autoload	 "srfi-48"        srfi48:help srfi48:format-fixed)

;==============================================================================
;; Execute the REPL only if a file was not given on the command line
(define %before-exit-hook void)

;; A main function which will probably overloaded by the user
(define main void)


;; ----------------------------------------------------------------------
;; 	%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 " @ [~S:~S]\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 (string? name) (cdar bt))
		 ;; We have either a "pretty name" or a line information
		 (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)
  (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")
    (exit 70)))   ; 70 seems to be required by SRFI-22


;; ----------------------------------------------------------------------
;;	Scheme Module
;; ----------------------------------------------------------------------
;; The SCHEME module is 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 this is only partially true since bindings
;;; in SCHEME module are mutable
;;; Note that module SCHEME was already created before bootstrap

(let ((STklos (find-module 'STklos))
      (Scheme (find-module 'SCHEME)))

  ;; Register the options given as program args in the system state plist
  (set! *%system-state-plist* (append *%system-state-plist* *%program-args*))

  (%redefine-module-exports STklos Scheme)
  (%module-exports-set! Scheme (module-exports STklos)))


;; ----------------------------------------------------------------------
;;	option analysis and REPL launching
;; ----------------------------------------------------------------------
(let ((no-init (key-get *%program-args* :no-init-file #f))
      (ld      (key-get *%program-args* :load  #f))
      (file    (key-get *%program-args* :file #f))
      (expr    (key-get *%program-args* :sexpr #f))
      (confdir (key-get *%program-args* :conf-dir #f))
      (debug   (key-get *%program-args* :debug 0)))

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

  ;; 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
    (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 file" file c 2))
	    (load file)
	    ;; Try to execute the main procedure with the given arguments
	    (let ((ret-code (main (cons (program-name) (argv)))))
	      (%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