From: Joe Marshall Date: Fri, 12 Feb 2010 22:44:09 +0000 (-0800) Subject: Separate global declarations from top-level declarations. X-Git-Tag: 20100708-Gtk~168^2~2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=54d4f2d5824fadc1f761a0337bf147955c5ecbcf;p=mit-scheme.git Separate global declarations from top-level declarations. --- diff --git a/src/sf/pardec.scm b/src/sf/pardec.scm index 35158a8b7..6515ff470 100644 --- a/src/sf/pardec.scm +++ b/src/sf/pardec.scm @@ -68,9 +68,11 @@ USA. (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) @@ -86,7 +88,7 @@ USA. (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) @@ -122,18 +124,23 @@ USA. ;; 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))) @@ -156,7 +163,7 @@ USA. '()) (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") @@ -203,7 +210,7 @@ USA. (cons (make-declaration operation variable value - #t) + 'GLOBAL) declarations)) (set! remaining (cons (vector operation name value) @@ -232,7 +239,7 @@ USA. (vector-ref remaining 0) (variable/make&bind! top-level-block (vector-ref remaining 1)) (vector-ref remaining 2) - #t))) + 'GLOBAL))) remaining)))) (define (define-integration-declaration operation) @@ -241,7 +248,7 @@ USA. (make-declarations operation (block/lookup-names block names #t) 'NO-VALUES - #f)))) + 'LOCAL)))) (define-integration-declaration 'INTEGRATE) (define-integration-declaration 'INTEGRATE-OPERATOR) @@ -272,7 +279,7 @@ USA. name) (make-integration-info (copy/expression/extern block value)) - #t)))))) + 'TOP-LEVEL)))))) externs)))) (append-map (lambda (specification) (let ((value @@ -345,7 +352,7 @@ USA. (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) @@ -389,7 +396,7 @@ USA. (make-dumpable-expander (replacement/make replacement block) `(REPLACE-OPERATOR ,replacement)) - #f)) + 'LOCAL)) replacements))) (define (make-dumpable-expander expander declaration) @@ -429,5 +436,5 @@ USA. (block/lookup-name block (car expander) #t) (eval (cadr expander) expander-evaluation-environment) - #f)) + 'LOCAL)) expanders))) \ No newline at end of file diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 64d55dc7b..3cb2c2613 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -524,7 +524,7 @@ USA. (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))))) @@ -634,19 +634,19 @@ USA. 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)))) diff --git a/src/sf/tables.scm b/src/sf/tables.scm index 3161021cd..95d092964 100644 --- a/src/sf/tables.scm +++ b/src/sf/tables.scm @@ -154,7 +154,7 @@ USA. required)))) (define (listify-tail operands) - (fold-right + (fold-right (lambda (operand tail) (combination/make #f block @@ -178,59 +178,81 @@ USA. ;;;; 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)