1 ; Guile-specific functions.
2 ; Copyright (C) 2000, 2004, 2009 Red Hat, Inc.
3 ; This file is part of CGEN.
4 ; See file COPYING.CGEN for details.
6 (define *guile-major-version* (string->number (major-version)))
7 (define *guile-minor-version* (string->number (minor-version)))
9 ; eval takes a module argument in 1.6 and later
11 (if (or (> *guile-major-version* 1)
12 (>= *guile-minor-version* 6))
14 (eval expr (current-module)))
19 ; symbol-bound? is deprecated in 1.6
21 (if (or (> *guile-major-version* 1)
22 (>= *guile-minor-version* 6))
23 (define (symbol-bound? table s)
25 (error "must pass #f for symbol-bound? first arg"))
26 ; FIXME: Not sure this is 100% correct.
27 (module-defined? (current-module) s))
30 (if (symbol-bound? #f 'load-from-path)
34 ;(load-from-path file)
35 (primitive-load-path file)
40 ; FIXME: to be deleted
44 (if (not (symbol-bound? #f '%stat))
50 (if (symbol-bound? #f 'debug-enable)
51 (debug-enable 'backtrace)
54 ; Guile 1.3 has reverse!, Guile 1.2 has list-reverse!.
56 (if (and (not (symbol-bound? #f 'reverse!))
57 (symbol-bound? #f 'list-reverse!))
58 (define reverse! list-reverse!)
61 (define (debug-write . objs)
63 ((if (string? o) display write) o (current-error-port)))
65 (newline (current-error-port)))
67 ;; Guile 1.8 no longer has "." in %load-path so relative path loads
70 (if (or (> *guile-major-version* 1)
71 (>= *guile-minor-version* 8))
72 (set! %load-path (append %load-path (list ".")))
76 ;;; Enabling and disabling debugging features of the host Scheme.
78 ;;; For the initial load proces, turn everything on. We'll disable it
79 ;;; before we start doing the heavy computation.
80 (if (memq 'debug-extensions *features*)
82 (debug-enable 'backtrace)
84 (debug-enable 'backwards)
85 (debug-set! depth 2000)
86 (debug-set! maxdepth 2000)
87 (debug-set! stack 100000)
88 (debug-set! frames 10)))
89 (read-enable 'positions)
91 ;;; Call THUNK, with debugging enabled if FLAG is true, or disabled if
94 ;;; (On systems other than Guile, this needn't actually do anything at
95 ;;; all, beyond calling THUNK, so long as your backtraces are still
96 ;;; helpful. In Guile, the debugging evaluator is slower, so we don't
97 ;;; want to use it unless the user asked for it.)
98 (define (cgen-call-with-debugging flag thunk)
99 (if (memq 'debug-extensions *features*)
100 ((if flag debug-enable debug-disable) 'debug))
102 ;; Now, make that debugging / no-debugging setting actually take
105 ;; Guile has two separate evaluators, one that does the extra
106 ;; bookkeeping for backtraces, and one which doesn't, but runs
107 ;; faster. However, the evaluation process (in either evaluator)
108 ;; ordinarily never consults the variable that says which evaluator
109 ;; to use: whatever evaluator was running just keeps rolling along.
110 ;; There are certain primitives, like some of the eval variants,
111 ;; that do actually check. start-stack is one such primitive, but
112 ;; we don't want to shadow whatever other stack id is there, so we
113 ;; do all the real work in the ID argument, and do nothing in the
114 ;; EXP argument. What a kludge.
115 (start-stack (begin (thunk) #t) #f))
118 ;;; Apply PROC to ARGS, marking that application as the bottom of the
119 ;;; stack for error backtraces.
121 ;;; (On systems other than Guile, this doesn't really need to do
122 ;;; anything other than apply PROC to ARGS, as long as something
123 ;;; ensures that backtraces will work right.)
124 (define (cgen-debugging-stack-start proc args)
126 ;; Naming this procedure, rather than using an anonymous lambda,
127 ;; allows us to pass less fragile cut info to save-stack.
128 (define (handler . args)
129 ;;(display args (current-error-port))
130 ;;(newline (current-error-port))
131 ;; display-error takes 6 arguments.
132 ;; If `quit' is called from elsewhere, it may not have 6
133 ;; arguments. Not sure how best to handle this.
134 (if (= (length args) 5)
136 (apply display-error #f (current-error-port) (cdr args))
137 ;; Grab a copy of the current stack,
138 (save-stack handler 0)
142 ;; Apply proc to args, and if any uncaught exception is thrown, call
143 ;; handler WITHOUT UNWINDING THE STACK (that's the 'lazy' part). We
144 ;; need the stack left alone so we can produce a backtrace.
147 ;; I have no idea why the 'load-stack' stack mark is
148 ;; not still present on the stack; we're still loading
149 ;; cgen-APP.scm, aren't we? But stack-id returns #f
150 ;; in handler if we don't do a start-stack here.
151 (start-stack proc (apply proc args)))