From: Joe Marshall Date: Tue, 9 Feb 2010 23:24:55 +0000 (-0800) Subject: Add guarantees, minor cleanups. X-Git-Tag: 20100708-Gtk~168^2~14 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a5cf57c87822452aa1994187542a36dbedcc57b9;p=mit-scheme.git Add guarantees, minor cleanups. --- diff --git a/src/sf/chtype.scm b/src/sf/chtype.scm index 8e565e5b9..4f404aa8b 100644 --- a/src/sf/chtype.scm +++ b/src/sf/chtype.scm @@ -79,9 +79,7 @@ USA. (change-type/expression (conditional/alternative expression)))) (define-method/change-type 'CONSTANT - (lambda (expression) - expression ; ignored - 'DONE)) + false-procedure) (define-method/change-type 'DECLARATION (lambda (expression) @@ -96,39 +94,28 @@ USA. (change-type/expression (disjunction/predicate expression)) (change-type/expression (disjunction/alternative expression)))) -(define-method/change-type 'PROCEDURE - (lambda (expression) - (change-type/expression (procedure/body expression)))) - (define-method/change-type 'OPEN-BLOCK (lambda (expression) (change-type/expressions (open-block/values expression)) - (change-type/open-block-actions (open-block/actions expression)))) + (for-each (lambda (action) + (if (not (eq? action open-block/value-marker)) + (change-type/expression action))) + (open-block/actions expression)))) -(define (change-type/open-block-actions actions) - (cond ((null? actions) 'DONE) - ((eq? (car actions) open-block/value-marker) - (change-type/open-block-actions (cdr actions))) - (else (change-type/expression (car actions)) - (change-type/open-block-actions (cdr actions))))) +(define-method/change-type 'PROCEDURE + (lambda (expression) + (change-type/expression (procedure/body expression)))) (define-method/change-type 'QUOTATION (lambda (expression) - (change-type/quotation expression))) - -(define (change-type/quotation quotation) - (change-type/expression (quotation/expression quotation))) + (change-type/expression (quotation/expression expression)))) (define-method/change-type 'REFERENCE - (lambda (expression) - expression ; ignored - 'DONE)) + false-procedure) (define-method/change-type 'SEQUENCE (lambda (expression) (change-type/expressions (sequence/actions expression)))) (define-method/change-type 'THE-ENVIRONMENT - (lambda (expression) - expression ; ignored - 'DONE)) \ No newline at end of file + false-procedure) \ No newline at end of file diff --git a/src/sf/copy.scm b/src/sf/copy.scm index e5e97daec..f296ec5d1 100644 --- a/src/sf/copy.scm +++ b/src/sf/copy.scm @@ -34,12 +34,14 @@ USA. (define copy/declarations) (define (copy/expression/intern block expression) + (guarantee-block block 'copy/expression/intern) (fluid-let ((root-block block) (copy/variable/free copy/variable/free/intern) (copy/declarations copy/declarations/intern)) (copy/expression block (environment/make) expression))) (define (copy/expression/extern block expression) + (guarantee-block block 'copy/expression/extern) (fluid-let ((root-block block) (copy/variable/free copy/variable/free/extern) (copy/declarations copy/declarations/extern)) @@ -67,6 +69,7 @@ USA. (map* environment cons variables values)) (define (environment/lookup environment variable if-found if-not) + (guarantee-variable variable 'environment/lookup) (let ((association (assq variable environment))) (if association (if-found (cdr association)) @@ -82,6 +85,7 @@ USA. (define (make-renamer environment) (lambda (variable) + (guarantee-variable variable) (environment/lookup environment variable identity-procedure (lambda () (error "Variable missing during copy operation:" variable))))) @@ -115,7 +119,7 @@ USA. (values result environment))))) (define (copy/variable block environment variable) - block ;ignored + (declare (ignore block)) (environment/lookup environment variable identity-procedure (lambda () (copy/variable/free variable)))) @@ -143,7 +147,7 @@ USA. (block/lookup-name root-block (variable/name variable) true)) (define (copy/declarations/intern block environment declarations) - block ;ignored + (declare (ignore block)) (if (null? declarations) '() (declarations/map declarations @@ -195,13 +199,11 @@ USA. (conditional/scode expression) (copy/expression block environment (conditional/predicate expression)) (copy/expression block environment (conditional/consequent expression)) - (copy/expression block - environment - (conditional/alternative expression))))) + (copy/expression block environment (conditional/alternative expression))))) (define-method/copy 'CONSTANT (lambda (block environment expression) - block environment ;ignored + (declare (ignore block environment)) expression)) (define-method/copy 'DECLARATION @@ -266,7 +268,7 @@ USA. (define-method/copy 'QUOTATION (lambda (block environment expression) - block environment ;ignored + (declare (ignore block environment)) (copy/quotation expression))) (define-method/copy 'REFERENCE @@ -284,5 +286,5 @@ USA. (define-method/copy 'THE-ENVIRONMENT (lambda (block environment expression) - block environment expression ;ignored + (declare (ignore block environment expression)) (error "Attempt to integrate expression containing (THE-ENVIRONMENT)"))) \ No newline at end of file diff --git a/src/sf/emodel.scm b/src/sf/emodel.scm index 3c83b5abc..4386887d8 100644 --- a/src/sf/emodel.scm +++ b/src/sf/emodel.scm @@ -30,6 +30,7 @@ USA. (integrate-external "object")) (define (variable/make&bind! block name) + (guarantee-symbol name 'variable/make&bind!) (or (%block/lookup-name block name) (%variable/make&bind! block name))) @@ -40,6 +41,7 @@ USA. variable)) (define (block/lookup-name block name intern?) + (guarantee-symbol name 'block/lookup-name) (let search ((block block)) (or (%block/lookup-name block name) (if (block/parent block) @@ -52,6 +54,7 @@ USA. (eq? (variable/name variable) name)))) (define (block/limited-lookup block name limit) + (guarantee-symbol name 'block/limited-lookup) (let search ((block block)) (and (not (eq? block limit)) (or (%block/lookup-name block name) diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm index 01b991e43..9378d8d08 100644 --- a/src/sf/toplev.scm +++ b/src/sf/toplev.scm @@ -63,9 +63,8 @@ USA. (define sf:noisy? #t) (define (sf/set-usual-integrations-default-deletions! del-list) - (if (not (list-of-symbols? del-list)) - (error "sf/set-usual-integrations-default-deletions!: Bad deletion list" - del-list)) + (guarantee-list-of-type del-list symbol? "list of symbols" + 'sf/set-usual-integrations-default-deletions!) (set! sf/usual-integrations-default-deletions del-list) unspecific) @@ -83,22 +82,12 @@ USA. (define sf/usual-integrations-default-deletions '()) - -(define (list-of-symbols? object) - (or (null? object) - (and (pair? object) - (symbol? (car object)) - (list-of-symbols? (cdr object))))) ;;;; File Syntaxer (define (syntax-file input-string bin-string spec-string) - (if (not (environment? sf/default-syntax-table)) - (error "Malformed binding of SF/DEFAULT-SYNTAX-TABLE:" - sf/default-syntax-table)) - (if (not (list-of-symbols? sf/top-level-definitions)) - (error "Malformed binding of SF/TOP-LEVEL-DEFINITIONS:" - sf/top-level-definitions)) + (guarantee-environment sf/default-syntax-table 'syntax-file) + (guarantee-list-of-type sf/top-level-definitions symbol? 'syntax-file) (for-each (lambda (input-string) (receive (input-pathname bin-pathname spec-pathname) (sf/pathname-defaulting input-string bin-string spec-string)