;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.
+(define with-throw-handler #f)
(let ()
;; Ideally we'd like to be able to give these default values for all threads,
;; even threads not created by Guile; but alack, that does not currently seem
(apply prev thrown-k args))))
(apply prev thrown-k args)))))
- (define! 'catch
- (lambda* (k thunk handler #:optional pre-unwind-handler)
- "Invoke @var{thunk} in the dynamic context of @var{handler} for
+ (set! catch
+ (lambda* (k thunk handler #:optional pre-unwind-handler)
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for
exceptions matching @var{key}. If thunk throws to the symbol
@var{key}, then @var{handler} is invoked this way:
@lisp
If it exits normally, Guile unwinds the stack and dynamic context
and then calls the normal (third argument) handler. If it exits
non-locally, that exit determines the continuation."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error "catch" 'wrong-type-arg
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (let ((tag (make-prompt-tag "catch")))
- (call-with-prompt
- tag
- (lambda ()
- (with-fluids
- ((%exception-handler
- (if pre-unwind-handler
- (custom-throw-handler tag k pre-unwind-handler)
- (default-throw-handler tag k))))
- (thunk)))
- (lambda (cont k . args)
- (apply handler k args))))))
-
- (define! 'with-throw-handler
- (lambda (k thunk pre-unwind-handler)
- "Add @var{handler} to the dynamic context as a throw handler
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "catch" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (let ((tag (make-prompt-tag "catch")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluids
+ ((%exception-handler
+ (if pre-unwind-handler
+ (custom-throw-handler tag k pre-unwind-handler)
+ (default-throw-handler tag k))))
+ (thunk)))
+ (lambda (cont k . args)
+ (apply handler k args))))))
+
+ (set! with-throw-handler
+ (lambda (k thunk pre-unwind-handler)
+ "Add @var{handler} to the dynamic context as a throw handler
for key @var{key}, then invoke @var{thunk}."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error "with-throw-handler" 'wrong-type-arg
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (with-fluids ((%exception-handler
- (custom-throw-handler #f k pre-unwind-handler)))
- (thunk))))
-
- (define! 'throw
- (lambda (key . args)
- "Invoke the catch form matching @var{key}, passing @var{args} to the
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "with-throw-handler" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (with-fluids ((%exception-handler
+ (custom-throw-handler #f k pre-unwind-handler)))
+ (thunk))))
+
+ (set! throw
+ (lambda (key . args)
+ "Invoke the catch form matching @var{key}, passing @var{args} to the
@var{handler}.
@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
If there is no handler at all, Guile prints an error and then exits."
- (if (not (symbol? key))
- ((exception-handler) 'wrong-type-arg "throw"
- "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
- (apply (exception-handler) key args)))))
+ (if (not (symbol? key))
+ ((exception-handler) 'wrong-type-arg "throw"
+ "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
+ (apply (exception-handler) key args)))))
\f
;;; {Deprecation}
;;;
-;;; Depends on: defmacro
-;;;
-(defmacro begin-deprecated forms
- (if (include-deprecated-features)
- `(begin ,@forms)
- `(begin)))
+(define-syntax begin-deprecated
+ (lambda (x)
+ (syntax-case x ()
+ ((_ form form* ...)
+ (if (include-deprecated-features)
+ #'(begin form form* ...)
+ #'(begin))))))
\f
(define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation)
-(defmacro false-if-exception (expr)
- `(catch #t
- (lambda ()
- ;; avoid saving backtraces inside false-if-exception
- (with-fluids ((the-last-stack (fluid-ref the-last-stack)))
- ,expr))
- (lambda args #f)))
+(define-syntax false-if-exception
+ (syntax-rules ()
+ ((_ expr)
+ (catch #t
+ (lambda () expr)
+ (lambda (k . args) #f)))))
\f
(define error
(case-lambda
(()
- (save-stack)
(scm-error 'misc-error #f "?" #f #f))
((message . args)
- (save-stack)
(let ((msg (string-join (cons "~A" (make-list (length args) "~S")))))
(scm-error 'misc-error #f msg (cons message args) #f)))))
(or (fluid-ref %stacks) '()))))
(thunk)))
(lambda (k . args)
- (%start-stack tag (lambda () (apply k args)))))))
+ (%start-stack tag (lambda () (apply k args)))))))
(define-syntax start-stack
(syntax-rules ()
((_ tag exp)
(catch #t
(lambda ()
(let* ((scmstat (stat name))
- (gostat (stat go-path #f)))
- (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
+ (gostat (stat go-path #f)))
+ (if (and gostat
+ (or (> (stat:mtime gostat) (stat:mtime scmstat))
+ (and (= (stat:mtime gostat) (stat:mtime scmstat))
+ (>= (stat:mtimensec gostat)
+ (stat:mtimensec scmstat)))))
go-path
(begin
(if gostat
;; Create a new module, perhaps with a particular size of obarray,
;; initial uses list, or binding procedure.
;;
-(define make-module
- (lambda args
-
- (define (parse-arg index default)
- (if (> (length args) index)
- (list-ref args index)
- default))
-
- (define %default-import-size
- ;; Typical number of imported bindings actually used by a module.
- 600)
+(define* (make-module #:optional (size 31) (uses '()) (binder #f))
+ (define %default-import-size
+ ;; Typical number of imported bindings actually used by a module.
+ 600)
+
+ (if (not (integer? size))
+ (error "Illegal size to make-module." size))
+ (if (not (and (list? uses)
+ (and-map module? uses)))
+ (error "Incorrect use list." uses))
+ (if (and binder (not (procedure? binder)))
+ (error
+ "Lazy-binder expected to be a procedure or #f." binder))
+
+ (let ((module (module-constructor (make-hash-table size)
+ uses binder #f macroexpand
+ #f #f #f
+ (make-hash-table %default-import-size)
+ '()
+ (make-weak-key-hash-table 31) #f
+ (make-hash-table 7) #f #f #f)))
+
+ ;; We can't pass this as an argument to module-constructor,
+ ;; because we need it to close over a pointer to the module
+ ;; itself.
+ (set-module-eval-closure! module (standard-eval-closure module))
- (if (> (length args) 3)
- (error "Too many args to make-module." args))
-
- (let ((size (parse-arg 0 31))
- (uses (parse-arg 1 '()))
- (binder (parse-arg 2 #f)))
-
- (if (not (integer? size))
- (error "Illegal size to make-module." size))
- (if (not (and (list? uses)
- (and-map module? uses)))
- (error "Incorrect use list." uses))
- (if (and binder (not (procedure? binder)))
- (error
- "Lazy-binder expected to be a procedure or #f." binder))
-
- (let ((module (module-constructor (make-hash-table size)
- uses binder #f macroexpand
- #f #f #f
- (make-hash-table %default-import-size)
- '()
- (make-weak-key-hash-table 31) #f
- (make-hash-table 7) #f #f #f)))
-
- ;; We can't pass this as an argument to module-constructor,
- ;; because we need it to close over a pointer to the module
- ;; itself.
- (set-module-eval-closure! module (standard-eval-closure module))
-
- module))))
+ module))
\f
(define (module-define-submodule! module name submodule)
(hashq-set! (module-submodules module) name submodule))
-\f
-
-;;; {Low Level Bootstrapping}
-;;;
-
-;; make-root-module
-
-;; A root module uses the pre-modules-obarray as its obarray. This
-;; special obarray accumulates all bindings that have been established
-;; before the module system is fully booted.
+;; It used to be, however, that module names were also present in the
+;; value namespace. When we enable deprecated code, we preserve this
+;; legacy behavior.
;;
-;; (The obarray continues to be used by code that has been closed over
-;; before the module system has been booted.)
-
-(define (make-root-module)
- (let ((m (make-module 0)))
- (set-module-obarray! m (%get-pre-modules-obarray))
- m))
-
-;; make-scm-module
-
-;; The root interface is a module that uses the same obarray as the
-;; root module. It does not allow new definitions, tho.
-
-(define (make-scm-module)
- (let ((m (make-module 0)))
- (set-module-obarray! m (%get-pre-modules-obarray))
- (set-module-eval-closure! m (standard-interface-eval-closure m))
- m))
-
+;; These shims are defined here instead of in deprecated.scm because we
+;; need their definitions before loading other modules.
+;;
+(begin-deprecated
+ (define (module-ref-submodule module name)
+ (or (hashq-ref (module-submodules module) name)
+ (and (module-submodule-binder module)
+ ((module-submodule-binder module) module name))
+ (let ((var (module-local-variable module name)))
+ (and var (variable-bound? var) (module? (variable-ref var))
+ (begin
+ (warn "module" module "not in submodules table")
+ (variable-ref var))))))
+
+ (define (module-define-submodule! module name submodule)
+ (let ((var (module-local-variable module name)))
+ (if (and var
+ (or (not (variable-bound? var))
+ (not (module? (variable-ref var)))))
+ (warn "defining module" module ": not overriding local definition" var)
+ (module-define! module name submodule)))
+ (hashq-set! (module-submodules module) name submodule)))
\f
(loop cur (car tail) (cdr tail)))))))
-(define (local-ref names) (nested-ref (current-module) names))
-(define (local-set! names val) (nested-set! (current-module) names val))
-(define (local-define names val) (nested-define! (current-module) names val))
-(define (local-remove names) (nested-remove! (current-module) names))
-(define (local-ref-module names) (nested-ref-module (current-module) names))
-(define (local-define-module names mod) (nested-define-module! (current-module) names mod))
+(define (local-ref names)
+ (nested-ref (current-module) names))
+
+(define (local-set! names val)
+ (nested-set! (current-module) names val))
+
+(define (local-define names val)
+ (nested-define! (current-module) names val))
+
+(define (local-remove names)
+ (nested-remove! (current-module) names))
+
+(define (local-ref-module names)
+ (nested-ref-module (current-module) names))
+
+(define (local-define-module names mod)
+ (nested-define-module! (current-module) names mod))
(define (set-system-module! m s)
(set-procedure-property! (module-eval-closure m) 'system-module s))
-(define the-root-module (make-root-module))
-(define the-scm-module (make-scm-module))
-(set-module-public-interface! the-root-module the-scm-module)
-(set-module-name! the-root-module '(guile))
-(set-module-name! the-scm-module '(guile))
-(set-module-kind! the-scm-module 'interface)
-(set-system-module! the-root-module #t)
-(set-system-module! the-scm-module #t)
+;; The root module uses the pre-modules-obarray as its obarray. This
+;; special obarray accumulates all bindings that have been established
+;; before the module system is fully booted.
+;;
+;; (The obarray continues to be used by code that has been closed over
+;; before the module system has been booted.)
+;;
+(define the-root-module
+ (let ((m (make-module 0)))
+ (set-module-obarray! m (%get-pre-modules-obarray))
+ (set-module-name! m '(guile))
+ (set-system-module! m #t)
+ m))
+
+;; The root interface is a module that uses the same obarray as the
+;; root module. It does not allow new definitions, tho.
+;;
+(define the-scm-module
+ (let ((m (make-module 0)))
+ (set-module-obarray! m (%get-pre-modules-obarray))
+ (set-module-eval-closure! m (standard-interface-eval-closure m))
+ (set-module-name! m '(guile))
+ (set-module-kind! m 'interface)
+ (set-system-module! m #t)
+ m))
+
+(set-module-public-interface! the-root-module the-scm-module)
\f
((_ opt val)
(options (append (options) (list 'opt val))))))))))
-(define-option-interface
- (eval-options-interface
- (eval-options eval-enable eval-disable)
- (eval-set!)))
-
(define-option-interface
(debug-options-interface
(debug-options debug-enable debug-disable)
;;; {Running Repls}
;;;
-(define (default-pre-unwind-handler key . args)
- ;; Narrow by two more frames: this one, and the throw handler.
- (save-stack 2)
- (apply throw key args))
-
-(define abort-hook (make-hook))
+(define *repl-stack* (make-fluid))
;; Programs can call `batch-mode?' to see if they are running as part of a
;; script or if they are running interactively. REPL implementations ensure that
;; `batch-mode?' returns #f during their extent.
;;
-;; Programs can re-enter batch mode, for example after a fork, by calling
-;; `ensure-batch-mode!'. This will also restore signal handlers. It's not a
-;; great interface, though; it would be better to abort to the outermost prompt,
-;; and call a thunk there.
-(define *repl-level* (make-fluid))
(define (batch-mode?)
- (negative? (or (fluid-ref *repl-level*) -1)))
-(define (ensure-batch-mode!)
- (fluid-set! *repl-level* #f)
- (restore-signals))
-
-;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
-(define before-signal-stack (make-fluid))
-;; FIXME: stack-saved? is broken in the presence of threads.
-(define stack-saved? #f)
-
-(define (save-stack . narrowing)
- (if (not stack-saved?)
- (begin
- (let ((stacks (fluid-ref %stacks)))
- (fluid-set! the-last-stack
- ;; (make-stack obj inner outer inner outer ...)
- ;;
- ;; In this case, cut away the make-stack frame, the
- ;; save-stack frame, and then narrow as specified by the
- ;; user, delimited by the nearest start-stack invocation,
- ;; if any.
- (apply make-stack #t
- 2
- (if (pair? stacks) (cdar stacks) 0)
- narrowing)))
- (set! stack-saved? #t))))
+ (null? (or (fluid-ref *repl-stack*) '())))
-(define before-error-hook (make-hook))
-(define after-error-hook (make-hook))
-(define before-backtrace-hook (make-hook))
-(define after-backtrace-hook (make-hook))
-
-(define has-shown-debugger-hint? #f)
-
-(define (handle-system-error key . args)
- (let ((cep (current-error-port)))
- (cond ((not (stack? (fluid-ref the-last-stack))))
- ((memq 'backtrace (debug-options-interface))
- (let ((highlights (if (or (eq? key 'wrong-type-arg)
- (eq? key 'out-of-range))
- (list-ref args 3)
- '())))
- (run-hook before-backtrace-hook)
- (newline cep)
- (display "Backtrace:\n")
- (display-backtrace (fluid-ref the-last-stack) cep
- #f #f highlights)
- (newline cep)
- (run-hook after-backtrace-hook))))
- (run-hook before-error-hook)
- (apply display-error (fluid-ref the-last-stack) cep args)
- (run-hook after-error-hook)
- (force-output cep)
- (throw 'abort key)))
+;; Programs can re-enter batch mode, for example after a fork, by calling
+;; `ensure-batch-mode!'. It's not a great interface, though; it would be better
+;; to abort to the outermost prompt, and call a thunk there.
+;;
+(define (ensure-batch-mode!)
+ (set! batch-mode? (lambda () #t)))
(define (quit . args)
(apply throw 'quit args))
(define (gc-run-time)
(cdr (assq 'gc-time-taken (gc-stats))))
+(define abort-hook (make-hook))
+(define before-error-hook (make-hook))
+(define after-error-hook (make-hook))
+(define before-backtrace-hook (make-hook))
+(define after-backtrace-hook (make-hook))
+
(define before-read-hook (make-hook))
(define after-read-hook (make-hook))
(define before-eval-hook (make-hook 1))
(define before-print-hook (make-hook 1))
(define after-print-hook (make-hook 1))
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(define repl-reader
;; Return a list of expressions that evaluate to the appropriate
;; arguments for resolve-interface according to SPEC.
-(eval-when
- (compile)
- (if (memq 'prefix (read-options))
- (error "boot-9 must be compiled with #:kw, not :kw")))
+(eval-when (compile)
+ (if (memq 'prefix (read-options))
+ (error "boot-9 must be compiled with #:kw, not :kw")))
(define (keyword-like-symbol->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
;; FIXME: we really need to clean up the guts of the module system.
;; We can compile to something better than process-define-module.
+;;
(define-syntax define-module
(lambda (x)
(define (keyword-like? stx)
(lambda ()
(module-re-export! (current-module) '(name ...))))))))
+(define-syntax export!
+ (syntax-rules ()
+ ((_ name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-replace! (current-module) '(name ...))))))))
+
(define-syntax export-syntax
(syntax-rules ()
((_ name ...)
;;; {Parameters}
;;;
-(define make-mutable-parameter
- (let ((make (lambda (fluid converter)
- (lambda args
- (if (null? args)
- (fluid-ref fluid)
- (fluid-set! fluid (converter (car args))))))))
- (lambda* (init #:optional (converter identity))
- (let ((fluid (make-fluid)))
- (fluid-set! fluid (converter init))
- (make fluid converter)))))
+(define* (make-mutable-parameter init #:optional (converter identity))
+ (let ((fluid (make-fluid)))
+ (fluid-set! fluid (converter init))
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((val) (fluid-set! fluid (converter val))))))
+
\f
(append (hashq-ref %cond-expand-table mod '())
features)))))
-(define-macro (cond-expand . clauses)
- (let ((syntax-error (lambda (cl)
- (error "invalid clause in `cond-expand'" cl))))
- (letrec
- ((test-clause
- (lambda (clause)
- (cond
- ((symbol? clause)
- (or (memq clause %cond-expand-features)
- (let lp ((uses (module-uses (current-module))))
- (if (pair? uses)
- (or (memq clause
- (hashq-ref %cond-expand-table
- (car uses) '()))
- (lp (cdr uses)))
- #f))))
- ((pair? clause)
- (cond
- ((eq? 'and (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #t)
- ((pair? l)
- (and (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'or (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #f)
- ((pair? l)
- (or (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'not (car clause))
- (cond ((not (pair? (cdr clause)))
- (syntax-error clause))
- ((pair? (cddr clause))
- ((syntax-error clause))))
- (not (test-clause (cadr clause))))
- (else
- (syntax-error clause))))
- (else
- (syntax-error clause))))))
- (let lp ((c clauses))
- (cond
- ((null? c)
- (error "Unfulfilled `cond-expand'"))
- ((not (pair? c))
- (syntax-error c))
- ((not (pair? (car c)))
- (syntax-error (car c)))
- ((test-clause (caar c))
- `(begin ,@(cdar c)))
- ((eq? (caar c) 'else)
- (if (pair? (cdr c))
- (syntax-error c))
- `(begin ,@(cdar c)))
- (else
- (lp (cdr c))))))))
+(define-syntax cond-expand
+ (lambda (x)
+ (define (module-has-feature? mod sym)
+ (or-map (lambda (mod)
+ (memq sym (hashq-ref %cond-expand-table mod '())))
+ (module-uses mod)))
+
+ (define (condition-matches? condition)
+ (syntax-case condition (and or not)
+ ((and c ...)
+ (and-map condition-matches? #'(c ...)))
+ ((or c ...)
+ (or-map condition-matches? #'(c ...)))
+ ((not c)
+ (if (condition-matches? #'c) #f #t))
+ (c
+ (identifier? #'c)
+ (let ((sym (syntax->datum #'c)))
+ (if (memq sym %cond-expand-features)
+ #t
+ (module-has-feature? (current-module) sym))))))
+
+ (define (match clauses alternate)
+ (syntax-case clauses ()
+ (((condition form ...) . rest)
+ (if (condition-matches? #'condition)
+ #'(begin form ...)
+ (match #'rest alternate)))
+ (() (alternate))))
+
+ (syntax-case x (else)
+ ((_ clause ... (else form ...))
+ (match #'(clause ...)
+ (lambda ()
+ #'(begin form ...))))
+ ((_ clause ...)
+ (match #'(clause ...)
+ (lambda ()
+ (syntax-violation 'cond-expand "unfulfilled cond-expand" x)))))))
;; This procedure gets called from the startup code with a list of
;; numbers, which are the numbers of the SRFIs to be loaded on startup.
;;; srfi-55: require-extension
;;;
-(define-macro (require-extension extension-spec)
- ;; This macro only handles the srfi extension, which, at present, is
- ;; the only one defined by the standard.
- (if (not (pair? extension-spec))
- (scm-error 'wrong-type-arg "require-extension"
- "Not an extension: ~S" (list extension-spec) #f))
- (let ((extension (car extension-spec))
- (extension-args (cdr extension-spec)))
- (case extension
- ((srfi)
- (let ((use-list '()))
- (for-each
- (lambda (i)
- (if (not (integer? i))
- (scm-error 'wrong-type-arg "require-extension"
- "Invalid srfi name: ~S" (list i) #f))
- (let ((srfi-sym (string->symbol
- (string-append "srfi-" (number->string i)))))
- (if (not (memq srfi-sym %cond-expand-features))
- (set! use-list (cons `(use-modules (srfi ,srfi-sym))
- use-list)))))
- extension-args)
- (if (pair? use-list)
- ;; i.e. (begin (use-modules x) (use-modules y) (use-modules z))
- `(begin ,@(reverse! use-list)))))
- (else
- (scm-error
- 'wrong-type-arg "require-extension"
- "Not a recognized extension type: ~S" (list extension) #f)))))
-
-\f
-
-;;; {Load emacs interface support if emacs option is given.}
-;;;
-
-(define (named-module-use! user usee)
- (module-use! (resolve-module user) (resolve-interface usee)))
-
-(define (load-emacs-interface)
- (and (provided? 'debug-extensions)
- (debug-enable 'backtrace))
- (named-module-use! '(guile-user) '(ice-9 emacs)))
+(define-syntax require-extension
+ (lambda (x)
+ (syntax-case x (srfi)
+ ((_ (srfi n ...))
+ (and-map integer? (syntax->datum #'(n ...)))
+ (with-syntax
+ (((srfi-n ...)
+ (map (lambda (n)
+ (datum->syntax x (symbol-append 'srfi- n)))
+ (map string->symbol
+ (map number->string (syntax->datum #'(n ...)))))))
+ #'(use-modules (srfi srfi-n) ...)))
+ ((_ (type arg ...))
+ (identifier? #'type)
+ (syntax-violation 'require-extension "Not a recognized extension type"
+ x)))))
\f
(lambda () (fluid-ref using-readline?))
(lambda (v) (fluid-set! using-readline? v)))))
-(define (top-repl)
- (let ((guile-user-module (resolve-module '(guile-user))))
-
- ;; Load emacs interface support if emacs option is given.
- (if (and (module-defined? guile-user-module 'use-emacs-interface)
- (module-ref guile-user-module 'use-emacs-interface))
- (load-emacs-interface))
-
- ;; Use some convenient modules (in reverse order)
-
- (set-current-module guile-user-module)
- (process-use-modules
- (append
- '(((ice-9 r5rs))
- ((ice-9 session))
- ((ice-9 debug)))
- (if (provided? 'regex)
- '(((ice-9 regex)))
- '())
- (if (provided? 'threads)
- '(((ice-9 threads)))
- '())))
- ;; load debugger on demand
- (module-autoload! guile-user-module '(system vm debug) '(debug))
-
- ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
- ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
- ;; no effect.
- (let ((old-handlers #f)
- ;; We can't use @ here, as modules have been booted, but in Guile's
- ;; build the srfi-1 helper lib hasn't been built yet, which will
- ;; result in an error when (system repl repl) is loaded at compile
- ;; time (to see if it is a macro or not).
- (start-repl (module-ref (resolve-module '(system repl repl))
- 'start-repl))
- (signals (if (provided? 'posix)
- `((,SIGINT . "User interrupt")
- (,SIGFPE . "Arithmetic error")
- (,SIGSEGV
- . "Bad memory access (Segmentation violation)"))
- '())))
- ;; no SIGBUS on mingw
- (if (defined? 'SIGBUS)
- (set! signals (acons SIGBUS "Bad memory access (bus error)"
- signals)))
-
- (dynamic-wind
-
- ;; call at entry
- (lambda ()
- (let ((make-handler (lambda (msg)
- (lambda (sig)
- ;; Make a backup copy of the stack
- (fluid-set! before-signal-stack
- (fluid-ref the-last-stack))
- (save-stack 2)
- (scm-error 'signal
- #f
- msg
- #f
- (list sig))))))
- (set! old-handlers
- (map (lambda (sig-msg)
- (sigaction (car sig-msg)
- (make-handler (cdr sig-msg))))
- signals))))
-
- ;; the protected thunk.
- (lambda ()
- (let ((status (start-repl 'scheme)))
- (run-hook exit-hook)
- status))
-
- ;; call at exit.
- (lambda ()
- (map (lambda (sig-msg old-handler)
- (if (not (car old-handler))
- ;; restore original C handler.
- (sigaction (car sig-msg) #f)
- ;; restore Scheme handler, SIG_IGN or SIG_DFL.
- (sigaction (car sig-msg)
- (car old-handler)
- (cdr old-handler))))
- signals old-handlers))))))
-
-;;; This hook is run at the very end of an interactive session.
-;;;
-(define exit-hook (make-hook))
-
\f
;;; {Deprecated stuff}
HCoop / bpt / guile.git / blobdiff