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

diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm
index 1fddad9fa4a306472f0f8a64818a9e1184f66f5e..1fb57d5278fc01d2566757fae902ec0b0c7dff98 100644 (file)
--- 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 158afb53f147a8254b6817ea77cd4c9aeb546ce3..126d6cf9caa1012744a7780d2cf23c213d0c728d 100644 (file)
--- 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 2ddb9d572cc212e779a1d2b5cee18a7e95598dec..6744c8ff25df11dff5588e11eb8f4a3a7159cc0f 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.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)))
 \f
+(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")))))))))
 \f
 (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 e15a21e253b76ab415ffd04a2ae7dcbf42792162..1b0e22e2a589e88cf864f058f06a369f353048fc 100644 (file)
--- 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 d8f8da8d618f9fc73ee29731ea52e5ced5fb4c41..ae718ec0c0da3b63553c18386f9694a3fee1643c 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.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)))
 \f
+(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")))))))))
 \f
 (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