From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Sun, 30 Oct 1988 14:31:20 +0000 (+0000)
Subject: Add sf/usual-integrations-default-deletions.
X-Git-Tag: 20090517-FFI~12471
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=625239220b10f1980759ec3a920fd7113872949c;p=mit-scheme.git

Add sf/usual-integrations-default-deletions.
---

diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm
index 987f6dbc9..5166dde5d 100644
--- 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 8de895da1..5bf3cfd16 100644
--- 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 b48a5edaf..36b052620 100644
--- 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)