Import Upstream version 2d2upstream/2d2

1 files changed, 74 insertions, 30 deletions

diff --git a/mitscheme.init b/mitscheme.init
index ab1e1b7..afec48e 100644
--- a/mitscheme.init
+++ b/mitscheme.init
@@ -15,8 +15,8 @@
 
 (define (scheme-implementation-type) 'MITScheme)
 
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (scheme-implementation-home-page) should return a (string) URI
+;;; (Uniform Resource Identifier) for this scheme implementation's home
 ;;; page; or false if there isn't one.
 
 (define (scheme-implementation-home-page)
@@ -27,7 +27,7 @@
 
 (define (scheme-implementation-version)
   (let* ((str (with-output-to-string identify-world))
-	 (beg (+ (substring? "Release " str) 8))
+	 (beg (+ (string-search-forward "Release " str) 8))
 	 (rst (substring str beg (string-length str)))
 	 (end (string-find-next-char-in-set
 	       rst
@@ -76,36 +76,71 @@
 					;(slib:load-source "filename")
 	compiled			;can load compiled files
 					;(slib:load-compiled "filename")
-	rev4-report
-	ieee-p1178
-	sicp
-	rev4-optional-procedures
-	rev3-procedures
-	rev2-procedures
-	multiarg/and-
-	multiarg-apply
-	rationalize
-	object-hash
-	delay
-	with-file
-	string-port
-	transcript
+
+		       ;; Scheme report features
+
+	rev5-report			;conforms to
+	eval				;R5RS two-argument eval
+	values				;R5RS multiple values
+	dynamic-wind			;R5RS dynamic-wind
+	macro				;R5RS high level macros
+	delay				;has DELAY and FORCE
+	multiarg-apply			;APPLY can take more than 2 args.
 	char-ready?
-	record
-	values
-	dynamic-wind
-	ieee-floating-point
-	full-continuation
+	rationalize
+	rev4-optional-procedures	;LIST-TAIL, STRING->LIST,
+					;LIST->STRING, STRING-COPY,
+					;STRING-FILL!, LIST->VECTOR,
+					;VECTOR->LIST, and VECTOR-FILL!
+
+	rev4-report			;conforms to
+
+	ieee-p1178			;conforms to
+
+;	rev3-report			;conforms to
+
+	rev2-procedures			;SUBSTRING-MOVE-LEFT!,
+					;SUBSTRING-MOVE-RIGHT!,
+					;SUBSTRING-FILL!,
+					;STRING-NULL?, APPEND!, 1+,
+					;-1+, <?, <=?, =?, >?, >=?
+	object-hash			;has OBJECT-HASH
+
+	multiarg/and-			;/ and - can take more than 2 args.
+	with-file			;has WITH-INPUT-FROM-FILE and
+					;WITH-OUTPUT-FROM-FILE
+	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
+	ieee-floating-point		;conforms to IEEE Standard 754-1985
+					;IEEE Standard for Binary
+					;Floating-Point Arithmetic.
+	full-continuation		;can return multiple times
+
+			;; Other common features
+
+;	srfi				;srfi-0, COND-EXPAND finds all srfi-*
+	sicp				;runs code from Structure and
+					;Interpretation of Computer
+					;Programs by Abelson and Sussman.
+	defmacro			;has Common Lisp DEFMACRO
+	record				;has user defined data structures
+	string-port			;has CALL-WITH-INPUT-STRING and
+					;CALL-WITH-OUTPUT-STRING
 ;	sort
-	queue
 	pretty-print
 	object->string
+;	format				;Common-lisp output formatting
 	trace				;has macros: TRACE and UNTRACE
-	defmacro
-	compiler
-	getenv
+	compiler			;has (COMPILER)
+;	ed				;(ED) is editor
+	system				;posix (system <string>)
+	getenv				;posix (getenv <string>)
+;	program-arguments		;returns list of strings (argv)
+	current-time			;returns time in seconds since 1/1/1970
+
+		  ;; Implementation Specific features
+
+	queue
 	Xwindows
-	current-time
 	))
 
 (define current-time current-file-time)
@@ -156,6 +191,13 @@
 (define object->string write-to-string)
 (define object->limited-string write-to-string)
 
+;;; "rationalize" adjunct procedures.
+(define (find-ratio x e)
+  (let ((rat (rationalize x e)))
+    (list (numerator rat) (denominator rat))))
+(define (find-ratio-between x y)
+  (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
+
 ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
 ;;; be returned by CHAR->INTEGER.  It is defined incorrectly (65536)
 ;;; by MITScheme version 8.0.
@@ -229,12 +271,14 @@
 
 (define slib:warn
   (lambda args
-    (let ((port (current-error-port)))
-      (display "Warn: " port)
-      (for-each (lambda (x) (display x port)) args))))
+    (let ((cep (current-error-port)))
+      (if (provided? 'trace) (print-call-stack cep))
+      (display "Warn: " cep)
+      (for-each (lambda (x) (display x cep)) args))))
 
 ;; define an error procedure for the library
 (define (slib:error . args)
+  (if (provided? 'trace) (print-call-stack (current-error-port)))
   (apply error-procedure (append args (list (the-environment)))))
 
 ;; define these as appropriate for your system.