Add sf/usual-integrations-default-deletions.

diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm
index 987f6dbc9ccde489f748dcf68ffa2c3a60ca3267..5166dde5d1f807f7dea99b6ea7eac0a8ead16f47 100644 (file)
--- a/v7/src/sf/pardec.scm
+++ b/v7/src/sf/pardec.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.1 1988/06/13 12:29:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.2 1988/10/30 14:31:20 jinx Rel $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -193,25 +193,27 @@ MIT in each case. |#
 (define-declaration 'USUAL-INTEGRATIONS true
   (lambda (block table/cons table deletions)
     block                              ;ignored
-    (let ((finish
-          (lambda (table operation names vals)
-            (with-values
-                (lambda ()
-                  (if (null? deletions)
-                      (values names vals)
-                      (let deletion-loop ((names names) (vals vals))
-                        (cond ((null? names) (values '() '()))
-                              ((memq (car names) deletions)
-                               (deletion-loop (cdr names) (cdr vals)))
-                              (else
-                               (with-values
-                                   (lambda ()
-                                     (deletion-loop (cdr names) (cdr vals)))
-                                 (lambda (names* vals*)
-                                   (values (cons (car names) names*)
-                                           (cons (car vals) vals*)))))))))
-              (lambda (names vals)
-                (bind/values table/cons table operation false names vals))))))
+    (let* ((deletions (append sf/usual-integrations-default-deletions
+                             deletions))
+          (finish
+           (lambda (table operation names vals)
+             (with-values
+                 (lambda ()
+                   (if (null? deletions)
+                       (values names vals)
+                       (let deletion-loop ((names names) (vals vals))
+                         (cond ((null? names) (values '() '()))
+                               ((memq (car names) deletions)
+                                (deletion-loop (cdr names) (cdr vals)))
+                               (else
+                                (with-values
+                                    (lambda ()
+                                      (deletion-loop (cdr names) (cdr vals)))
+                                  (lambda (names* vals*)
+                                    (values (cons (car names) names*)
+                                            (cons (car vals) vals*)))))))))
+               (lambda (names vals)
+                 (bind/values table/cons table operation false names vals))))))
       (finish (finish table 'INTEGRATE
                      usual-integrations/constant-names
                      usual-integrations/constant-values)

diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm
index 8de895da170d54344e20e050acc0345e7059a7d1..5bf3cfd165d25713f7c055084de4e6a2cbdb7f54 100644 (file)
--- a/v7/src/sf/toplev.scm
+++ b/v7/src/sf/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.2 1988/10/29 00:07:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.3 1988/10/30 14:27:50 jinx Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -72,6 +72,12 @@ Currently only the 68000 implementation needs this."
                        (pathname/normalize pathname)
                        syntax-table))
 
+(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))
+  (set! sf/usual-integrations-default-deletions del-list))
+
 (define (sf/add-file-declarations! pathname declarations)
   (let ((pathname (pathname/normalize pathname)))
     (pathname-map/insert! file-info/declarations
@@ -109,6 +115,9 @@ Currently only the 68000 implementation needs this."
 (define sf/top-level-definitions
   '())
 
+(define sf/usual-integrations-default-deletions
+  '())
+
 (define (list-of-symbols? object)
   (or (null? object)
       (and (pair? object)

diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm
index b48a5edaf4c56a403cde7637b00fc7632922c644..36b05262020a1e4087a49a46f5975792b66fbf86 100644 (file)
--- a/v8/src/sf/toplev.scm
+++ b/v8/src/sf/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.2 1988/10/29 00:07:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.3 1988/10/30 14:27:50 jinx Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -72,6 +72,12 @@ Currently only the 68000 implementation needs this."
                        (pathname/normalize pathname)
                        syntax-table))
 
+(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))
+  (set! sf/usual-integrations-default-deletions del-list))
+
 (define (sf/add-file-declarations! pathname declarations)
   (let ((pathname (pathname/normalize pathname)))
     (pathname-map/insert! file-info/declarations
@@ -109,6 +115,9 @@ Currently only the 68000 implementation needs this."
 (define sf/top-level-definitions
   '())
 
+(define sf/usual-integrations-default-deletions
+  '())
+
 (define (list-of-symbols? object)
   (or (null? object)
       (and (pair? object)