From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 23 Apr 1988 08:25:27 +0000 (+0000)
Subject: Bind `sf/default-externs-pathname' to same directory as input file
X-Git-Tag: 20090517-FFI~12813
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d5d1d0725ea450988a1f1cea882bedeb0627cf4;p=mit-scheme.git

Bind `sf/default-externs-pathname' to same directory as input file
when syntaxing a file.  This is correct default for relative filenames
that appear in a file's declarations.
---

diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm
index e1eadd89e..ca9d3b75c 100644
--- a/v7/src/sf/make.scm
+++ b/v7/src/sf/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.2 1988/03/30 21:56:15 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.3 1988/04/23 08:25:27 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -61,11 +61,11 @@ MIT in each case. |#
     (make-environment
       (define :name "SF")
       (define :version 4)
-      (define :modification 2)
+      (define :modification 3)
       (define :files)
 
       (define :rcs-header		;RCS sets up this string.
-	"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.2 1988/03/30 21:56:15 cph Rel $")
+	"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.3 1988/04/23 08:25:27 cph Exp $")
 
       (define :files-lists
 	(list
diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm
index a4a30757f..4d15a558f 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 3.9 1988/03/30 23:05:03 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.10 1988/04/23 08:24:45 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -153,55 +153,61 @@ Currently only the 68000 implementation needs this."
    (stickify-input-filenames input-string sf/default-input-pathname)))
 
 (define (syntax-file* input-pathname bin-pathname spec-pathname)
-  (let ((start-date (date))
-	(start-time (time))
-	(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)
-    (transmit-values
-	(transmit-values (file-info/find input-pathname)
-	  (lambda (syntax-table declarations)
-	    (integrate/file input-pathname syntax-table declarations
-			    spec-pathname)))
-      (lambda (expression externs events)
-	(fasdump (wrapping-hook
-		  (make-comment `((SOURCE-FILE . ,input-filename)
-				  (DATE . ,start-date)
-				  (TIME . ,start-time)
-				  (FLUID-LET . ,*fluid-let-type*))
-				(set! expression false)))
-		 bin-pathname)
-	(write-externs-file (pathname-new-type
-			     bin-pathname
-			     (pathname-type sf/default-externs-pathname))
-			    (set! externs false))
-	(if spec-pathname
-	    (begin (newline)
-		   (write-string "Writing ")
-		   (write spec-filename)
-		   (with-output-to-file spec-pathname
-		     (lambda ()
-		       (newline)
-		       (write `(DATE ,start-date ,start-time))
-		       (newline)
-		       (write `(FLUID-LET ,*fluid-let-type*))
-		       (newline)
-		       (write `(SOURCE-FILE ,input-filename))
-		       (newline)
-		       (write `(BINARY-FILE ,bin-filename))
-		       (for-each (lambda (event)
-				   (newline)
-				   (write `(,(car event)
-					    (RUNTIME ,(cdr event)))))
-				 events)))
-		   (write-string " -- done")))))))
+  (fluid-let ((sf/default-externs-pathname
+	       (make-pathname (pathname-device input-pathname)
+			      (pathname-directory input-pathname)
+			      false
+			      "ext"
+			      'NEWEST)))
+    (let ((start-date (date))
+	  (start-time (time))
+	  (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)
+      (transmit-values
+	  (transmit-values (file-info/find input-pathname)
+	    (lambda (syntax-table declarations)
+	      (integrate/file input-pathname syntax-table declarations
+			      spec-pathname)))
+	(lambda (expression externs events)
+	  (fasdump (wrapping-hook
+		    (make-comment `((SOURCE-FILE . ,input-filename)
+				    (DATE . ,start-date)
+				    (TIME . ,start-time)
+				    (FLUID-LET . ,*fluid-let-type*))
+				  (set! expression false)))
+		   bin-pathname)
+	  (write-externs-file (pathname-new-type
+			       bin-pathname
+			       (pathname-type sf/default-externs-pathname))
+			      (set! externs false))
+	  (if spec-pathname
+	      (begin (newline)
+		     (write-string "Writing ")
+		     (write spec-filename)
+		     (with-output-to-file spec-pathname
+		       (lambda ()
+			 (newline)
+			 (write `(DATE ,start-date ,start-time))
+			 (newline)
+			 (write `(FLUID-LET ,*fluid-let-type*))
+			 (newline)
+			 (write `(SOURCE-FILE ,input-filename))
+			 (newline)
+			 (write `(BINARY-FILE ,bin-filename))
+			 (for-each (lambda (event)
+				     (newline)
+				     (write `(,(car event)
+					      (RUNTIME ,(cdr event)))))
+				   events)))
+		     (write-string " -- done"))))))))
 
 (define (read-externs-file pathname)
   (let ((pathname
diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm
index 22b2d205e..519a6cd55 100644
--- a/v8/src/sf/make.scm
+++ b/v8/src/sf/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.2 1988/03/30 21:56:15 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.3 1988/04/23 08:25:27 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -61,11 +61,11 @@ MIT in each case. |#
     (make-environment
       (define :name "SF")
       (define :version 4)
-      (define :modification 2)
+      (define :modification 3)
       (define :files)
 
       (define :rcs-header		;RCS sets up this string.
-	"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.2 1988/03/30 21:56:15 cph Rel $")
+	"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.3 1988/04/23 08:25:27 cph Exp $")
 
       (define :files-lists
 	(list
diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm
index 16d5c04bc..fd38490eb 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 3.9 1988/03/30 23:05:03 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.10 1988/04/23 08:24:45 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -153,55 +153,61 @@ Currently only the 68000 implementation needs this."
    (stickify-input-filenames input-string sf/default-input-pathname)))
 
 (define (syntax-file* input-pathname bin-pathname spec-pathname)
-  (let ((start-date (date))
-	(start-time (time))
-	(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)
-    (transmit-values
-	(transmit-values (file-info/find input-pathname)
-	  (lambda (syntax-table declarations)
-	    (integrate/file input-pathname syntax-table declarations
-			    spec-pathname)))
-      (lambda (expression externs events)
-	(fasdump (wrapping-hook
-		  (make-comment `((SOURCE-FILE . ,input-filename)
-				  (DATE . ,start-date)
-				  (TIME . ,start-time)
-				  (FLUID-LET . ,*fluid-let-type*))
-				(set! expression false)))
-		 bin-pathname)
-	(write-externs-file (pathname-new-type
-			     bin-pathname
-			     (pathname-type sf/default-externs-pathname))
-			    (set! externs false))
-	(if spec-pathname
-	    (begin (newline)
-		   (write-string "Writing ")
-		   (write spec-filename)
-		   (with-output-to-file spec-pathname
-		     (lambda ()
-		       (newline)
-		       (write `(DATE ,start-date ,start-time))
-		       (newline)
-		       (write `(FLUID-LET ,*fluid-let-type*))
-		       (newline)
-		       (write `(SOURCE-FILE ,input-filename))
-		       (newline)
-		       (write `(BINARY-FILE ,bin-filename))
-		       (for-each (lambda (event)
-				   (newline)
-				   (write `(,(car event)
-					    (RUNTIME ,(cdr event)))))
-				 events)))
-		   (write-string " -- done")))))))
+  (fluid-let ((sf/default-externs-pathname
+	       (make-pathname (pathname-device input-pathname)
+			      (pathname-directory input-pathname)
+			      false
+			      "ext"
+			      'NEWEST)))
+    (let ((start-date (date))
+	  (start-time (time))
+	  (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)
+      (transmit-values
+	  (transmit-values (file-info/find input-pathname)
+	    (lambda (syntax-table declarations)
+	      (integrate/file input-pathname syntax-table declarations
+			      spec-pathname)))
+	(lambda (expression externs events)
+	  (fasdump (wrapping-hook
+		    (make-comment `((SOURCE-FILE . ,input-filename)
+				    (DATE . ,start-date)
+				    (TIME . ,start-time)
+				    (FLUID-LET . ,*fluid-let-type*))
+				  (set! expression false)))
+		   bin-pathname)
+	  (write-externs-file (pathname-new-type
+			       bin-pathname
+			       (pathname-type sf/default-externs-pathname))
+			      (set! externs false))
+	  (if spec-pathname
+	      (begin (newline)
+		     (write-string "Writing ")
+		     (write spec-filename)
+		     (with-output-to-file spec-pathname
+		       (lambda ()
+			 (newline)
+			 (write `(DATE ,start-date ,start-time))
+			 (newline)
+			 (write `(FLUID-LET ,*fluid-let-type*))
+			 (newline)
+			 (write `(SOURCE-FILE ,input-filename))
+			 (newline)
+			 (write `(BINARY-FILE ,bin-filename))
+			 (for-each (lambda (event)
+				     (newline)
+				     (write `(,(car event)
+					      (RUNTIME ,(cdr event)))))
+				   events)))
+		     (write-string " -- done"))))))))
 
 (define (read-externs-file pathname)
   (let ((pathname