From: Joe Marshall Date: Tue, 9 Feb 2010 23:30:08 +0000 (-0800) Subject: Move environment table to tables. X-Git-Tag: 20100708-Gtk~168^2~13 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=34bfbb380a177459e379454c55af5ec01452e605;p=mit-scheme.git Move environment table to tables. --- diff --git a/src/sf/subst.scm b/src/sf/subst.scm index dfac87893..34175c1cc 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -339,22 +339,8 @@ USA. (define (integrate/primitive-operator expression operations environment block operator operands) - (let ((integration-failure - (lambda () - (combination/optimizing-make expression block operator operands)))) - (operations/lookup operations (constant/value operator) - (lambda (operation info) - (case operation - ((#F) (integration-failure)) - ((EXPAND) - (info expression - operands - (lambda (expression) - (integrate/expression operations environment expression)) - integration-failure - block)) - (else (error "Unknown operation" operation)))) - integration-failure))) + (declare (ignore operations environment)) + (combination/optimizing-make expression block operator operands)) ;;; ((let ((a (foo)) (b (bar))) ;;; (lambda (receiver) @@ -737,29 +723,6 @@ USA. (warn "Unable to integrate" (variable/name variable)) (if-not)))) -(define *unknown-value "Unknown Value") - -(define (simulate-unknown-application environment procedure) - (define (bind-required environment required) - (if (null? required) - (bind-optional environment (procedure/optional procedure)) - (bind-required - (environment/bind environment (car required) *unknown-value) - (cdr required)))) - - (define (bind-optional environment optional) - (if (null? optional) - (bind-rest environment (procedure/rest procedure)) - (bind-optional - (environment/bind environment (car optional) *unknown-value) - (cdr optional)))) - - (define (bind-rest environment rest) - (if (null? rest) - environment - (environment/bind environment rest *unknown-value))) - - (bind-required environment (procedure/required procedure))) (define (integrate/hack-apply? operands) (define (check operand) @@ -788,94 +751,6 @@ USA. (append (except-last-pair operands) tail))))) -(define (simulate-application environment block procedure operands) - (define (procedure->pretty procedure) - (if (procedure/scode procedure) - (unsyntax (procedure/scode procedure)) - (let ((arg-list (append (procedure/required procedure) - (if (null? (procedure/optional procedure)) - '() - (cons lambda-tag:optional - (procedure/optional procedure))) - (if (not (procedure/rest procedure)) - '() - (procedure/rest procedure))))) - (if (procedure/name procedure) - `(named-lambda (,(procedure/name procedure) ,@arg-list) - ...) - `(lambda ,arg-list - ...))))) - - (define (match-required environment required operands) - (cond ((null? required) - (match-optional environment - (procedure/optional procedure) - operands)) - ((null? operands) - (error "Too few operands in call to procedure" - procedure - (procedure->pretty procedure))) - (else - (match-required (environment/bind environment - (car required) - (car operands)) - (cdr required) - (cdr operands))))) - - (define (match-optional environment optional operands) - (cond ((null? optional) - (match-rest environment (procedure/rest procedure) operands)) - ((null? operands) - (match-rest environment (procedure/rest procedure) '())) - (else - (match-optional (environment/bind environment - (car optional) - (car operands)) - (cdr optional) - (cdr operands))))) - - (define (listify-tail operands) - (let ((const-null (constant/make #f '()))) - (if (null? operands) - const-null - (let ((const-cons (constant/make #f (ucode-primitive cons)))) - (let walk ((operands operands)) - (if (null? operands) - const-null - (combination/make #f - block - const-cons - (list (car operands) - (walk (cdr operands)))))))))) - - (define (match-rest environment rest operands) - (cond (rest - (environment/bind environment rest (listify-tail operands))) - ((null? operands) - environment) - (else - (error "Too many operands in call to procedure" - procedure - (procedure->pretty procedure))))) - - (match-required environment (procedure/required procedure) operands)) - -(define (environment/make) - '()) - -(define-integrable (environment/bind environment variable value) - (cons (cons variable value) environment)) - -(define-integrable (environment/bind-multiple environment variables values) - (map* environment cons variables values)) - -(define (environment/lookup environment variable if-found if-unknown if-not) - (let ((association (assq variable environment))) - (if association - (if (eq? (cdr association) *unknown-value) - (if-unknown) - (if-found (cdr association))) - (if-not)))) (define (delayed-integration/in-progress? delayed-integration) (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED)) diff --git a/src/sf/tables.scm b/src/sf/tables.scm index 711bb1795..3161021cd 100644 --- a/src/sf/tables.scm +++ b/src/sf/tables.scm @@ -29,12 +29,164 @@ USA. (declare (usual-integrations) (integrate-external "object")) +;;;; Environment + +;; An environment is implemented as an alist mapping a variable +;; to one of three things, a value, an unknown-value marker, or +;; a delayed integration. + +(define (environment/make) + '()) + +(define (environment/bind environment variable value) + (guarantee-variable variable 'environment/bind) + (alist-cons variable value environment)) + +(define-integrable (environment/bind-multiple environment variables values) + (map* environment cons variables values)) + +(define (environment/lookup environment variable if-found if-unknown if-not) + (let ((association (assq variable environment))) + (if association + (if (eq? (cdr association) *unknown-value) + (if-unknown) + (if-found (cdr association))) + (if-not)))) + +(define *unknown-value (string-copy "Unknown Value")) + +;; Extend the environment with bindings for the formal parameters. +;; Each binding is given the *unknown-value object. +(define (simulate-unknown-application environment procedure) + (define (bind-required environment required) + (if (null? required) + (bind-optional environment (procedure/optional procedure)) + (bind-required + (environment/bind environment (car required) *unknown-value) + (cdr required)))) + + (define (bind-optional environment optional) + (if (null? optional) + (bind-rest environment (procedure/rest procedure)) + (bind-optional + (environment/bind environment (car optional) *unknown-value) + (cdr optional)))) + + (define (bind-rest environment rest) + (if rest + (environment/bind environment rest *unknown-value) + environment)) + + (bind-required environment (procedure/required procedure))) + +;; Extend the environment with actual bindings for the formal +;; parameters. If the arity does not match, issue a warning +;; and fall back to the unknown case. +(define (simulate-application base-environment block procedure operands) + (define (procedure->pretty procedure) + (if (procedure/scode procedure) + (unsyntax (procedure/scode procedure)) + (let ((arg-list (append (procedure/required procedure) + (if (null? (procedure/optional procedure)) + '() + (cons lambda-tag:optional + (procedure/optional procedure))) + (if (not (procedure/rest procedure)) + '() + (procedure/rest procedure))))) + (if (procedure/name procedure) + `(named-lambda (,(procedure/name procedure) ,@arg-list) + ...) + `(lambda ,arg-list + ...))))) + + (define (fail message . irritants) + (apply warn message irritants) + (simulate-unknown-application base-environment procedure)) + + (define (match-required environment required remaining-operands) + (cond ((pair? required) + (cond ((pair? remaining-operands) + (match-required (environment/bind environment + (car required) + (car remaining-operands)) + (cdr required) + (cdr remaining-operands))) + ((null? remaining-operands) + (fail "Too few operands in call to procedure" + procedure + (procedure->pretty procedure))) + (else + (fail "Improper list of operands in application" + procedure + (procedure->pretty procedure) + operands)))) + + ((null? required) + (match-optional environment + (procedure/optional procedure) + remaining-operands)) + + ;; impossible? + (else (error "INTERNAL ERROR: Required argument list is improper" + required)))) + + (define (match-optional environment optional remaining-operands) + (cond ((pair? optional) + (cond ((pair? remaining-operands) + (match-optional (environment/bind environment + (car optional) + (car remaining-operands)) + (cdr optional) + (cdr remaining-operands))) + ((null? remaining-operands) + (match-rest environment (procedure/rest procedure) '())) + (else + (fail "Improper list of operands in application" + procedure + (procedure->pretty procedure) + operands)))) + + ((null? optional) + (match-rest environment (procedure/rest procedure) remaining-operands)) + ;; impossible? + (else (error "INTERNAL ERROR: Required argument list is improper" + required)))) + + (define (listify-tail operands) + (fold-right + (lambda (operand tail) + (combination/make #f + block + (constant/make #f (ucode-primitive cons)) + (list operand tail))) + (constant/make #f '()) + operands)) + + (define (match-rest environment rest remaining-operands) + (cond (rest + (environment/bind environment rest (listify-tail remaining-operands))) + ((null? remaining-operands) + environment) + (else + (fail "Too many operands in call to procedure" + procedure + (procedure->pretty procedure) + operands)))) + + (match-required base-environment (procedure/required procedure) operands)) + ;;;; Operations +;; An operations table is a cons of two alists. The first alist +;; contains the lexically visible operations, the second contains +;; the global operations. + (define (operations/make) (cons '() '())) (define (operations/lookup operations variable if-found if-not) + (guarantee-variable variable 'operations/lookup) (let ((entry (assq variable (car operations)))) (if entry (if (cdr entry) @@ -45,18 +197,34 @@ USA. (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 + (if-found (cadr probe) (cddr probe)) + (if-not)))) + (define (operations/shadow operations variables) (cons (map* (car operations) - (lambda (variable) (cons variable false)) + (lambda (variable) + (guarantee-variable variable 'operations/shadow) + (cons variable false)) variables) (cdr operations))) (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))) (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)))) @@ -69,4 +237,4 @@ USA. (cons (procedure (cadar elements) (caar elements) (cddar elements)) (loop (cdr elements)))) (else - (loop (cdr elements)))))) \ No newline at end of file + (loop (cdr elements))))))