Import Upstream version 5b3upstream/5b3

1 files changed, 122 insertions, 62 deletions

diff --git a/Init.scm b/Init.scm
index 758c407..35575e9 100644
--- a/Init.scm
+++ b/Init.scm
@@ -42,7 +42,7 @@
 ;;; Author: Aubrey Jaffer.
 
 (define (scheme-implementation-type) 'SCM)
-(define (scheme-implementation-version) "4e6")
+(define (scheme-implementation-version) "5b3")
 
 ;;; Temporary hack for compatability with older versions.
 (define software-type
@@ -89,6 +89,15 @@
     (if library-path (lambda () library-path)
 	implementation-vicinity)))
 
+(define home-vicinity
+  (let ((home (getenv "HOME")))
+    (and home
+	 (case (software-type)
+	   ((UNIX COHERENT MS-DOS)	;V7 unix has a / on HOME
+	    (if (not (char=? #\/ (string-ref home (+ -1 (string-length home)))))
+		(set! home (string-append home "/"))))))
+    (lambda () home)))
+
 ;;; Here for backward compatability
 (define scheme-file-suffix
   (case (software-type)
@@ -103,7 +112,6 @@
 		string-port source current-time)
 	      *features*))
 
-(define slib:exit quit)
 (define (exec-self)
   (require 'i/o-extensions)
   (execv (execpath) (program-arguments)))
@@ -179,13 +187,20 @@
 	((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
 	 (read:array c port))
 	((#\!) (if (= 1 (line-number))
-		   (let skip () (if (eq? #\newline (peek-char port))
-				    (if #f #f)
-				    (begin (read-char port) (skip))))
+		   (let skip ((metarg? #f))
+		     (case (read-char port)
+		       ((#\newline) (if metarg? (skip #t)))
+		       ((#\\) (skip #t))
+		       ((#\!) (if (not (and (eqv? #\# (peek-char port))
+					    (read-char port)))
+				  (skip metarg?)))
+		       (else (skip metarg?))))
 		   (barf)))
 	(else (barf))))
 
 (define type 'type)			;for /bin/sh hack.
+(define : ':)
+(define !#(if #f #f))			;for scsh hack.
 
 ;;;; Here are some Revised^2 Scheme functions:
 (define 1+
@@ -202,15 +217,29 @@
 (define >=? >=)
 (define t #t)
 (define nil #f)
-(define sequence begin)
-
-(set! apply
-      (let ((apply:nconc-to-last apply:nconc-to-last)
-	    (@apply @apply))
-	(lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
-(define call-with-current-continuation
-  (let ((@call-with-current-continuation @call-with-current-continuation))
-    (lambda (proc) (@call-with-current-continuation proc))))
+(cond ((defined? the-macro)
+       (define sequence (the-macro begin))
+       (set! apply
+	     (let ((apply:nconc-to-last apply:nconc-to-last)
+		   (@apply (the-macro @apply)))
+	       (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
+       (define call-with-current-continuation
+	 (let ((@call-with-current-continuation
+		(the-macro @call-with-current-continuation)))
+	   (lambda (proc) (@call-with-current-continuation proc)))))
+      (else
+       (define sequence begin)
+       (set! apply
+	     (let ((apply:nconc-to-last apply:nconc-to-last)
+		   (@apply @apply))
+	       (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
+       (define call-with-current-continuation
+	 (let ((@call-with-current-continuation
+		@call-with-current-continuation))
+	   (lambda (proc) (@call-with-current-continuation proc))))))
+(if (defined? copy-tree)
+    (define @copy-tree copy-tree)
+    (define copy-tree @copy-tree))
 
 ;;; VMS does something strange when output is sent to both
 ;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
@@ -292,6 +321,18 @@
 (if (not (defined? force-output))
     (define (force-output . a) #f))
 
+(define (warn . args)
+  (define cep (current-error-port))
+  (perror "WARN")
+  (errno 0)
+  (display "WARN: " cep)
+  (if (not (null? args))
+      (begin (display (car args) cep)
+	     (for-each (lambda (x) (display #\  cep) (write x cep))
+		       (cdr args))))
+  (newline cep)
+  (force-output cep))
+
 (define (error . args)
   (define cep (current-error-port))
   (perror "ERROR")
@@ -306,12 +347,28 @@
   (abort))
 
 (define set-errno errno)
+(define slib:exit quit)
 (define exit quit)
 
+(define (print . args)
+  (define result #f)
+  (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
+  (newline)
+  result)
+
 (define (file-exists? str)
   (let ((port (open-file str OPEN_READ)))
-    (if port (begin (close-port port) #t)
-	#f)))
+    (and port (close-port port) #t)))
+(define (file-readable? str)
+  (let ((port (open-file str OPEN_READ)))
+    (and port
+	 (char-ready? port)
+	 (do ((c (read-char port)
+		 (and (char-ready? port) (read-char port)))
+	      (i 0 (+ 1 i))
+	      (l '() (cons c l)))
+	     ((or (not c) (eof-object? c) (<= 2 i))
+	      (if (null? l) #f (list->string (reverse l))))))))
 
 (define difftime -)
 (define offset-time +)
@@ -341,6 +398,7 @@
 
 (define (identity x) x)
 (define slib:error error)
+(define slib:warn warn)
 (define slib:tab #\tab)
 (define slib:form-feed #\page)
 (define slib:eval eval)
@@ -373,21 +431,21 @@
   (define hss (has-suffix? file (scheme-file-suffix)))
   (load:pre file)
   (or (and (defined? link:link) (not hss)
-	   (or (apply link:link file libs)
+	   (or (let ((s2 (file-readable? file)))
+		 (and s2 (not (equal? "#!" s2)) (apply link:link file libs)))
 	       (and link:able-suffix
-		    (let ((fs (string-append file link:able-suffix)))
-		      (cond ((not (file-exists? fs)) #f)
-			    ((apply link:link fs libs) (set! filesuf fs) #t)
-			    (else #f))))))
+		    (let* ((fs (string-append file link:able-suffix))
+			   (fs2 (file-readable? fs)))
+		      (and fs2 (apply link:link fs libs) (set! filesuf fs) #t)
+		      ))))
       (and (null? libs) (try-load file))
       ;;HERE is where the suffix gets specified
-      (and (not hss)
-	   (begin (errno 0)		; clean up error from TRY-LOAD above
-                  (set! filesuf (string-append file (scheme-file-suffix)))
-		  (try-load filesuf)))
+      (and (not hss) (errno 0)		; clean up error from TRY-LOAD above
+	   (set! filesuf (string-append file (scheme-file-suffix)))
+	   (try-load filesuf))
       (and (procedure? could-not-open) (could-not-open) #f)
-      (let () (set! load:indent 0)
-	   (error "LOAD couldn't find file " file)))
+      (begin (set! load:indent 0)
+	     (error "LOAD couldn't find file " file)))
   (load:post filesuf))
 (define load scm:load)
 (define slib:load load)
@@ -453,7 +511,7 @@
   (lambda (f)
     (procedure->memoizing-macro
       (lambda (exp env)
-	(copy-tree (apply f (cdr exp)))))))
+	(@copy-tree (apply f (cdr exp)))))))
 
 (define defmacro
   (let ((defmacro-transformer
@@ -502,12 +560,6 @@
 	  (evl o))
 	(set! *load-pathname* old-load-pathname)))))
 
-(define (print . args)
-  (define result #f)
-  (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
-  (newline)
-  result)
-
 ;;; Autoloads for SLIB procedures.
 
 (define (tracef . args) (require 'trace) (apply tracef args))
@@ -529,10 +581,31 @@
 (defmacro defvar (var val)
   `(if (not (defined? ,var)) (define ,var ,val)))
 
+(define print-args
+  (procedure->syntax
+   (lambda (sexp env)
+     (let ((frame (and (not (null? env)) (car env))))
+       (cond ((not (null? (cdr sexp)))
+	      (display "In")
+	      (for-each (lambda (exp) (display #\ ) (display exp)) (cdr sexp))
+	      (display ": ")))
+       (do ((vars (car frame) (cdr vars))
+	    (vals (cdr frame) (cdr vals)))
+	   ((not (pair? vars))
+	    (cond ((not (null? vars))
+		   (write vars)
+		   (display " := ")
+		   (write vals)))
+	    (newline))
+	 (write (car vars))
+	 (display " = ")
+	 (write (car vals))
+	 (display "; "))))))
+
 (cond
  ((defined? stack-trace)
 
-  #+breakpoint-error;; remove this line to enable breakpointing on errors
+  #+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
   (define (error . args)
     (define cep (current-error-port))
     (perror "ERROR")
@@ -560,13 +633,11 @@
 
 ;;; ABS and MAGNITUDE can be the same.
 (cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
-       (if (defined? usr:lib)
-	   (if (usr:lib "m")
-	       (load (in-vicinity (implementation-vicinity) "Transcen")
-		     (usr:lib "m"))
-	       (load (in-vicinity (implementation-vicinity) "Transcen")))
-	   (load (in-vicinity (implementation-vicinity) "Transcen"
-			      (scheme-file-suffix))))
+       (or (and (defined? usr:lib)
+		(usr:lib "m")
+		(load (in-vicinity (implementation-vicinity) "Transcen")
+		      (usr:lib "m")))
+	   (load (in-vicinity (implementation-vicinity) "Transcen")))
        (set! abs magnitude)))
 
 (if (defined? array?)
@@ -606,23 +677,12 @@
 ;;; This loads the user's initialization file, or files named in
 ;;; program arguments.
 
-(or
- (eq? (software-type) 'THINKC)
- (member "-no-init-file" (program-arguments))
- (member "--no-init-file" (program-arguments))
- (try-load
-  (in-vicinity
-   (let ((home (getenv "HOME")))
-     (if home
-	 (case (software-type)
-	   ((UNIX COHERENT)
-	    (if (char=? #\/ (string-ref home (+ -1 (string-length home))))
-		home			;V7 unix has a / on HOME
-		(string-append home "/")))
-	   (else home))
-	 (user-vicinity)))
-   "ScmInit.scm"))
- (errno 0))
+(or (eq? (software-type) 'THINKC)
+    (member "-no-init-file" (program-arguments))
+    (member "--no-init-file" (program-arguments))
+    (try-load (in-vicinity (or (home-vicinity) (user-vicinity))
+			   (string-append "ScmInit") (scheme-file-suffix)))
+    (errno 0))
 
 (if (not (defined? *R4RS-macro*))
     (define *R4RS-macro* #f))
@@ -704,7 +764,7 @@
 	   (cond ((zero? (modulo i 4)) (newline cep) (display indent cep))))
 	 (cdr arg-opts))
 	(display " [-- | -s | -] [file] [args...]" cep) (newline cep)
-	(if success? (display success? cep) (exit #f)))
+	(if success? (display success? cep) (quit #f)))
 
       ;; -a int => ignore (handled by run_scm)
       ;; -c str => (eval str)
@@ -838,7 +898,7 @@ There is no warranty, to the extent permitted by law.
 	       (set! *interactive* #t)))))
 
     (cond ((not *interactive*) (quit))
-	  (*R4RS-macro*
+	  ((and *R4RS-macro* (not (provided? 'macro)))
 	   (require 'repl)
 	   (require 'macro)
 	   (let* ((oquit quit))
@@ -846,7 +906,7 @@ There is no warranty, to the extent permitted by law.
 	     (set! exit quit)
 	     (repl:top-level macro:eval)
 	     (oquit))))
-    ;;otherwise, fall into non-macro SCM repl.
+    ;;otherwise, fall into natural SCM repl.
     )
    (else
     (begin (errno 0)