From: Chris Hanson Date: Mon, 7 Jan 2002 03:38:47 +0000 (+0000) Subject: Redesign way that macros are integrated into environments. Syntactic X-Git-Tag: 20090517-FFI~2301 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=225f20b553d31b424d2f9012e5a02a78043f9163;p=mit-scheme.git Redesign way that macros are integrated into environments. Syntactic keywords are now considered bound, but ordinary variable-reference operations signal errors on those bindings; but each of the definition operations can be used to modify either kind of binding. New procedure ENVIRONMENT-DEFINABLE? can be used to determine if a definition is allowed on a particular environment; currently it is false on compiled-code environments. New procedures ENVIRONMENT-REFERENCE-TYPE and ENVIRONMENT-SAFE-LOOKUP provide very flexible mechanisms for determining what is contained in an environment or binding without generating errors. --- diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index cc9b7cc38..8a81242d2 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.55 2001/12/23 17:20:59 cph Exp $ +$Id: error.scm,v 14.56 2002/01/07 03:38:28 cph Exp $ -Copyright (c) 1988-2001 Massachusetts Institute of Technology +Copyright (c) 1988-2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -706,6 +706,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define error:derived-thread) (define error:illegal-pathname-component) (define error:macro-binding) +(define error:unassigned-variable) +(define error:unbound-variable) (define error:wrong-number-of-arguments) (define error:wrong-type-argument) (define error:wrong-type-datum) @@ -1135,6 +1137,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (condition-signaller condition-type:no-such-restart '(NAME) standard-error-handler)) + (set! error:unassigned-variable + (condition-signaller condition-type:unassigned-variable + '(ENVIRONMENT LOCATION) + standard-error-handler)) + (set! error:unbound-variable + (condition-signaller condition-type:unbound-variable + '(ENVIRONMENT LOCATION) + standard-error-handler)) (set! error:macro-binding (condition-signaller condition-type:macro-binding '(ENVIRONMENT LOCATION) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 762a5f8f8..f66c25f66 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.404 2002/01/04 06:05:13 cph Exp $ +$Id: runtime.pkg,v 14.405 2002/01/07 03:38:41 cph Exp $ -Copyright (c) 1988-2001 Massachusetts Institute of Technology +Copyright (c) 1988-2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -1325,6 +1325,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA environment-bindings environment-bound-names environment-bound? + environment-definable? environment-define environment-define-macro environment-has-parent? @@ -1334,6 +1335,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA environment-macro-names environment-parent environment-procedure-name + environment-reference-type + environment-safe-lookup environment? extend-interpreter-environment guarantee-environment @@ -1476,7 +1479,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ordinal-number-string write-operator) (export (runtime environment) - error:macro-binding) + error:macro-binding + error:unassigned-variable + error:unbound-variable) (initialization (initialize-package!))) (define-package (runtime event-distributor) diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 71d30062e..ce5bbf16c 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: uenvir.scm,v 14.51 2002/01/04 06:05:21 cph Exp $ +$Id: uenvir.scm,v 14.52 2002/01/07 03:38:47 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -86,18 +86,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (illegal-environment environment 'ENVIRONMENT-MACRO-NAMES)))) (define (environment-bindings environment) - (cond ((system-global-environment? environment) - (system-global-environment/bindings)) - ((ic-environment? environment) - (ic-environment/bindings environment)) - (else - (map (lambda (name) - (cons name - (let ((value (environment-lookup environment name))) - (if (unassigned-reference-trap? value) - '() - (list value))))) - (environment-bound-names environment))))) + (let ((items (environment-bound-names environment))) + (do ((items items (cdr items))) + ((not (pair? items))) + (let ((name (car items))) + (set-car! items + (cons name + (let ((value + (environment-safe-lookup environment name))) + (if (unassigned-reference-trap? value) + '() + (list value))))))) + items)) (define (environment-arguments environment) (cond ((ic-environment? environment) @@ -128,48 +128,51 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (illegal-environment environment 'ENVIRONMENT-LAMBDA)))) (define (environment-bound? environment name) + (not (eq? 'UNBOUND (environment-reference-type environment name)))) + +(define (environment-reference-type environment name) (cond ((interpreter-environment? environment) - (interpreter-environment/bound? environment name)) + (interpreter-environment/reference-type environment name)) ((stack-ccenv? environment) - (stack-ccenv/bound? environment name)) + (stack-ccenv/reference-type environment name)) ((closure-ccenv? environment) - (closure-ccenv/bound? environment name)) + (closure-ccenv/reference-type environment name)) (else - (illegal-environment environment 'ENVIRONMENT-BOUND?)))) + (illegal-environment environment 'ENVIRONMENT-REFERENCE-TYPE)))) (define (environment-assigned? environment name) - (cond ((interpreter-environment? environment) - (interpreter-environment/assigned? environment name)) - ((stack-ccenv? environment) - (stack-ccenv/assigned? environment name)) - ((closure-ccenv? environment) - (closure-ccenv/assigned? environment name)) - (else - (illegal-environment environment 'ENVIRONMENT-ASSIGNED?)))) + (case (environment-reference-type environment name) + ((UNBOUND) (error:unbound-variable environment name)) + ((MACRO) (error:macro-binding environment name)) + ((UNASSIGNED) #f) + (else #t))) (define (environment-lookup environment name) - (cond ((interpreter-environment? environment) - (interpreter-environment/lookup environment name)) - ((stack-ccenv? environment) - (stack-ccenv/lookup environment name)) - ((closure-ccenv? environment) - (closure-ccenv/lookup environment name)) - (else - (illegal-environment environment 'ENVIRONMENT-LOOKUP)))) + (let ((value (environment-safe-lookup environment name))) + (cond ((unassigned-reference-trap? value) + (error:unassigned-variable environment name)) + ((macro-reference-trap? value) + (error:macro-binding environment name)) + (else value)))) (define (environment-lookup-macro environment name) + (let ((value (environment-safe-lookup environment name))) + (and (macro-reference-trap? value) + (macro-reference-trap-transformer value)))) + +(define (environment-safe-lookup environment name) (cond ((interpreter-environment? environment) - (interpreter-environment/lookup-macro environment name)) + (interpreter-environment/safe-lookup environment name)) ((stack-ccenv? environment) - (stack-ccenv/lookup-macro environment name)) + (stack-ccenv/safe-lookup environment name)) ((closure-ccenv? environment) - (closure-ccenv/lookup-macro environment name)) + (closure-ccenv/safe-lookup environment name)) (else - (illegal-environment environment 'ENVIRONMENT-LOOKUP-MACRO)))) + (illegal-environment environment 'ENVIRONMENT-SAFE-LOOKUP)))) (define (environment-assignable? environment name) (cond ((interpreter-environment? environment) - #t) + (interpreter-environment/assignable? environment name)) ((stack-ccenv? environment) (stack-ccenv/assignable? environment name)) ((closure-ccenv? environment) @@ -187,6 +190,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (else (illegal-environment environment 'ENVIRONMENT-ASSIGN!)))) +(define (environment-definable? environment name) + name + (cond ((interpreter-environment? environment) #t) + ((or (stack-ccenv? environment) (closure-ccenv? environment)) #f) + (else (illegal-environment environment 'ENVIRONMENT-DEFINABLE?)))) + (define (environment-define environment name value) (cond ((interpreter-environment? environment) (interpreter-environment/define environment name value)) @@ -211,16 +220,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (eq? system-global-environment object)) (define (system-global-environment/bound-names) - (walk-global not-macro-reference-trap? map-entry/name)) + (walk-global object? map-entry/name)) (define (system-global-environment/macro-names) (walk-global macro-reference-trap? map-entry/name)) -(define (system-global-environment/bindings) - (walk-global not-macro-reference-trap? map-entry/binding)) - -(define (not-macro-reference-trap? v) - (not (macro-reference-trap? v))) +(define (object? v) v #t) (define (map-entry/name name value) value @@ -230,12 +235,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA name value) -(define (map-entry/binding name value) - (cons name - (if (unassigned-reference-trap? value) - '() - (list value)))) - (define (walk-global keep? map-entry) (let ((obarray (fixed-objects-item 'OBARRAY))) (let ((n-buckets (vector-length obarray))) @@ -278,37 +277,24 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (error:wrong-type-datum object "interpreter environment")) object) -#| -(define (lexical-reference-type environment name) +(define (interpreter-environment/reference-type environment name) (let ((i ((ucode-primitive lexical-reference-type 2) environment name)) (v '#(UNBOUND UNASSIGNED NORMAL MACRO))) (if (not (fix:< i (vector-length v))) - (error "Unknown reference type:" i 'LEXICAL-REFERENCE-TYPE)) + (error "Unknown reference type:" i 'ENVIRONMENT-REFERENCE-TYPE)) (vector-ref v i))) -|# -(define (safe-lexical-reference environment name) +(define (interpreter-environment/safe-lookup environment name) (let ((cell (list #f))) (set-car! cell ((ucode-primitive safe-lexical-reference 2) environment name)) (map-reference-trap (lambda () (car cell))))) -(define (interpreter-environment/bound? environment name) - (not (lexical-unbound? environment name))) - -(define (interpreter-environment/assigned? environment name) - (not (lexical-unassigned? environment name))) - -(define (interpreter-environment/lookup environment name) - (let ((value (safe-lexical-reference environment name))) - (if (macro-reference-trap? value) - (error:macro-binding environment name)) - value)) - -(define (interpreter-environment/lookup-macro environment name) - (let ((value (safe-lexical-reference environment name))) - (and (macro-reference-trap? value) - (macro-reference-trap-transformer value)))) +(define (interpreter-environment/assignable? environment name) + (case (interpreter-environment/reference-type environment name) + ((UNBOUND) (error:unbound-variable environment name)) + ((MACRO) (error:macro-binding environment name)) + (else #t))) (define (interpreter-environment/assign! environment name value) (lexical-assignment environment name value) @@ -317,24 +303,24 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (interpreter-environment/define environment name value) (local-assignment environment name value)) -(define (interpreter-environment/define-macro environment name value) +(define (interpreter-environment/define-macro environment name transformer) (local-assignment environment name - (make-unmapped-macro-reference-trap value))) + (make-unmapped-macro-reference-trap transformer))) (define (ic-environment/bound-names environment) - (map-ic-environment-bindings environment - not-macro-reference-trap? - map-entry/name)) + (map-ic-environment-bindings environment object? map-entry/name)) (define (ic-environment/macro-names environment) (map-ic-environment-bindings environment macro-reference-trap? map-entry/name)) -(define (ic-environment/bindings environment) - (map-ic-environment-bindings environment - not-macro-reference-trap? - map-entry/binding)) +(define (ic-environment/arguments environment) + (let ((environment (ic-external-frame environment))) + (walk-ic-procedure-args environment + (ic-frame-procedure* environment) + object? + map-entry/value))) (define (map-ic-environment-bindings environment keep? map-entry) (let ((external (ic-external-frame environment)) @@ -384,13 +370,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA result)))))) result)))) -(define (ic-environment/arguments environment) - (let ((environment (ic-external-frame environment))) - (walk-ic-procedure-args environment - (ic-frame-procedure* environment) - not-macro-reference-trap? - map-entry/value))) - (define (ic-environment/has-parent? environment) (interpreter-environment? (ic-frame-parent environment))) @@ -634,8 +613,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((INDIRECTED) (lookup (dbg-variable/value variable))) (else - (stack-ccenv/lookup environment - (dbg-variable/name variable))))))) + (stack-ccenv/safe-lookup + environment + (dbg-variable/name variable))))))) (map* (map* (let ((rest (dbg-procedure/rest procedure))) (if rest (lookup rest) '())) lookup @@ -651,23 +631,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (dbg-block/layout-vector (stack-ccenv/block environment))) dbg-variable?))) -(define (stack-ccenv/bound? environment name) - (or (dbg-block/find-name (stack-ccenv/block environment) name) - (environment-bound? (stack-ccenv/parent environment) name))) - -(define (stack-ccenv/assigned? environment name) - (and (stack-ccenv/lookup environment name) #t)) +(define (stack-ccenv/reference-type environment name) + (dbg-variable-reference-type (stack-ccenv/block environment) + name + (lambda (index) + (stack-ccenv/get-value environment index)) + (lambda (name) + (environment-reference-type (stack-ccenv/parent environment) name)))) -(define (stack-ccenv/lookup environment name) +(define (stack-ccenv/safe-lookup environment name) (lookup-dbg-variable (stack-ccenv/block environment) name - (stack-ccenv/get-value environment) - (lambda (name) - (environment-lookup (stack-ccenv/parent environment) - name)))) - -(define (stack-ccenv/lookup-macro environment name) - (environment-lookup-macro (stack-ccenv/parent environment) name)) + (lambda (index) + (stack-ccenv/get-value environment index)) + (lambda (name) + (environment-safe-lookup (stack-ccenv/parent environment) name)))) (define (stack-ccenv/assignable? environment name) (assignable-dbg-variable? (stack-ccenv/block environment) name @@ -677,16 +655,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (stack-ccenv/assign! environment name value) (assign-dbg-variable! (stack-ccenv/block environment) name - (stack-ccenv/get-value environment) + (lambda (index) + (stack-ccenv/get-value environment index)) value (lambda (name) (environment-assign! (stack-ccenv/parent environment) name value)))) - -(define (stack-ccenv/get-value environment) - (lambda (index) - (stack-frame/ref (stack-ccenv/frame environment) - (+ (stack-ccenv/start-index environment) index)))) +(define (stack-ccenv/get-value environment index) + (stack-frame/ref (stack-ccenv/frame environment) + (+ (stack-ccenv/start-index environment) index))) + (define (stack-ccenv/static-link environment) (let ((static-link (find-stack-element environment @@ -758,36 +736,27 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (dbg-block/layout-vector (closure-ccenv/stack-block environment))) (lambda (variable) (and (dbg-variable? variable) - (closure-ccenv/variable-bound? environment variable)))))) - -(define (closure-ccenv/bound? environment name) - (or (let ((block (closure-ccenv/stack-block environment))) - (let ((index (dbg-block/find-name block name))) - (and index - (closure-ccenv/variable-bound? - environment - (vector-ref (dbg-block/layout-vector block) index))))) - (environment-bound? (closure-ccenv/parent environment) name))) - -(define (closure-ccenv/assigned? environment name) - (and (closure-ccenv/lookup environment name) #t)) - -(define (closure-ccenv/variable-bound? environment variable) - (or (eq? (dbg-variable/type variable) 'INTEGRATED) - (vector-find-next-element - (dbg-block/layout-vector (closure-ccenv/closure-block environment)) - variable))) + (or (eq? (dbg-variable/type variable) 'INTEGRATED) + (vector-find-next-element + (dbg-block/layout-vector + (closure-ccenv/closure-block environment)) + variable))))))) + +(define (closure-ccenv/reference-type environment name) + (dbg-variable-reference-type (closure-ccenv/closure-block environment) + name + (lambda (index) + (closure-ccenv/get-value environment index)) + (lambda (name) + (environment-reference-type (closure-ccenv/parent environment) name)))) -(define (closure-ccenv/lookup environment name) +(define (closure-ccenv/safe-lookup environment name) (lookup-dbg-variable (closure-ccenv/closure-block environment) name - (closure-ccenv/get-value environment) - (lambda (name) - (environment-lookup (closure-ccenv/parent environment) - name)))) - -(define (closure-ccenv/lookup-macro environment name) - (environment-lookup-macro (closure-ccenv/parent environment) name)) + (lambda (index) + (closure-ccenv/get-value environment index)) + (lambda (name) + (environment-safe-lookup (closure-ccenv/parent environment) name)))) (define (closure-ccenv/assignable? environment name) (assignable-dbg-variable? (closure-ccenv/closure-block environment) name @@ -797,22 +766,22 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (closure-ccenv/assign! environment name value) (assign-dbg-variable! (closure-ccenv/closure-block environment) name - (closure-ccenv/get-value environment) + (lambda (index) + (closure-ccenv/get-value environment index)) value (lambda (name) (environment-assign! (closure-ccenv/parent environment) name value)))) - + +(define (closure-ccenv/get-value environment index) + (closure/get-value (closure-ccenv/closure environment) + (closure-ccenv/closure-block environment) + index)) + (define-integrable (closure/get-value closure closure-block index) (compiled-closure/ref closure index (dbg-block/layout-first-offset closure-block))) - -(define (closure-ccenv/get-value environment) - (lambda (index) - (closure/get-value (closure-ccenv/closure environment) - (closure-ccenv/closure-block environment) - index))) - + (define (closure-ccenv/has-parent? environment) (or (let ((stack-block (closure-ccenv/stack-block environment))) (let ((parent (dbg-block/parent stack-block))) @@ -871,7 +840,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((CELL) (let ((value (get-value index))) (if (not (cell? value)) - (error "Value of variable should be in cell" + (error "Value of variable should be in cell:" variable value)) (cell-contents value))) ((INTEGRATED) @@ -879,9 +848,37 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((INDIRECTED) (loop (dbg-variable/name (dbg-variable/value variable)))) (else - (error "Unknown variable type" variable)))) + (error "Unknown variable type:" variable)))) (not-found name))))) +(define (dbg-variable-reference-type block name get-value not-found) + (let ((value->reference-type + (lambda (value) + (cond ((unassigned-reference-trap? value) 'UNASSIGNED) + ((macro-reference-trap? value) 'MACRO) + (else 'NORMAL))))) + (let loop ((name name)) + (let ((index (dbg-block/find-name block name))) + (if index + (let ((variable + (vector-ref (dbg-block/layout-vector block) index))) + (case (dbg-variable/type variable) + ((NORMAL) + (value->reference-type (get-value index))) + ((CELL) + (let ((value (get-value index))) + (if (not (cell? value)) + (error "Value of variable should be in cell" + variable value)) + (value->reference-type (cell-contents value)))) + ((INTEGRATED) + (value->reference-type (dbg-variable/value variable))) + ((INDIRECTED) + (loop (dbg-variable/name (dbg-variable/value variable)))) + (else + (error "Unknown variable type:" variable)))) + (not-found name)))))) + (define (assignable-dbg-variable? block name not-found) (let ((index (dbg-block/find-name block name))) (if index @@ -899,13 +896,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((CELL) (let ((cell (get-value index))) (if (not (cell? cell)) - (error "Value of variable should be in cell" name cell)) + (error "Value of variable should be in cell:" name cell)) (set-cell-contents! cell value) unspecific)) ((NORMAL INTEGRATED INDIRECTED) - (error "Variable cannot be side-effected" variable)) + (error "Variable cannot be modified:" variable)) (else - (error "Unknown variable type" variable)))) + (error "Unknown variable type:" variable)))) (not-found name)))) (define (dbg-block/name block)