Add guarantees, minor cleanups.

diff --git a/src/sf/chtype.scm b/src/sf/chtype.scm
index 8e565e5b93ae4f460ea0b2e9357ecb7cb2b24c1f..4f404aa8b6c3ad5a410d5e9e005c95c8a832b04d 100644 (file)
--- 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)
 \f
 (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 e5e97daec270efd43684e4e291a17048a998b46e..f296ec5d1300763c11ede2ab168d0530a054fbae 100644 (file)
--- 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 3c83b5abcf307a9bdb7493428f09a608bb058bd6..4386887d8054f796050068db6453f099bbf6eb36 100644 (file)
--- a/src/sf/emodel.scm
+++ b/src/sf/emodel.scm
@@ -30,6 +30,7 @@ USA.
         (integrate-external "object"))
 \f
 (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 01b991e43b84398705ceda780b6718893cf1c0cd..9378d8d08ac17a620397c45d2c3997015142685e 100644 (file)
--- 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)))))
 \f
 ;;;; 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)