boot.stk 11.1 KB
Newer Older
eg's avatar
eg committed
1
;;;;
Erick's avatar
Erick committed
2
;;;; boot.stk                                   -- Default boot file
3
;;;;
Erick's avatar
Erick committed
4
;;;; Copyright © 2000-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
5 6
;;;;
;;;;
eg's avatar
eg committed
7 8 9 10
;;;; 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.
11
;;;;
eg's avatar
eg committed
12 13 14 15
;;;; 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.
16
;;;;
eg's avatar
eg committed
17 18
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
19
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
eg's avatar
eg committed
20
;;;; USA.
21
;;;;
eg's avatar
eg committed
22 23
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 01-Jan-2000 15:04 (eg)
24
;;;; Last file update: 27-Nov-2018 14:16 (eg)
eg's avatar
eg committed
25 26
;;;;

Erick's avatar
Erick committed
27 28 29 30 31 32 33 34 35 36 37 38
(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
39
(include "equiv.stk")           ; equivalence of circular structures
Erick's avatar
Erick committed
40 41 42 43 44 45 46 47 48 49 50
(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
51
(import REPL REPL-READLINE)
52

eg's avatar
eg committed
53
;==============================================================================
Erick's avatar
Erick committed
54 55 56 57 58 59 60 61 62 63 64
(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)
Erick Gallesio's avatar
Erick Gallesio committed
65
(syntax-autoload "scmpkg-support" interface)
Erick's avatar
Erick committed
66
(autoload        "srfi-27"        random-integer random-real)
67 68
(syntax-autoload "srfi-34"        with-exception-handler guard)
(syntax-autoload "srfi-35"        define-condition-type condition)
Erick's avatar
Erick committed
69
(autoload        "srfi-48"        srfi48:help srfi48:format-fixed)
eg's avatar
eg committed
70 71 72 73 74 75 76 77 78 79

;==============================================================================
;; 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)


;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
80
;;      %display-backtrace ...
eg's avatar
eg committed
81 82 83 84 85 86 87
;; ----------------------------------------------------------------------
(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)
Erick's avatar
Erick committed
88 89 90
        (let ((bt (list-tail (reverse bt) useless-frames)))
          (reverse! (cons (cons eval #f) bt)))
        bt))
eg's avatar
eg committed
91 92 93

  (define (limit-bt bt)
    (let ((depth (or (let ((x (getenv "STKLOS_FRAMES")))
Erick's avatar
Erick committed
94 95 96
                       (and x (string->number x)))
                     10))
          (len (length bt)))
eg's avatar
eg committed
97
      (if (and (> depth 0) (> len depth))
Erick's avatar
Erick committed
98 99 100 101
          (reverse!
           (cons "  - ...\nSet shell variable STKLOS_FRAMES to set visible frames\n"
                 (list-tail (reverse! bt) (- len depth))))
          bt)))
102

eg's avatar
eg committed
103 104
  (let ((p (current-error-port)))
    (for-each (lambda (x)
Erick's avatar
Erick committed
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
                (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)))
eg's avatar
eg committed
121 122 123
    (flush-output-port p)))

;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
124
;;      %build-error-location ...
eg's avatar
eg committed
125 126 127 128
;; ----------------------------------------------------------------------
(define (%build-error-location who bt)
  (if who
      (list who
Erick's avatar
Erick committed
129
            (if (null? bt) #f (cdar bt)))
130
      (let Loop ((bt bt) (info #f))
Erick's avatar
Erick committed
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
        (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))))))))
eg's avatar
eg committed
147 148

;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
149
;;      %simple-fatal-exception-handler ...
eg's avatar
eg committed
150 151
;; ----------------------------------------------------------------------
(define (%simple-fatal-exception-handler what who c useless-frames)
Erick's avatar
Erick committed
152 153 154 155 156 157 158 159 160 161 162 163 164
  ;; We arrive her when we have an exception not catched.
  ;; Two cases:
  ;;  - if condition is of type &exit-r7rs, we come form a call to exit
  ;;    => run the %pre-exit functions and exit
  ;;  - else we are in serious trouble => display an 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
eg's avatar
eg committed
165
  (let ((port (current-error-port))
Erick's avatar
Erick committed
166
        (bt   #f))
167
    ;; Display the message
eg's avatar
eg committed
168 169 170
    (format port "**** Error while ~A ~S\n" what who)
    (when (condition? c)
      (when (condition-has-type? c &error-message)
Erick's avatar
Erick committed
171 172 173 174 175 176
        (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)))
eg's avatar
eg committed
177
      (when (condition-has-type? c &message)
Erick's avatar
Erick committed
178
        (format port "\tReason: ~A\n" (condition-ref c 'message))))
eg's avatar
eg committed
179
    ;; Show a backtrace
180
    (newline port)
eg's avatar
eg committed
181 182 183 184 185 186
    (when bt
      (%display-backtrace bt useless-frames))
    (format port "EXIT\n")
    (exit 70)))   ; 70 seems to be required by SRFI-22


187
;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
188
;;      Scheme Module
189 190 191 192 193 194 195
;; ----------------------------------------------------------------------
;; 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
196
;;; Note that module SCHEME was already created before bootstrap
197 198 199

(let ((STklos (find-module 'STklos))
      (Scheme (find-module 'SCHEME)))
200 201 202 203

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

204 205 206 207
  (%redefine-module-exports STklos Scheme)
  (%module-exports-set! Scheme (module-exports STklos)))


eg's avatar
eg committed
208
;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
209
;;      option analysis and REPL launching
eg's avatar
eg committed
210 211 212 213
;; ----------------------------------------------------------------------
(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))
Erick Gallesio's avatar
.  
Erick Gallesio committed
214
      (expr    (key-get *%program-args* :sexpr #f))
215
      (confdir (key-get *%program-args* :conf-dir #f))
Erick Gallesio's avatar
.  
Erick Gallesio committed
216
      (debug   (key-get *%program-args* :debug 0)))
eg's avatar
eg committed
217

Erick's avatar
Erick committed
218 219 220
  ;; Set the configuration if needed
  (when confdir
    (%stklos-conf-dir confdir))
221

Erick Gallesio's avatar
.  
Erick Gallesio committed
222 223
  ;; Look at the debug flag
  (when (> debug 0)
224
    (stklos-debug-level debug)
Erick's avatar
Erick committed
225 226 227
    (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
228
      (load-verbose debug)))
229 230 231 232 233 234

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

eg's avatar
eg committed
238 239
  ;; Try to load the user initialization file except if "--no-init-file"
  (unless no-init
240
    (try-load (%stklos-conf-file "stklosrc")))
241

eg's avatar
eg committed
242
  (when ld
243
    ;; "--load" option
eg's avatar
eg committed
244 245 246
    (with-handler
      (lambda (c) (%simple-fatal-exception-handler "loading file" ld c 7))
      (load ld)))
247

248 249 250
  (cond
    ;; "--file" option
    (file (with-handler
Erick's avatar
Erick committed
251 252 253 254 255 256
            (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))))
257 258
    ;; "--expression" option
    (expr (with-handler
Erick's avatar
Erick committed
259 260 261
            (lambda (c) (%simple-fatal-exception-handler "evaluating" expr c 4))
            (eval (read-from-string expr))
            0))
262 263
    (else  ;; Try to initialize GNU readline and starts the main REPL
           (try-initialize-repl-with-readline)
264
           (main-repl))))
eg's avatar
eg committed
265 266 267


; LocalWords:  VM EVAL SRFI REPL