Add support for M-x print-graphics.

diff --git a/v7/src/6001/6001.pkg b/v7/src/6001/6001.pkg
index 2a4329dda753207e69e084fdf21470071bd4a8d5..c1fcba654beafe0eb93dca0489c52c35cd4c5f50 100644 (file)
--- a/v7/src/6001/6001.pkg
+++ b/v7/src/6001/6001.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.pkg,v 1.4 1992/07/18 02:26:55 hal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.pkg,v 1.5 1992/09/01 20:11:17 cph Exp $
 
 Copyright (c) 1991-92 Massachusetts Institute of Technology
 
@@ -144,4 +144,10 @@ MIT in each case. |#
          ;picture-scale
          ;picture-set!
          ;picture-v-reflect
-         ))
\ No newline at end of file
+         ))
+
+(define-package (edwin student)
+  (files "edextra")
+  (parent (edwin))
+  (export (edwin)
+         edwin-command$print-graphics))
\ No newline at end of file

diff --git a/v7/src/6001/6001.sf b/v7/src/6001/6001.sf
index 08f69b0e225df2f81b7e1a32d37e70443f137b29..bd2bae8199e585f857d0c8b2483cfbd2478b49c6 100644 (file)
--- a/v7/src/6001/6001.sf
+++ b/v7/src/6001/6001.sf
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.sf,v 1.4 1992/03/25 21:44:49 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.sf,v 1.5 1992/09/01 20:12:08 cph Exp $
 
 Copyright (c) 1991-92 Massachusetts Institute of Technology
 
@@ -37,6 +37,9 @@ MIT in each case. |#
            '("arith" "make" "nodefs" "picture" "pic-record" "pic-image"
                      "pic-read" "pic-ops")))
 
+(fluid-let ((sf/default-syntax-table edwin-syntax-table))
+  (sf-conditionally "edextra"))
+
 ;; Guarantee that the package modeller is loaded.
 (if (not (name->package '(CROSS-REFERENCE)))
     (with-working-directory-pathname "../cref"

diff --git a/v7/src/6001/picture.scm b/v7/src/6001/picture.scm
index efb32ac1611440b381f43b1947415d028636f023..7a8357c07394f0f6b324c3989faef7c1c5c6d14f 100644 (file)
--- a/v7/src/6001/picture.scm
+++ b/v7/src/6001/picture.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/picture.scm,v 1.12 1992/06/11 17:31:22 u6001 Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/picture.scm,v 1.13 1992/09/01 20:07:09 cph Exp $
 
 Copyright (c) 1991-92 Massachusetts Institute of Technology
 
@@ -250,6 +250,7 @@ MIT in each case. |#
       (lambda ()
        (graphics-device-coordinate-limits window))
     (lambda (x1 y1 x2 y2)
+      (set! *last-picture-displayed* pic)
       (graphics-set-coordinate-limits window 0 (- y1 y2) (- x2 x1) 0)
       (let* ((win-wid (fix:+ 1 (fix:- x2 x1)))
             (win-hgt (fix:+ 1 (fix:- y1 y2)))
@@ -282,6 +283,17 @@ MIT in each case. |#
              (if (and true-min-max? (not image-cached?))
                  (picture-set-image! pic image))))))))
 
+(define (call-with-last-picture-file procedure)
+  (if *last-picture-displayed*
+      (call-with-temporary-filename
+       (lambda (filename)
+        (picture->pgm-file *last-picture-displayed*)
+        (procedure filename)))
+      (procedure false)))
+
+(define *last-picture-displayed*
+  false)
+
 (define (picture-write picture filename)
   (let ((path-name  (->pathname filename)))
     (if (picture? picture)

diff --git a/v7/src/edwin/print.scm b/v7/src/edwin/print.scm
index cf3416546761862c66c8ca05e8e77aa29cca9c9c..adc514de8dc4e6c2f14d8f25555c05e4f1b605fb 100644 (file)
--- a/v7/src/edwin/print.scm
+++ b/v7/src/edwin/print.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/print.scm,v 1.9 1992/08/28 21:03:19 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/print.scm,v 1.10 1992/09/01 20:12:17 cph Exp $
 ;;;
 ;;;    Copyright (c) 1991-92 Massachusetts Institute of Technology
 ;;;
@@ -76,63 +76,38 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr."
 
 (define (print-region/internal region print-command?)
   (let ((switches (print-region-switches region print-command?))
-       (source-buffer (mark-buffer (region-start region)))
-       (temp-buffer (temporary-buffer " *spool temp*")))
+       (source-buffer (mark-buffer (region-start region))))
     (message "Spooling...")
-    (insert-region (region-start region)
-                  (region-end region)
-                  (buffer-point temp-buffer))
-    (let ((width (ref-variable tab-width source-buffer)))
-      (if (not (= width 8))
-         (begin
-           (define-variable-local-value! temp-buffer
-             (ref-variable-object tab-width)
-             width)
-           (untabify-region (buffer-start temp-buffer)
-                            (buffer-end temp-buffer)))))
-    (shell-command region (buffer-end temp-buffer) false false
-                  (apply string-append
-                         (ref-variable lpr-command source-buffer)
-                         (let loop ((switches switches))
-                           (if (null? switches)
-                               (list "")
-                               (cons* " "
-                                      (car switches)
-                                      (loop (cdr switches)))))))
+    (call-with-temporary-buffer " *spool temp*"
+      (lambda (temp-buffer)
+       (insert-region (region-start region)
+                      (region-end region)
+                      (buffer-point temp-buffer))
+       (let ((width (ref-variable tab-width source-buffer)))
+         (if (not (= width 8))
+             (begin
+               (define-variable-local-value! temp-buffer
+                 (ref-variable-object tab-width)
+                 width)
+               (untabify-region (buffer-start temp-buffer)
+                                (buffer-end temp-buffer)))))
+       (shell-command region (buffer-end temp-buffer) false false
+                      (apply string-append
+                             (ref-variable lpr-command source-buffer)
+                             (let loop ((switches switches))
+                               (if (null? switches)
+                                   (list "")
+                                   (cons* " "
+                                          (car switches)
+                                          (loop (cdr switches)))))))))
     (append-message "done")))
 \f
 (define (print-region-switches region print-command?)
-  (let ((switches (ref-variable lpr-switches))
-       (title (print-region-title-string region)))
-    (append (if (and print-command? (not lpr-print-not-special?))
-               '("-p")
-               '())
-           (let ((job-name
-                  (or (and lpr-prompt-for-name?
-                           (not (there-exists? switches
-                                  (lambda (switch)
-                                    (string-prefix? "-J" switch))))
-                           (let ((job-name
-                                  (prompt-for-string
-                                   "Name to print on title page"
-                                   lpr-most-recent-name
-                                   'INSERTED-DEFAULT)))
-                             (if (string-null? job-name)
-                                 false
-                                 (begin
-                                   (set! lpr-most-recent-name job-name)
-                                   job-name))))
-                      title)))
-             (if job-name
-                 (list (string-append "-J \"" job-name "\""))
-                 '()))
-           (if (and title
-                    (not (there-exists? switches
-                           (lambda (switch)
-                             (string-prefix? "-T" switch)))))
-               (list (string-append "-T \"" title "\""))
-               '())
-           switches)))
+  (print/assemble-switches
+   (print-region-title-string region)
+   (if (and print-command? (not lpr-print-not-special?))
+       '("-p")
+       '())))
 
 (define (print-region-title-string region)
   (let ((buffer-title
@@ -148,4 +123,31 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr."
            (and (group-start? (region-start region))
                 (group-end? (region-end region))))
        buffer-title
-       (string-append "region from " buffer-title))))
\ No newline at end of file
+       (string-append "region from " buffer-title))))
+
+(define (print/assemble-switches title additional-switches)
+  (let ((switches (ref-variable lpr-switches)))
+    (append additional-switches
+           (let ((job-name (or (print/job-name) title)))
+             (if job-name
+                 (list (string-append "-J \"" job-name "\""))
+                 '()))
+           (if (and title
+                    (not (there-exists? switches
+                           (lambda (switch)
+                             (string-prefix? "-T" switch)))))
+               (list (string-append "-T \"" title "\""))
+               '())
+           switches)))
+
+(define (print/job-name)
+  (and lpr-prompt-for-name?
+       (let ((job-name
+             (prompt-for-string "Name to print on title page"
+                                lpr-most-recent-name
+                                'INSERTED-DEFAULT)))
+        (if (string-null? job-name)
+            false
+            (begin
+              (set! lpr-most-recent-name job-name)
+              job-name)))))
\ No newline at end of file