set! name (lambda ...) names the lambda

* module/ice-9/psyntax.scm (build-lexical-assignment)
  (build-global-assignment): Maybe name the RHS.

* module/ice-9/psyntax-pp.scm: Regenerated.

* module/ice-9/boot-9.scm (catch, with-throw-handler, throw): Rework to
  use set! instead of define! so that we get names.
This commit is contained in:
Andy Wingo 2010-06-19 13:56:16 +02:00
commit 37620f3f4e
3 changed files with 8364 additions and 8325 deletions

View file

@ -67,6 +67,7 @@
;; Define catch and with-throw-handler, using some common helper routines and a ;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour. ;; shared fluid. Hide the helpers in a lexical contour.
(define with-throw-handler #f)
(let () (let ()
;; Ideally we'd like to be able to give these default values for all threads, ;; 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 ;; even threads not created by Guile; but alack, that does not currently seem
@ -118,7 +119,7 @@
(apply prev thrown-k args)))) (apply prev thrown-k args))))
(apply prev thrown-k args))))) (apply prev thrown-k args)))))
(define! 'catch (set! catch
(lambda* (k thunk handler #:optional pre-unwind-handler) (lambda* (k thunk handler #:optional pre-unwind-handler)
"Invoke @var{thunk} in the dynamic context of @var{handler} for "Invoke @var{thunk} in the dynamic context of @var{handler} for
exceptions matching @var{key}. If thunk throws to the symbol exceptions matching @var{key}. If thunk throws to the symbol
@ -170,7 +171,7 @@ non-locally, that exit determines the continuation."
(lambda (cont k . args) (lambda (cont k . args)
(apply handler k args)))))) (apply handler k args))))))
(define! 'with-throw-handler (set! with-throw-handler
(lambda (k thunk pre-unwind-handler) (lambda (k thunk pre-unwind-handler)
"Add @var{handler} to the dynamic context as a throw handler "Add @var{handler} to the dynamic context as a throw handler
for key @var{key}, then invoke @var{thunk}." for key @var{key}, then invoke @var{thunk}."
@ -182,7 +183,7 @@ for key @var{key}, then invoke @var{thunk}."
(custom-throw-handler #f k pre-unwind-handler))) (custom-throw-handler #f k pre-unwind-handler)))
(thunk)))) (thunk))))
(define! 'throw (set! throw
(lambda (key . args) (lambda (key . args)
"Invoke the catch form matching @var{key}, passing @var{args} to the "Invoke the catch form matching @var{key}, passing @var{args} to the
@var{handler}. @var{handler}.

File diff suppressed because it is too large Load diff

View file

@ -377,7 +377,13 @@
(set-source-properties! e s)) (set-source-properties! e s))
e) e)
;;; output constructors (define (maybe-name-value! name val)
(if (lambda? val)
(let ((meta (lambda-meta val)))
(if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta))))))
;;; output constructors
(define build-void (define build-void
(lambda (source) (lambda (source)
(make-void source))) (make-void source)))
@ -400,6 +406,7 @@
(define build-lexical-assignment (define build-lexical-assignment
(lambda (source name var exp) (lambda (source name var exp)
(maybe-name-value! name exp)
(make-lexical-set source name var exp))) (make-lexical-set source name var exp)))
;; Before modules are booted, we can't expand into data structures from ;; Before modules are booted, we can't expand into data structures from
@ -438,6 +445,7 @@
(define build-global-assignment (define build-global-assignment
(lambda (source var exp mod) (lambda (source var exp mod)
(maybe-name-value! var exp)
(analyze-variable (analyze-variable
mod var mod var
(lambda (mod var public?) (lambda (mod var public?)
@ -445,12 +453,6 @@
(lambda (var) (lambda (var)
(make-toplevel-set source var exp))))) (make-toplevel-set source var exp)))))
(define (maybe-name-value! name val)
(if (lambda? val)
(let ((meta (lambda-meta val)))
(if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta))))))
(define build-global-definition (define build-global-definition
(lambda (source var exp) (lambda (source var exp)
(maybe-name-value! var exp) (maybe-name-value! var exp)