← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/compiler/fggen/declar.scm

  • Committer: Bazaar Package Importer
  • Author(s): Evan Broder
  • Date: 2009-03-08 00:46:17 UTC
  • mfrom: (1.1.6 upstream) (3.1.3 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090308004617-csqyjpnkg7daq9c4
Tags: 7.7.90+20090107-1ubuntu1
https://launchpad.net/bugs/288000
https://launchpad.net/bugs/217792
* Merge from debian unstable, remaining changes (LP: #288000, #217792):
  * Bootstrapping done via binary package from Debian unstable. See log
      entry for 7.7.90+20060906-3ubuntu1 for details.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/compiler/fggen/declar.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: declar.scm,v 1.10 2007/01/05 21:19:20 cph Exp $
 
3
$Id: declar.scm,v 1.12 2008/01/30 20:01:44 cph Exp $
4
4
 
5
5
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
6
6
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
7
 
    2006, 2007 Massachusetts Institute of Technology
 
7
    2006, 2007, 2008 Massachusetts Institute of Technology
8
8
 
9
9
This file is part of MIT/GNU Scheme.
10
10
 
29
29
 
30
30
(declare (usual-integrations))
31
31
 
32
 
(define (process-top-level-declarations! block declarations)
 
32
;;; A block's declarations are processed in two phases: before and
 
33
;;; after the flow graph is generated for the block's children.  See
 
34
;;; GENERATE/BODY in fggen/fggen.scm.  Some declarations need to refer
 
35
;;; to information about variables bound by the block, so they use
 
36
;;; post-declarations; others need to establish information that the
 
37
;;; children can inherit from, so they use pre-declarations.
 
38
 
 
39
(define (process-top-level-declarations! block declarations handlers)
33
40
  (process-declarations!
34
41
   block
35
42
   (let loop
40
47
         (loop (if (assq (caar defaults) declarations)
41
48
                   declarations
42
49
                   (cons (car defaults) declarations))
43
 
               (cdr defaults))))))
 
50
               (cdr defaults))))
 
51
   handlers))
44
52
 
45
 
(define (process-declarations! block declarations)
 
53
(define (process-declarations! block declarations handlers)
46
54
  (for-each (lambda (declaration)
47
 
              (process-declaration! block declaration))
 
55
              (process-declaration! block declaration handlers))
48
56
            declarations))
49
57
 
50
 
(define (process-declaration! block declaration)
51
 
  (let ((entry (assq (car declaration) known-declarations)))
 
58
(define (process-declaration! block declaration handlers)
 
59
  (let ((entry (assq (car declaration) handlers)))
52
60
    (if entry
53
61
        ((cdr entry) block (car declaration) (cdr declaration))
54
62
        (warn "Unknown declaration name" (car declaration)))))
55
63
 
56
 
(define known-declarations
57
 
  '())
58
 
 
59
 
(define (define-declaration keyword handler)
60
 
  (let ((entry (assq keyword known-declarations)))
61
 
    (if entry
62
 
        (set-cdr! entry handler)
63
 
        (set! known-declarations
64
 
              (cons (cons keyword handler)
65
 
                    known-declarations))))
66
 
  keyword)
 
64
(define (declaration-processor get-handlers)
 
65
  (lambda (block declarations)
 
66
    (process-top-level-declarations! block declarations (get-handlers))))
 
67
 
 
68
(define (declaration-definer get-handlers set-handlers!)
 
69
  (lambda (keyword handler)
 
70
    (let ((handlers (get-handlers)))
 
71
      (cond ((assq keyword handlers)
 
72
             => (lambda (entry)
 
73
                  (set-cdr! entry handler)))
 
74
            (else
 
75
             (set-handlers! (cons (cons keyword handler) handlers)))))
 
76
    keyword))
 
77
 
 
78
(define pre-declarations '())
 
79
(define post-declarations '())
 
80
 
 
81
(define process-pre-declarations!
 
82
  (declaration-processor (lambda () pre-declarations)))
 
83
 
 
84
(define process-post-declarations!
 
85
  (declaration-processor (lambda () post-declarations)))
 
86
 
 
87
(define define-pre-declaration
 
88
  (declaration-definer (lambda () pre-declarations)
 
89
                       (lambda (handlers) (set! pre-declarations handlers))))
 
90
 
 
91
(define define-post-declaration
 
92
  (declaration-definer (lambda () post-declarations)
 
93
                       (lambda (handlers) (set! post-declarations handlers))))
 
94
 
 
95
(define (define-pre-only-declaration keyword handler)
 
96
  (define-pre-declaration keyword handler)
 
97
  (define-post-declaration keyword ignored-declaration))
 
98
 
 
99
(define (define-post-only-declaration keyword handler)
 
100
  (define-pre-declaration keyword ignored-declaration)
 
101
  (define-post-declaration keyword handler))
 
102
 
 
103
(define ignored-declaration
 
104
  (lambda (block keyword parameters)
 
105
    block keyword parameters            ;ignore
 
106
    unspecific))
67
107
 
68
108
(package (boolean-variable-property)
69
109
 
129
169
 
130
170
)
131
171
 
132
 
(define-declaration 'UUO-LINK boolean-variable-property)
133
 
(define-declaration 'CONSTANT boolean-variable-property)
134
 
(define-declaration 'IGNORE-REFERENCE-TRAPS boolean-variable-property)
135
 
(define-declaration 'IGNORE-ASSIGNMENT-TRAPS boolean-variable-property)
136
 
(define-declaration 'USUAL-DEFINITION boolean-variable-property)
137
 
(define-declaration 'SIDE-EFFECT-FREE boolean-variable-property)
138
 
(define-declaration 'PURE-FUNCTION boolean-variable-property)
 
 
b'\\ No newline at end of file'
 
172
(define-post-only-declaration 'UUO-LINK boolean-variable-property)
 
173
(define-post-only-declaration 'CONSTANT boolean-variable-property)
 
174
(define-post-only-declaration 'IGNORE-REFERENCE-TRAPS
 
175
  boolean-variable-property)
 
176
(define-post-only-declaration 'IGNORE-ASSIGNMENT-TRAPS
 
177
  boolean-variable-property)
 
178
(define-post-only-declaration 'USUAL-DEFINITION boolean-variable-property)
 
179
(define-post-only-declaration 'SIDE-EFFECT-FREE boolean-variable-property)
 
180
(define-post-only-declaration 'PURE-FUNCTION boolean-variable-property)
 
181
 
 
182
;;;; Safety Check Declarations
 
183
 
 
184
(let ()
 
185
  (define (check-property block-checks set-block-checks! enable?)
 
186
    (lambda (block keyword primitives)
 
187
      keyword                           ;ignore
 
188
      (set-block-checks!
 
189
       block
 
190
       (let ((checks (block-checks block)))
 
191
         (if (null? primitives)
 
192
             enable?
 
193
             (if (boolean? checks)
 
194
                 (if (eqv? checks enable?)
 
195
                     checks
 
196
                     (if enable?
 
197
                         (list checks primitives '())
 
198
                         (list checks '() primitives)))
 
199
                 (let ((default (car checks))
 
200
                       (do-check (cadr checks))
 
201
                       (dont-check (caddr checks)))
 
202
                   (if enable?
 
203
                       (list default
 
204
                             (eq-set-adjoin primitives do-check)
 
205
                             dont-check)
 
206
                       (list default
 
207
                             do-check
 
208
                             (eq-set-adjoin primitives dont-check))))))))))
 
209
  (define-pre-only-declaration 'TYPE-CHECKS
 
210
    (check-property block-type-checks set-block-type-checks! #t))
 
211
  (define-pre-only-declaration 'NO-TYPE-CHECKS
 
212
    (check-property block-type-checks set-block-type-checks! #f))
 
213
  (define-pre-only-declaration 'RANGE-CHECKS
 
214
    (check-property block-range-checks set-block-range-checks! #t))
 
215
  (define-pre-only-declaration 'NO-RANGE-CHECKS
 
216
    (check-property block-range-checks set-block-range-checks! #f)))