(if (null? declarations)
operations
(loop (let ((declaration (car declarations)))
- ((if (declaration/overridable? declaration)
- operations/bind-global
- operations/bind)
+ ((case (declaration/binding-level declaration)
+ ((LOCAL) operations/bind)
+ ((TOP-LEVEL) operations/bind-top-level)
+ ((GLOBAL) operations/bind-global)
+ (else (error "Unrecognized binding level" (declaration/binding-level declaration))))
operations
(declaration/operation declaration)
(declaration/variable declaration)
(let ((value (declaration/value declaration)))
(and value
(per-value value)))
- (declaration/overridable? declaration)))
+ (declaration/binding-level declaration)))
(declaration-set/declarations declaration-set))))
(define (declarations/known? declaration)
;; field depends on OPERATION.
(value #f read-only #t)
- ;; OVERRIDABLE? means that a user-defined variable of the same name
- ;; will override this declaration. It also means that this
- ;; declaration should not be written out to the ".ext" file.
- (overridable? #f read-only #t))
+ ;; BINDING-LEVEL indicates whether the declaration is `global',
+ ;; 'top-level' or 'local'. Only 'local' declarations are written out
+ ;; to the ".ext" file.
-(define (make-declarations operation variables values overridable?)
+ ;; Usual-integrations are bound at the `global' level, external
+ ;; declarations are bound at the 'top-level' level. This prevents
+ ;; confusion between external integrations that have the same name
+ ;; as usual ones.
+ (binding-level #f read-only #t))
+
+(define (make-declarations operation variables values binding-level)
(if (eq? values 'NO-VALUES)
(map (lambda (variable)
- (make-declaration operation variable #f overridable?))
+ (make-declaration operation variable #f binding-level))
variables)
(map (lambda (variable value)
- (make-declaration operation variable value overridable?))
+ (make-declaration operation variable value binding-level))
variables
values)))
'())
(define (known-declaration? operation)
- (or (eq? operation 'EXPAND) ; this one is special
+ (or (eq? operation 'EXPAND) ; this one is special
(assq operation known-declarations)))
(define-guarantee known-declaration "known declaration")
(cons (make-declaration operation
variable
value
- #t)
+ 'GLOBAL)
declarations))
(set! remaining
(cons (vector operation name value)
(vector-ref remaining 0)
(variable/make&bind! top-level-block (vector-ref remaining 1))
(vector-ref remaining 2)
- #t)))
+ 'GLOBAL)))
remaining))))
\f
(define (define-integration-declaration operation)
(make-declarations operation
(block/lookup-names block names #t)
'NO-VALUES
- #f))))
+ 'LOCAL))))
(define-integration-declaration 'INTEGRATE)
(define-integration-declaration 'INTEGRATE-OPERATOR)
name)
(make-integration-info
(copy/expression/extern block value))
- #t))))))
+ 'TOP-LEVEL))))))
externs))))
(append-map (lambda (specification)
(let ((value
(block/lookup-name block (car rule) #t)
(make-dumpable-expander (reducer/make rule block)
`(REDUCE-OPERATOR ,rule))
- #f))
+ 'LOCAL))
reduction-rules)))
(define (check-declaration-syntax kind declarations)
(make-dumpable-expander
(replacement/make replacement block)
`(REPLACE-OPERATOR ,replacement))
- #f))
+ 'LOCAL))
replacements)))
\f
(define (make-dumpable-expander expander declaration)
(block/lookup-name block (car expander) #t)
(eval (cadr expander)
expander-evaluation-environment)
- #f))
+ 'LOCAL))
expanders)))
\ No newline at end of file
(define-method/integrate 'DISJUNCTION
(lambda (operations environment expression)
- (disjunction/make
+ (disjunction/make
(disjunction/scode expression)
(integrate/expression operations environment (disjunction/predicate expression))
(integrate/expression operations environment (disjunction/alternative expression)))))
operations name
(lambda (operation info)
(case operation
- ((#F) (dont-integrate));; shadowed
+ ((#F) (dont-integrate))
((EXPAND)
(cond ((info expression operands (reference/block operator))
=> (lambda (new-expression)
- (integrate/expression operations environment new-expression)))
+ (integrate/expression operations environment new-expression)))
(else (dont-integrate))))
((INTEGRATE INTEGRATE-OPERATOR)
- ;; This can happen when a top-level variable shadows an expander.
- ;; Don't integrate here or the wrong thing will happen.
- ;; This needs to be fixed.
- (dont-integrate))
+ (let ((new-operator
+ (reassign operator
+ (copy/expression/intern block (integration-info/expression info)))))
+ (integrate/combination expression operations environment block new-operator operands)))
(else
(error "unknown operation" operation))))
required))))
(define (listify-tail operands)
- (fold-right
+ (fold-right
(lambda (operand tail)
(combination/make #f
block
;;;; Operations
-;; An operations table is a cons of two alists. The first alist
+;; An operations table is a triple of three alists. The first alist
;; contains the lexically visible operations, the second contains
-;; the global operations.
+;; the top-level operations, the third contains the global operations.
+
+;; The global operations are installed by the `usual-integrations'
+;; declarations, external operations are installed in the top-level
+;; operations. This allows us to lookup the appropriate operation
+;; when integrating an expression like (access foo #f) where there
+;; is an external integration that *also* is called foo.
(define (operations/make)
- (cons '() '()))
+ (vector '() '() '()))
(define (operations/lookup operations variable if-found if-not)
(guarantee-variable variable 'operations/lookup)
- (let ((entry (assq variable (car operations))))
+ (let ((entry (assq variable (vector-ref operations 0))))
(if entry
(if (cdr entry)
(if-found (cadr entry) (cddr entry))
(if-not))
- (let ((entry (assq variable (cdr operations))))
+ (let ((entry (assq variable (vector-ref operations 1))))
(if entry
- (if-found (cadr entry) (cddr entry))
- (if-not))))))
+ (if (cdr entry)
+ (if-found (cadr entry) (cddr entry))
+ (if-not))
+ (let ((entry (assq variable (vector-ref operations 2))))
+ (if entry
+ (if-found (cadr entry) (cddr entry))
+ (if-not))))))))
;; When processing a global reference, we only have a name.
(define (operations/lookup-global operations name if-found if-not)
(guarantee-symbol name 'operations/lookup-global)
(let ((probe (find (lambda (entry)
(eq? (variable/name (car entry)) name))
- (cdr operations))))
- (if probe
+ (vector-ref operations 2))))
+ (if probe
(if-found (cadr probe) (cddr probe))
(if-not))))
(define (operations/shadow operations variables)
- (cons (map* (car operations)
- (lambda (variable)
- (guarantee-variable variable 'operations/shadow)
- (cons variable false))
- variables)
- (cdr operations)))
+ (vector (map* (vector-ref operations 0)
+ (lambda (variable)
+ (guarantee-variable variable 'operations/shadow)
+ (cons variable false))
+ variables)
+ (vector-ref operations 1)
+ (vector-ref operations 2)))
(define (operations/bind operations operation variable value)
(guarantee-known-declaration operation 'operations/bind)
(guarantee-variable variable 'operations/bind)
- (cons (cons (cons* variable operation value)
- (car operations))
- (cdr operations)))
+ (vector (cons (cons* variable operation value)
+ (vector-ref operations 0))
+ (vector-ref operations 1)
+ (vector-ref operations 2)))
+
+(define (operations/bind-top-level operations operation variable value)
+ (guarantee-known-declaration operation 'operations/bind-top-level)
+ (guarantee-variable variable 'operations/bind-top-level)
+ (vector (vector-ref operations 0)
+ (cons (cons* variable operation value)
+ (vector-ref operations 1))
+ (vector-ref operations 2)))
(define (operations/bind-global operations operation variable value)
(guarantee-known-declaration operation 'operations/bind-global)
(guarantee-variable variable 'operations/bind-global)
- (cons (car operations)
- (cons (cons* variable operation value)
- (cdr operations))))
+ (vector (vector-ref operations 0)
+ (vector-ref operations 1)
+ (cons (cons* variable operation value)
+ (vector-ref operations 2))))
(define (operations/map-external operations procedure)
- (let loop ((elements (car operations)))
+ (let loop ((elements (vector-ref operations 0)))
(cond ((null? elements)
'())
((cdar elements)
projects / mit-scheme.git / commitdiff