From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Mon, 26 Mar 1990 20:49:53 +0000 (+0000)
Subject: Add sf:noisy? flag, and syntax&integrate global procedure.
X-Git-Tag: 20090517-FFI~11496
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e830b503e3244121e466110e977c64b4b0c66758;p=mit-scheme.git

Add sf:noisy? flag, and syntax&integrate global procedure.
---

diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm
index 1fddad9fa..1fb57d527 100644
--- a/v7/src/sf/make.scm
+++ b/v7/src/sf/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.9 1989/10/26 06:28:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.10 1990/03/26 20:49:53 jinx Exp $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -39,4 +39,4 @@ MIT in each case. |#
 (package/system-loader "sf" '() 'QUERY)
 ((package/reference (find-package '(SCODE-OPTIMIZER))
 		    'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 9 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 10 '()))
\ No newline at end of file
diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg
index 158afb53f..126d6cf9c 100644
--- a/v7/src/sf/sf.pkg
+++ b/v7/src/sf/sf.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.pkg,v 4.5 1989/06/09 16:56:32 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.pkg,v 4.6 1990/03/26 20:45:32 jinx Rel $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -60,6 +60,7 @@ MIT in each case. |#
   (parent (scode-optimizer))
   (export ()
 	  sf
+	  sf:noisy?
 	  sf/add-file-declarations!
 	  sf/default-declarations
 	  sf/default-syntax-table
@@ -69,7 +70,9 @@ MIT in each case. |#
 	  sf/top-level-definitions
 	  sf/usual-integrations-default-deletions
 	  sf/set-usual-integrations-default-deletions!
-	  sfu?)
+	  sfu?
+	  syntax&integrate
+	  )
   (export (scode-optimizer)
 	  integrate/procedure
 	  integrate/file
diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm
index 2ddb9d572..6744c8ff2 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.5 1989/12/07 05:39:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.6 1990/03/26 20:44:52 jinx Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -63,7 +63,18 @@ MIT in each case. |#
 Currently only the 68000 implementation needs this."
   (fluid-let ((wrapping-hook wrap-with-control-point))
     (syntax-file input-string bin-string spec-string)))
+
+(define (syntax&integrate s-expression declarations #!optional syntax-table)
+  (fluid-let ((sf:noisy? false))
+    (integrate/sexp s-expression
+		    (if (default-object? syntax-table)
+			(nearest-repl/syntax-table)
+			syntax-table)
+		    declarations
+		    false)))
 
+(define sf:noisy? true)
+
 (define (sf/set-default-syntax-table! syntax-table)
   (set! sf/default-syntax-table syntax-table))
 
@@ -203,13 +214,15 @@ Currently only the 68000 implementation needs this."
 	  (input-filename (pathname->string input-pathname))
 	  (bin-filename (pathname->string bin-pathname))
 	  (spec-filename (and spec-pathname (pathname->string spec-pathname))))
-      (newline)
-      (write-string "Syntax file: ")
-      (write input-filename)
-      (write-string " ")
-      (write bin-filename)
-      (write-string " ")
-      (write spec-filename)
+      (if sf:noisy?
+	  (begin
+	    (newline)
+	    (write-string "Syntax file: ")
+	    (write input-filename)
+	    (write-string " ")
+	    (write bin-filename)
+	    (write-string " ")
+	    (write spec-filename)))
       (with-values
 	  (lambda ()
 	    (integrate/file input-pathname syntax-table declarations
@@ -230,9 +243,11 @@ Currently only the 68000 implementation needs this."
 			       (pathname-type sf/default-externs-pathname))
 			      (set! externs false))
 	  (if spec-pathname
-	      (begin (newline)
-		     (write-string "Writing ")
-		     (write spec-filename)
+	      (begin (if sf:noisy?
+			 (begin
+			   (newline)
+			   (write-string "Writing ")
+			   (write spec-filename)))
 		     (with-output-to-file spec-pathname
 		       (lambda ()
 			 (newline)
@@ -251,7 +266,8 @@ Currently only the 68000 implementation needs this."
 				     (write `(,(car event)
 					      (RUNTIME ,(cdr event)))))
 				   events)))
-		     (write-string " -- done"))))))))
+		     (if sf:noisy?
+			 (write-string " -- done")))))))))
 
 (define (read-externs-file pathname)
   (let ((pathname
@@ -267,6 +283,9 @@ Currently only the 68000 implementation needs this."
 	((file-exists? pathname)
 	 (delete-file pathname))))
 
+#|
+;; This seems unused
+
 (define (print-spec identifier names)
   (newline)
   (newline)
@@ -283,6 +302,7 @@ Currently only the 68000 implementation needs this."
 	       (write (car names))
 	       (loop (cdr names)))))
   (write-string ")"))
+|#
 
 (define (wrapping-hook scode)
   scode)
@@ -384,10 +404,12 @@ Currently only the 68000 implementation needs this."
 
 (define (mark-phase this-name)
   (end-phase)
-  (newline)
-  (write-string "    ")
-  (write-string this-name)
-  (write-string "...")
+  (if sf:noisy?
+      (begin
+	(newline)
+	(write-string "    ")
+	(write-string this-name)
+	(write-string "...")))
   (set! previous-name this-name))
 
 (define (end-phase)
@@ -404,10 +426,12 @@ Currently only the 68000 implementation needs this."
 
 ;; Should match the compiler.  We'll merge the two at some point.
 (define (time-report prefix process-time real-time)
-  (newline)
-  (write-string prefix)
-  (write-string ": ")
-  (write (/ (exact->inexact process-time) 1000))
-  (write-string " (process time); ")
-  (write (/ (exact->inexact real-time) 1000))
-  (write-string " (real time)"))
\ No newline at end of file
+  (if sf:noisy?
+      (begin
+	(newline)
+	(write-string prefix)
+	(write-string ": ")
+	(write (/ (exact->inexact process-time) 1000))
+	(write-string " (process time); ")
+	(write (/ (exact->inexact real-time) 1000))
+	(write-string " (real time)"))))
\ No newline at end of file
diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm
index e15a21e25..1b0e22e2a 100644
--- a/v8/src/sf/make.scm
+++ b/v8/src/sf/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.9 1989/10/26 06:28:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.10 1990/03/26 20:49:53 jinx Exp $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -39,4 +39,4 @@ MIT in each case. |#
 (package/system-loader "sf" '() 'QUERY)
 ((package/reference (find-package '(SCODE-OPTIMIZER))
 		    'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 9 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 10 '()))
\ No newline at end of file
diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm
index d8f8da8d6..ae718ec0c 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.5 1989/12/07 05:39:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.6 1990/03/26 20:44:52 jinx Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -63,7 +63,18 @@ MIT in each case. |#
 Currently only the 68000 implementation needs this."
   (fluid-let ((wrapping-hook wrap-with-control-point))
     (syntax-file input-string bin-string spec-string)))
+
+(define (syntax&integrate s-expression declarations #!optional syntax-table)
+  (fluid-let ((sf:noisy? false))
+    (integrate/sexp s-expression
+		    (if (default-object? syntax-table)
+			(nearest-repl/syntax-table)
+			syntax-table)
+		    declarations
+		    false)))
 
+(define sf:noisy? true)
+
 (define (sf/set-default-syntax-table! syntax-table)
   (set! sf/default-syntax-table syntax-table))
 
@@ -203,13 +214,15 @@ Currently only the 68000 implementation needs this."
 	  (input-filename (pathname->string input-pathname))
 	  (bin-filename (pathname->string bin-pathname))
 	  (spec-filename (and spec-pathname (pathname->string spec-pathname))))
-      (newline)
-      (write-string "Syntax file: ")
-      (write input-filename)
-      (write-string " ")
-      (write bin-filename)
-      (write-string " ")
-      (write spec-filename)
+      (if sf:noisy?
+	  (begin
+	    (newline)
+	    (write-string "Syntax file: ")
+	    (write input-filename)
+	    (write-string " ")
+	    (write bin-filename)
+	    (write-string " ")
+	    (write spec-filename)))
       (with-values
 	  (lambda ()
 	    (integrate/file input-pathname syntax-table declarations
@@ -230,9 +243,11 @@ Currently only the 68000 implementation needs this."
 			       (pathname-type sf/default-externs-pathname))
 			      (set! externs false))
 	  (if spec-pathname
-	      (begin (newline)
-		     (write-string "Writing ")
-		     (write spec-filename)
+	      (begin (if sf:noisy?
+			 (begin
+			   (newline)
+			   (write-string "Writing ")
+			   (write spec-filename)))
 		     (with-output-to-file spec-pathname
 		       (lambda ()
 			 (newline)
@@ -251,7 +266,8 @@ Currently only the 68000 implementation needs this."
 				     (write `(,(car event)
 					      (RUNTIME ,(cdr event)))))
 				   events)))
-		     (write-string " -- done"))))))))
+		     (if sf:noisy?
+			 (write-string " -- done")))))))))
 
 (define (read-externs-file pathname)
   (let ((pathname
@@ -267,6 +283,9 @@ Currently only the 68000 implementation needs this."
 	((file-exists? pathname)
 	 (delete-file pathname))))
 
+#|
+;; This seems unused
+
 (define (print-spec identifier names)
   (newline)
   (newline)
@@ -283,6 +302,7 @@ Currently only the 68000 implementation needs this."
 	       (write (car names))
 	       (loop (cdr names)))))
   (write-string ")"))
+|#
 
 (define (wrapping-hook scode)
   scode)
@@ -384,10 +404,12 @@ Currently only the 68000 implementation needs this."
 
 (define (mark-phase this-name)
   (end-phase)
-  (newline)
-  (write-string "    ")
-  (write-string this-name)
-  (write-string "...")
+  (if sf:noisy?
+      (begin
+	(newline)
+	(write-string "    ")
+	(write-string this-name)
+	(write-string "...")))
   (set! previous-name this-name))
 
 (define (end-phase)
@@ -404,10 +426,12 @@ Currently only the 68000 implementation needs this."
 
 ;; Should match the compiler.  We'll merge the two at some point.
 (define (time-report prefix process-time real-time)
-  (newline)
-  (write-string prefix)
-  (write-string ": ")
-  (write (/ (exact->inexact process-time) 1000))
-  (write-string " (process time); ")
-  (write (/ (exact->inexact real-time) 1000))
-  (write-string " (real time)"))
\ No newline at end of file
+  (if sf:noisy?
+      (begin
+	(newline)
+	(write-string prefix)
+	(write-string ": ")
+	(write (/ (exact->inexact process-time) 1000))
+	(write-string " (process time); ")
+	(write (/ (exact->inexact real-time) 1000))
+	(write-string " (real time)"))))
\ No newline at end of file