cgen/guile.scm

   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.
   5
   6 (define *guile-major-version* (string->number (major-version)))
   7 (define *guile-minor-version* (string->number (minor-version)))
   8
   9 ; eval takes a module argument in 1.6 and later
  10
  11 (if (or (> *guile-major-version* 1)
  12         (>= *guile-minor-version* 6))
  13     (define (eval1 expr)
  14       (eval expr (current-module)))
  15     (define (eval1 expr)
  16       (eval expr))
  17 )
  18
  19 ; symbol-bound? is deprecated in 1.6
  20
  21 (if (or (> *guile-major-version* 1)
  22         (>= *guile-minor-version* 6))
  23     (define (symbol-bound? table s)
  24       (if table
  25           (error "must pass #f for symbol-bound? first arg"))
  26       ; FIXME: Not sure this is 100% correct.
  27       (module-defined? (current-module) s))
  28 )
  29
  30 (if (symbol-bound? #f 'load-from-path)
  31     (begin
  32       (define (load file)
  33         (begin
  34           ;(load-from-path file)
  35           (primitive-load-path file)
  36           ))
  37       )
  38 )
  39
  40 ; FIXME: to be deleted
  41 (define =? =)
  42 (define >=? >=)
  43
  44 (if (not (symbol-bound? #f '%stat))
  45     (begin
  46       (define %stat stat)
  47       )
  48 )
  49
  50 (if (symbol-bound? #f 'debug-enable)
  51     (debug-enable 'backtrace)
  52 )
  53
  54 ; Guile 1.3 has reverse!, Guile 1.2 has list-reverse!.
  55 ; CGEN uses reverse!
  56 (if (and (not (symbol-bound? #f 'reverse!))
  57          (symbol-bound? #f 'list-reverse!))
  58     (define reverse! list-reverse!)
  59 )
  60
  61 (define (debug-write . objs)
  62   (map (lambda (o)
  63          ((if (string? o) display write) o (current-error-port)))
  64        objs)
  65   (newline (current-error-port)))
  66
  67 ;; Guile 1.8 no longer has "." in %load-path so relative path loads
  68 ;; no longer work.
  69
  70 (if (or (> *guile-major-version* 1)
  71         (>= *guile-minor-version* 8))
  72     (set! %load-path (append %load-path (list ".")))
  73 )
  74
  75 \f
  76 ;;; Enabling and disabling debugging features of the host Scheme.
  77
  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*)
  81     (begin
  82       (debug-enable 'backtrace)
  83       (debug-enable 'debug)
  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)
  90
  91 ;;; Call THUNK, with debugging enabled if FLAG is true, or disabled if
  92 ;;; FLAG is false.
  93 ;;;
  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))
 101
 102   ;; Now, make that debugging / no-debugging setting actually take
 103   ;; effect.
 104   ;;
 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))
 116
 117
 118 ;;; Apply PROC to ARGS, marking that application as the bottom of the
 119 ;;; stack for error backtraces.
 120 ;;;
 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)
 125
 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)
 135                     (begin
 136                       (apply display-error #f (current-error-port) (cdr args))
 137                       ;; Grab a copy of the current stack,
 138                       (save-stack handler 0)
 139                       (backtrace)))
 140                 (quit 1))
 141
 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.
 145   (lazy-catch #t
 146               (lambda ()
 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)))
 152               handler))