Import Upstream version 5d6upstream/5d6

1 files changed, 1409 insertions, 0 deletions

diff --git a/Init5d6.scm b/Init5d6.scm
new file mode 100644
index 0000000..a847689
--- /dev/null
+++ b/Init5d6.scm
@@ -0,0 +1,1409 @@
+;; Copyright (C) 1991-2002 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of SCM.
+;;
+;; The exception is that, if you link the SCM library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the SCM library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name SCM.  If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; SCM, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way.  To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for SCM, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Init.scm", Scheme initialization code for SCM.
+;;; Author: Aubrey Jaffer.
+
+(define (scheme-implementation-type) 'SCM)
+(define (scheme-implementation-version) "5d6")
+(define (scheme-implementation-home-page)
+  "http://swissnet.ai.mit.edu/~jaffer/SCM.html")
+
+(define vicinity:suffix?
+  (let ((suffi
+	 (case (software-type)
+	   ((AMIGA)				'(#\: #\/))
+	   ((MACOS THINKC)			'(#\:))
+	   ((MS-DOS WINDOWS ATARIST OS/2)	'(#\\ #\/))
+	   ((NOSVE)				'(#\: #\.))
+	   ((UNIX COHERENT PLAN9)		'(#\/))
+	   ((VMS)				'(#\: #\])))))
+    (lambda (chr) (memv chr suffi))))
+
+(define (pathname->vicinity pathname)
+  ;;Go up one level if PATHNAME ends in a vicinity suffix.
+  (let loop ((i (- (string-length pathname) 2)))
+    (cond ((negative? i) "")
+	  ((vicinity:suffix? (string-ref pathname i))
+	   (substring pathname 0 (+ i 1)))
+	  (else (loop (- i 1))))))
+
+;;; This definition of PROGRAM-VICINITY is equivalent to the one defined
+;;;  SLIB/require.scm.  It is used here to bootstrap
+;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY.
+
+(define (program-vicinity)
+  (if *load-pathname*
+      (pathname->vicinity *load-pathname*)
+      (error "not loading but called" 'program-vicinity)))
+
+(define in-vicinity string-append)
+
+(set! *features*
+      (append '(ed getenv tmpnam abort transcript with-file
+		   ieee-p1178 rev4-report rev4-optional-procedures
+		   hash object-hash delay dynamic-wind fluid-let
+		   multiarg-apply multiarg/and- logical defmacro
+		   string-port source current-time sharp:semi)
+	      *features*))
+
+(define eval
+  (let ((@eval @eval)
+	(@copy-tree @copy-tree))
+    (lambda (x) (@eval (@copy-tree x)))))
+
+(define (exec-self)
+  (require 'i/o-extensions)
+  (execv (execpath) (if *script*
+			(cons (car (program-arguments))
+			      (cons "\\"
+				    (member *script* (program-arguments))))
+			(program-arguments))))
+
+(define (display-file file . port)
+  (call-with-input-file file
+    (lambda (inport)
+      (do ((c (read-char inport) (read-char inport)))
+	  ((eof-object? c))
+	(apply write-char c port)))))
+(define (terms)
+  (display-file (in-vicinity (implementation-vicinity) "COPYING")))
+
+(define (read:try-number port . ic)
+  (define chr0 (char->integer #\0))
+  (let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0))))
+    (let ((c (peek-char port)))
+      (cond ((eof-object? c) #f)
+	    ((char-numeric? c)
+	     (loop (+ (* 10 (or arg 0))
+		      (- (char->integer (read-char port)) chr0))))
+	    (else arg)))))
+
+(define (read:array rank port)
+  (define (bomb pc wid)
+    (error (string-append "array syntax? #"
+			  (number->string rank)
+			  "A" (string pc)
+			  (if wid (number->string wid) ""))))
+  (list->uniform-array
+   rank
+   (case (char-downcase (peek-char port))
+     ((#\\) (read-char port) #\a)
+     ((#\t) (read-char port) #t)
+     ((#\c #\r)
+      (let* ((pc (read-char port))
+	     (wid (read:try-number port)))
+	(case wid
+	  ((64 32) (case pc
+		     ((#\c) (* +i wid))
+		     (else (exact->inexact wid))))
+	  (else (bomb pc wid)))))
+     ((#\s #\u)
+      (let* ((pc (read-char port))
+	     (wid (read:try-number port)))
+	(case (or wid (peek-char port))
+	  ((32 16 8) (case pc
+		       ((#\s) (- wid))
+		       (else wid)))
+	  ((#\s #\f #\d #\l) (read-char port) 32)
+	  ((#\() 32)			;legacy
+	  (else (bomb pc wid)))))
+     ((#\e)				;legacy
+      (read-char port)
+      (case (char-downcase (peek-char port))
+	((#\s) (read-char port) -16)
+	((#\f #\d #\l) (read-char port) -32)
+	(else -32)))
+     ((#\i)				;legacy
+      (read-char port)
+      (case (char-downcase (peek-char port))
+	((#\c)
+	 (read-char port)
+	 (case (char-downcase (peek-char port))
+	   ((#\s #\f #\d #\l) (read-char port)))
+	 +64i)
+	((#\s #\f) (read-char port) 32.0)
+	((#\d #\l) (read-char port) 64.0)
+	(else (bomb (read-char port) #f))))
+     (else #f))
+   (read port)))
+
+(define (read:sharp c port)
+  (define (barf c) (error "unknown # object" c))
+  (define (feature? exp)
+    (cond ((symbol? exp)
+	   (or (memq exp *features*) (eq? exp (software-type))))
+	  ((and (pair? exp) (list? exp))
+	   (case (car exp)
+	     ((not) (not (feature? (cadr exp))))
+	     ((or) (if (null? (cdr exp)) #f
+		       (or (feature? (cadr exp))
+			   (feature? (cons 'or (cddr exp))))))
+	     ((and) (if (null? (cdr exp)) #t
+			(and (feature? (cadr exp))
+			     (feature? (cons 'and (cddr exp))))))
+	     (else (error "read:sharp+ invalid expression " exp))))))
+  (case c
+    ((#\') (read port))
+    ((#\.) (eval (read port)))
+    ((#\+) (if (feature? (read port))
+	       (read port)
+	       (begin (read port) (if #f #f))))
+    ((#\-) (if (not (feature? (read port)))
+	       (read port)
+	       (begin (read port) (if #f #f))))
+    ((#\a #\A) (read:array 1 port))
+    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+     (let* ((num (read:try-number port c))
+	    (c (peek-char port)))
+       (cond ((memv c '(#\a #\A)) (read-char port) (read:array num port))
+	     (else (error "syntax? #" num c)))))
+    ((#\!) (let skip ((metarg? #f))
+	     (let ((c (read-char port)))
+	       (case c
+		 ((#\newline) (if metarg? (skip #t)))
+		 ((#\\) (skip #t))
+		 ((#\!) (cond ((eqv? #\# (peek-char port))
+			       (read-char port)
+			       (if #f #f))
+			      (else (skip metarg?))))
+		 (else (if (char? c) (skip metarg?) c))))))
+    ((#\?) (case (read port)
+	     ((line) (port-line port))
+	     ((column) (port-column port))
+	     ((file) (port-filename port))
+	     (else #f)))
+    (else (barf c))))
+
+;;; We can assume TOK has at least 2 characters.
+(define read:sharp-char
+  (letrec ((process
+	    (lambda (modifier tok)
+	      (and (char=? #\- (string-ref tok 1))
+		   (if (= 3 (string-length tok))
+		       (modifier (string-ref tok 2))
+		       (let ((c (read:sharp-char
+				 (substring tok 2 (string-length tok)))))
+			 (and c (modifier c)))))))
+	   (control
+	    (lambda (c)
+	      (and (char? c)
+		   (if (eqv? c #\?)
+		       (integer->char 127)
+		       (integer->char (logand #o237 (char->integer c)))))))
+	   (meta
+	    (lambda (c)
+	      (and (char? c)
+		   (integer->char (logior 128 (char->integer c)))))))
+    (lambda (tok)
+      (case (string-ref tok 0)
+	((#\C #\c) (process control tok))
+	((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1))))
+	((#\M #\m) (process meta tok))))))
+
+;;;; Function used to accumulate comments before a definition.
+(define comment
+  (let ((*accumulated-comments* '()))
+    (lambda args
+      (cond ((null? args)
+	     (let ((ans
+		    (apply string-append
+			   (map (lambda (comment)
+				  (string-append (or comment "") "\n"))
+				(reverse *accumulated-comments*)))))
+	       (set! *accumulated-comments* '())
+	       (if (equal? "" ans)
+		   "no-comment"	;#f
+		   (substring ans 0 (+ -1 (string-length ans))))))
+	    (else (set! *accumulated-comments*
+			(append (reverse args) *accumulated-comments*)))))))
+
+;;; Make #; convert the rest of the line to a (comment ...) form.
+;;; "build.scm" uses this.
+;;; requires line-i/o
+(define read:sharp
+  (let ((rdsharp read:sharp))
+    (lambda (c port)
+      (if (eqv? c #\;)
+	  (let skip-semi ()
+	    (cond ((eqv? #\; (peek-char port))
+		   (read-char port)
+		   (skip-semi))
+		  (else `(comment ,(read-line port)))))
+	  (rdsharp c port)))))
+
+
+(define type 'type)			;for /bin/sh hack.
+(define : ':)
+(define !#(if #f #f))			;for scsh hack.
+
+;;;; Here are some Revised^2 Scheme functions:
+(define 1+ (let ((+ +)) (lambda (n) (+ n 1))))
+(define -1+ (let ((+ +)) (lambda (n) (+ n -1))))
+(define 1- -1+)
+(define <? <)
+(define <=? <=)
+(define =? =)
+(define >? >)
+(define >=? >=)
+(define t #t)
+(define nil #f)
+(define identity cr)
+
+(cond ((defined? defsyntax)
+(defsyntax define-syntax (the-macro defsyntax)))
+      (else
+(define defsyntax define)
+(define the-macro identity)))
+(defsyntax sequence (the-macro begin))
+(define copy-tree @copy-tree)
+
+;;; VMS does something strange when output is sent to both
+;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
+(case (software-type) ((VMS) (set-current-error-port (current-output-port))))
+
+;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
+;;; mode to open files in.  MS-DOS does carriage return - newline
+;;; translation if not opened in `b' mode.
+
+(define OPEN_READ (case (software-type)
+		    ((MS-DOS WINDOWS ATARIST) 'rb)
+		    (else 'r)))
+(define OPEN_WRITE (case (software-type)
+		     ((MS-DOS WINDOWS) 'wbc)
+		     ((ATARIST) 'wb)
+		     (else 'w)))
+(define OPEN_BOTH (case (software-type)
+		    ((MS-DOS WINDOWS) 'r+bc)
+		    ((ATARIST) 'r+b)
+		    (else 'r+)))
+(define ((make-moder str) mode)
+  (if (symbol? mode)
+      (string->symbol (string-append (symbol->string mode) str))
+      (string-append mode str)))
+(define _IONBF (make-moder "0"))
+(define _TRACKED (make-moder "?"))
+(define _EXCLUSIVE (make-moder "x"))
+
+(define could-not-open #f)
+
+(define (open-output-file str)
+  (or (open-file str OPEN_WRITE)
+      (and (procedure? could-not-open) (could-not-open) #f)
+      (error "OPEN-OUTPUT-FILE couldn't open file " str)))
+(define (open-input-file str)
+  (or (open-file str OPEN_READ)
+      (and (procedure? could-not-open) (could-not-open) #f)
+      (error "OPEN-INPUT-FILE couldn't open file " str)))
+
+(define (string-index str chr)
+  (define len (string-length str))
+  (do ((pos 0 (+ 1 pos)))
+      ((or (>= pos len) (char=? chr (string-ref str pos)))
+       (and (< pos len) pos))))
+
+(if (not (defined? try-create-file))
+(define (try-create-file str modes . perms)
+  (if (symbol? modes) (set! modes (symbol->string modes)))
+  (let ((idx (string-index modes #\x)))
+    (cond ((require:feature->path 'i/o-extensions)
+	   (require 'i/o-extensions)
+	   (apply try-create-file str modes perms))
+	  ((not idx)
+	   (warn "not exclusive modes?" modes str)
+	   (try-open-file str modes))
+	  (else (set! modes (string-append (substring modes 0 idx)
+					   (substring modes (+ 1 idx)
+						      (string-length modes))))
+		(cond ((not (string-index modes #\w))
+		       (warn 'try-create-file "not writing?" modes str)
+		       (try-open-file str modes))
+		      (else
+		       (cond ((and (not (null? perms))
+				   (not (eqv? #o666 (car perms))))
+			      (warn "perms?" (car perms) str)))
+		       (cond ((file-exists? str) #f)
+			     (else (try-open-file str modes))))))))))
+
+(define close-input-port close-port)
+(define close-output-port close-port)
+
+(define (call-with-open-ports . ports)
+  (define proc (car ports))
+  (cond ((procedure? proc) (set! ports (cdr ports)))
+	(else (set! ports (reverse ports))
+	      (set! proc (car ports))
+	      (set! ports (reverse (cdr ports)))))
+  (let ((ans (apply proc ports)))
+    (for-each close-port ports)
+    ans))
+
+(define (call-with-input-file str proc)
+  (call-with-open-ports (open-input-file str) proc))
+
+(define (call-with-output-file str proc)
+  (call-with-open-ports (open-output-file str) proc))
+
+(define (with-input-from-port port thunk)
+  (dynamic-wind (lambda () (set! port (set-current-input-port port)))
+		thunk
+		(lambda () (set! port (set-current-input-port port)))))
+
+(define (with-output-to-port port thunk)
+  (dynamic-wind (lambda () (set! port (set-current-output-port port)))
+		thunk
+		(lambda () (set! port (set-current-output-port port)))))
+
+(define (with-error-to-port port thunk)
+  (dynamic-wind (lambda () (set! port (set-current-error-port port)))
+		thunk
+		(lambda () (set! port (set-current-error-port port)))))
+
+(define (with-input-from-file file thunk)
+  (let* ((nport (open-input-file file))
+	 (ans (with-input-from-port nport thunk)))
+    (close-port nport)
+    ans))
+
+(define (with-output-to-file file thunk)
+  (let* ((nport (open-output-file file))
+	 (ans (with-output-to-port nport thunk)))
+    (close-port nport)
+    ans))
+
+(define (with-error-to-file file thunk)
+  (let* ((nport (open-output-file file))
+	 (ans (with-error-to-port nport thunk)))
+    (close-port nport)
+    ans))
+
+(define (call-with-outputs thunk proc)
+  (define stdout #f)
+  (define stderr #f)
+  (define status #f)
+  (set! stdout
+	(call-with-output-string
+	 (lambda (stdout)
+	   (set! stderr
+		 (call-with-output-string
+		  (lambda (stderr)
+		    (call-with-current-continuation
+		     (lambda (escape)
+		       (dynamic-wind
+			   (lambda ()
+			     (set! status #f)
+			     (set! stdout (set-current-output-port stdout))
+			     (set! stderr (set-current-error-port stderr)))
+			   (lambda () (set! status (list (thunk))))
+			   (lambda ()
+			     (set! stdout (set-current-output-port stdout))
+			     (set! stderr (set-current-error-port stderr))
+			     (if (not status) (escape #f))))))))))))
+  (apply proc stdout stderr (or status '())))
+
+(define (warn . args)
+  (define cep (current-error-port))
+  (if (defined? print-call-stack)
+      (print-call-stack cep))
+  (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))
+  (if (defined? print-call-stack)
+      (print-call-stack cep))
+  (perror "ERROR")
+  (errno 0)
+  (display "ERROR: " 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)
+  (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 (pprint . args)
+  (define result #f)
+  (for-each (lambda (x) (set! result x) (pretty-print x)) args)
+  result)
+(define (pp . args)
+  (for-each pretty-print args)
+  (if #f #f))
+
+(if (not (defined? file-exists?))
+(define (file-exists? str)
+  (let ((port (open-file str OPEN_READ)))
+    (errno 0)
+    (and port (close-port port) #t))))
+(define (file-readable? str)
+  (let ((port (open-file str OPEN_READ)))
+    (errno 0)
+    (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 +)
+
+(if (not (defined? ed))
+(define (ed . args)
+  (system (apply string-append
+		 (or (getenv "EDITOR") "ed")
+		 (map (lambda (s) (string-append " " s)) args)))))
+
+(if (not (defined? output-port-width))
+(define (output-port-width . arg) 80))
+
+(if (not (defined? output-port-height))
+(define (output-port-height . arg) 24))
+
+(if (not (defined? last-pair))
+(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)))
+
+(define slib:error error)
+(define slib:warn warn)
+(define slib:tab #\tab)
+(define slib:form-feed #\page)
+(define slib:eval eval)
+
+(define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep)))
+
+;;;; Load.
+(define load:indent 0)
+(define (load:pre file)
+  (define cep (current-error-port))
+  (cond ((> (verbose) 1)
+	 (display
+	  (string-append ";" (make-string load:indent #\ ) "loading " file)
+	  cep)
+	 (set! load:indent (modulo (+ 2 load:indent) 16))
+	 (newline cep)))
+  (force-output cep))
+
+(define (load:post filesuf)
+  (define cep (current-error-port))
+  (errno 0)
+  (cond ((> (verbose) 1)
+	 (set! load:indent (modulo (+ -2 load:indent) 16))
+	 (display (string-append ";" (make-string load:indent #\ )
+				 "done loading " filesuf)
+		  cep)
+	 (newline cep)
+	 (force-output cep))))
+
+;;; Here for backward compatibility
+(define scheme-file-suffix
+  (case (software-type)
+    ((NOSVE) (lambda () "_scm"))
+    (else (lambda () ".scm"))))
+
+(define (has-suffix? str suffix)
+  (let ((sufl (string-length suffix))
+	(sl (string-length str)))
+    (and (> sl sufl)
+	 (string=? (substring str (- sl sufl) sl) suffix))))
+
+(define *load-reader* #f)
+(define (scm:load file . libs)
+  (define filesuf file)
+  (define hss (has-suffix? file (scheme-file-suffix)))
+  (load:pre file)
+  (or (and (defined? link:link) (not hss)
+	   (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))
+			   (fs2 (file-readable? fs)))
+		      (and fs2 (apply link:link fs libs) (set! filesuf fs) #t)
+		      ))))
+      (and (null? libs) (try-load file *load-reader*))
+      ;;HERE is where the suffix gets specified
+      (and (not hss) (errno 0)		; clean up error from TRY-LOAD above
+	   (set! filesuf (string-append file (scheme-file-suffix)))
+	   (try-load filesuf *load-reader*))
+      (and (procedure? could-not-open) (could-not-open) #f)
+      (begin (set! load:indent 0)
+	     (error "LOAD couldn't find file " file)))
+  (load:post filesuf))
+(define load scm:load)
+(define slib:load load)
+
+(define (scm:load-source file)
+  (define sfs (scheme-file-suffix))
+  (define filesuf file)
+  (load:pre file)
+  (or (and (or (try-load file *load-reader*)
+	       ;;HERE is where the suffix gets specified
+	       (and (not (has-suffix? file sfs))
+		    (begin (set! filesuf (string-append file sfs))
+			   (try-load filesuf *load-reader*)))))
+      (and (procedure? could-not-open) (could-not-open) #f)
+      (error "LOAD couldn't find file " file))
+  (load:post filesuf))
+(define slib:load-source scm:load-source)
+
+;;; This is the vicinity where this file resides.
+(define implementation-vicinity #f)
+
+;;; (library-vicinity) should be defined to be the pathname of the
+;;; directory where files of Scheme library functions reside.
+(define library-vicinity #f)
+
+;;; (home-vicinity) should return the vicinity of the user's HOME
+;;; directory, the directory which typically contains files which
+;;; customize a computer environment for a user.
+(define home-vicinity #f)
+
+(define (login->home-directory login)
+  (cond ((defined? getpw)
+	 (let ((pwvect (getpw login)))
+	   (and pwvect (vector-ref pwvect 5))))
+	((not (file-exists? "/etc/passwd")) #f)
+	(else
+	 (call-with-input-file "/etc/passwd"
+	   (lambda (iprt)
+	     (require 'string-search)
+	     (require 'line-i/o)
+	     (let tryline ()
+	       (define line (read-line iprt))
+	       (define (get-field)
+		 (define idx (string-index line #\:))
+		 (and idx
+		      (let ((fld (substring line 0 idx)))
+			(set! line (substring line (+ 1 idx)
+					      (string-length line)))
+			fld)))
+	       (cond ((eof-object? line) #f)
+		     ((string-index line #\:)
+		      => (lambda (idx)
+			   (define name (substring line 0 idx))
+			   (cond ((equal? login name)
+				  (do ((ans (get-field) (get-field))
+				       (cnt 4 (+ -1 cnt)))
+				      ((or (negative? cnt) (not ans)) ans)))
+				 (else (tryline))))))))))))
+
+(if (not (defined? getlogin))
+(define (getlogin) (or (getenv "USER") (getenv "LOGNAME"))))
+
+;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use
+;;; (implementation-vicinity) as (library-vicinity).  "require.scm",
+;;; the first file loaded from (library-vicinity), can redirect it.
+(define (set-vicinities! init-file)
+  (set! implementation-vicinity
+	(let ((vic (pathname->vicinity init-file)))
+	  (lambda () vic)))
+  (set! library-vicinity
+	(let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
+	  (if library-path
+	      (lambda () library-path)
+	      (lambda ()
+		(let ((olv library-vicinity)
+		      (oload load))
+		  (dynamic-wind
+		      (lambda () (set! load identity))
+		      (lambda ()
+			(let ((filename (in-vicinity (implementation-vicinity)
+						     "require.scm")))
+			  (or (try-load filename)
+			      (try-load (in-vicinity (implementation-vicinity)
+						     "requires.scm"))
+			      (error "Can't load" filename))))
+		      (lambda () (set! load oload)))
+		  (if (eq? olv library-vicinity)
+		      (error "Can't find library-vicinity"))
+		  (library-vicinity))))))
+  (set! home-vicinity
+	(let ((home (getenv "HOME")))
+	  (and (not home) login->home-directory
+	       (let ((login (getlogin)))
+		 (and login (set! home (login->home-directory login)))))
+	  (and home
+	       (case (software-type)
+		 ((UNIX COHERENT PLAN9 MS-DOS) ;V7 unix has a / on HOME
+		  (if (not
+		       (eqv? #\/ (string-ref home (+ -1 (string-length home)))))
+		      (set! home (string-append home "/"))))))
+	  (lambda () home))))
+;;; SET-VICINITIES! is also called from BOOT-TAIL
+(set-vicinities! *load-pathname*)
+
+;;;; Initialize SLIB
+(load (in-vicinity (library-vicinity) "require"))
+
+;;; This turns off line-numbering off for SLIB loads.
+(define *slib-load-reader* (and (defined? read-numbered) read-numbered))
+
+;;; DO NOT MOVE!  SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after
+;;; "require.scm" is loaded.
+(define (slib:load-source file . libs)
+  (fluid-let ((*load-reader* *slib-load-reader*))
+    (apply scm:load file libs)))
+(define (slib:load file . libs)
+  (fluid-let ((*load-reader* *slib-load-reader*))
+    (apply scm:load file libs)))
+
+;;; Dynamic link-loading
+(cond ((or (defined? dyn:link)
+	   (defined? vms:dynamic-link-call))
+       (load (in-vicinity (implementation-vicinity) "Link"))))
+
+(cond ((defined? link:link)
+(define (slib:load-compiled . args)
+  (cond ((symbol? (car args))
+	 (require:require (car args))
+	 (apply slib:load-compiled (cdr args)))
+	((apply link:link args))
+	(else (error "Couldn't link files " args))))
+(provide 'compiled)))
+
+;;; Complete the function set for feature STRING-CASE.
+(cond
+ ((defined? string-upcase!)
+(define (string-upcase str) (string-upcase! (string-copy str)))
+(define (string-downcase str) (string-downcase! (string-copy str)))
+(define (string-capitalize str) (string-capitalize! (string-copy str)))
+(define string-ci->symbol
+  (let ((s2cis (if (equal? "x" (symbol->string 'x))
+		   string-downcase string-upcase)))
+    (lambda (str) (string->symbol (s2cis str)))))
+(define symbol-append
+  (let ((s2cis (if (equal? "x" (symbol->string 'x))
+		   string-downcase string-upcase)))
+    (lambda args
+      (string->symbol
+       (apply string-append
+	      (map
+	       (lambda (obj)
+		 (cond ((string? obj) (s2cis obj))
+		       ((number? obj) (s2cis (number->string obj)))
+		       ((symbol? obj) (symbol->string obj))
+		       ((not obj) "")
+		       (else (slib:error 'wrong-type-to 'symbol-append obj))))
+	       args))))))
+(define (StudlyCapsExpand nstr . delimitr)
+  (set! delimitr
+	(cond ((null? delimitr) "-")
+	      ((char? (car delimitr)) (string (car delimitr)))
+	      (else (car delimitr))))
+  (do ((idx (+ -1 (string-length nstr)) (+ -1 idx)))
+      ((> 1 idx) nstr)
+    (cond ((and (> idx 1)
+		(char-upper-case? (string-ref nstr (+ -1 idx)))
+		(char-lower-case? (string-ref nstr idx)))
+	   (set! nstr
+		 (string-append (substring nstr 0 (+ -1 idx))
+				delimitr
+				(substring nstr (+ -1 idx)
+					   (string-length nstr)))))
+	  ((and (char-lower-case? (string-ref nstr (+ -1 idx)))
+		(char-upper-case? (string-ref nstr idx)))
+	   (set! nstr
+		 (string-append (substring nstr 0 idx)
+				delimitr
+				(substring nstr idx
+					   (string-length nstr))))))))
+(provide 'string-case)))
+
+;;;; Bit order and lamination
+
+(define (bit-reverse k n)
+  (do ((m (if (negative? n) (lognot n) n) (ash m -1))
+       (k (+ -1 k) (+ -1 k))
+       (rvs 0 (logior (ash rvs 1) (logand 1 m))))
+      ((negative? k) (if (negative? n) (lognot rvs) rvs))))
+
+(define (integer->list k . len)
+  (if (null? len)
+      (do ((k k (ash k -1))
+	   (lst '() (cons (odd? k) lst)))
+	  ((<= k 0) lst))
+      (do ((idx (+ -1 (car len)) (+ -1 idx))
+	   (k k (ash k -1))
+	   (lst '() (cons (odd? k) lst)))
+	  ((negative? idx) lst))))
+
+(define (list->integer bools)
+  (do ((bs bools (cdr bs))
+       (acc 0 (+ acc acc (if (car bs) 1 0))))
+      ((null? bs) acc)))
+(define (booleans->integer . bools)
+  (list->integer bools))
+
+(define (bitwise:laminate . ks)
+  (define nks (length ks))
+  (define nbs (apply max (map integer-length ks)))
+  (do ((kdx (+ -1 nbs) (+ -1 kdx))
+       (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks))
+		 (ash ibs nks))))
+      ((negative? kdx) ibs)))
+
+(define (bitwise:delaminate count k)
+  (define nbs (* count (+ 1 (quotient (integer-length k) count))))
+  (do ((kdx (- nbs count) (- kdx count))
+       (lst (vector->list (make-vector count 0))
+	    (map (lambda (k bool) (+ (if bool 1 0) (ash k 1)))
+		 lst
+		 (integer->list (ash k (- kdx)) count))))
+      ((negative? kdx) lst)))
+
+;;;; Gray-code
+
+(define (integer->gray-code k)
+  (logxor k (ash k -1)))
+
+(define (gray-code->integer k)
+  (if (negative? k)
+      (error 'gray-code->integer 'negative? k)
+      (do ((ktmp k (ash ktmp -1))
+	   (ans 0 (logxor ans ktmp)))
+	  ((zero? ktmp) ans))))
+
+(define (grayter k1 k2)
+  (define kl1 (integer-length k1))
+  (define kl2 (integer-length k2))
+  (cond ((eqv? kl1 kl2) (> (gray-code->integer k1) (gray-code->integer k2)))
+	(else (> kl1 kl2))))
+
+(define (gray-code<? k1 k2)
+  (not (or (eqv? k1 k2) (grayter k1 k2))))
+(define (gray-code<=? k1 k2)
+  (or (eqv? k1 k2) (not (grayter k1 k2))))
+(define (gray-code>? k1 k2)
+  (and (not (eqv? k1 k2)) (grayter k1 k2)))
+(define (gray-code>=? k1 k2)
+  (or (eqv? k1 k2) (grayter k1 k2)))
+
+(define @case-aux
+  (let ((integer-jump-table 1)
+	(char-jump-table 2))
+    (lambda (keys actions else-action)
+      (let ((n (length keys)))
+	(define (every-key pred)
+	  (let test ((keys keys))
+	    (or (null? keys)
+		(and (pred (car keys)) (test (cdr keys))))))
+	(define (jump-table keys)
+	  (let ((minkey (apply min keys))
+		(maxkey (apply max keys)))
+	    (and (< (- maxkey minkey) (* 4 n))
+		 (let ((actv (make-vector
+			      (+ 2 (- maxkey minkey)) else-action)))
+		   (for-each
+		    (lambda (key action)
+		      (vector-set! actv (+ 1 (- key minkey)) action))
+		    keys actions)
+		   (list integer-jump-table minkey actv)))))
+	(cond ((< n 5) #f)
+	      ((every-key integer?)
+	       (jump-table keys))
+	      ((every-key char?)
+	       (let* ((int-keys (map char->integer keys)))
+		 (cond ((jump-table int-keys) =>
+			(lambda (x)
+			  (cons char-jump-table
+				(cons (integer->char (cadr x))
+				      (cddr x)))))
+		       (else #f)))))))))
+
+;;;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer):
+(define *defmacros* '())
+(define (defmacro? m) (and (assq m *defmacros*) #t))
+
+(define defmacro:transformer
+  (lambda (f)
+    (procedure->memoizing-macro
+     (lambda (exp env)
+       (@copy-tree (apply f (remove-line-numbers! (cdr exp))))))))
+
+(define defmacro:get-destructuring-bind-pairs
+  (lambda (s e)
+    (let loop ((s s) (e e) (r '()))
+      (cond ((pair? s)
+	     (loop (car s) `(car ,e)
+		   (loop (cdr s) `(cdr ,e) r)))
+	    ((null? s) r)
+	    ((symbol? s) (cons `(,s ,e) r))
+	    (else (error 'destructuring-bind "illegal syntax"))))))
+
+(defsyntax destructuring-bind
+  (let ((destructuring-bind-transformer
+	 (lambda (s x . ff)
+	   (let ((tmp (gentemp)))
+	     `(let ((,tmp ,x))
+		(let ,(defmacro:get-destructuring-bind-pairs s tmp)
+		  ,@ff))))))
+    (set! *defmacros*
+	  (acons 'destructuring-bind
+		 destructuring-bind-transformer *defmacros*))
+    (defmacro:transformer destructuring-bind-transformer)))
+
+(defsyntax defmacro:simple-defmacro
+  (let ((defmacro-transformer
+	  (lambda (name parms . body)
+	    `(defsyntax ,name
+	       (let ((transformer (lambda ,parms ,@body)))
+		 (set! *defmacros* (acons ',name transformer *defmacros*))
+		 (defmacro:transformer transformer))))))
+    (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*))
+    (defmacro:transformer defmacro-transformer)))
+
+(defmacro:simple-defmacro defmacro (name . body)
+  (define (expn name pattern body)
+    (let ((args (gentemp)))
+      `(defmacro:simple-defmacro ,name ,args
+	 (destructuring-bind ,pattern ,args ,@body))))
+  (if (pair? name)
+      (expn (car name) (cdr name) body)
+      (expn name (car body) (cdr body))))
+
+(define (macroexpand-1 e)
+  (if (pair? e) (let ((a (car e)))
+		  (cond ((symbol? a) (set! a (assq a *defmacros*))
+			 (if a (apply (cdr a) (cdr e)) e))
+			(else e)))
+      e))
+
+(define (macroexpand e)
+  (if (pair? e) (let ((a (car e)))
+		  (cond ((symbol? a)
+			 (set! a (assq a *defmacros*))
+			 (if a (macroexpand (apply (cdr a) (cdr e))) e))
+			(else e)))
+      e))
+
+(define gentemp
+  (let ((*gensym-counter* -1))
+    (lambda ()
+      (set! *gensym-counter* (+ *gensym-counter* 1))
+      (string->symbol
+       (string-append "scm:G" (number->string *gensym-counter*))))))
+
+(define defmacro:eval slib:eval)
+(define defmacro:load load)
+
+(define (slib:eval-load <filename> evl)
+  (if (not (file-exists? <filename>))
+      (set! <filename> (string-append <filename> (scheme-file-suffix))))
+  (call-with-input-file <filename>
+    (lambda (port)
+      (let ((old-load-pathname *load-pathname*))
+	(set! *load-pathname* <filename>)
+	(do ((o (read port) (read port)))
+	    ((eof-object? o))
+	  (evl o))
+	(set! *load-pathname* old-load-pathname)))))
+
+;;;; Autoloads for SLIB procedures.
+
+(define (trace-all . args) (require 'debug) (apply trace-all args))
+(define (track-all . args) (require 'debug) (apply track-all args))
+(define (stack-all . args) (require 'debug) (apply stack-all args))
+(define (break-all . args) (require 'debug) (apply break-all args))
+(define (pretty-print . args) (require 'pretty-print) (apply pretty-print args))
+
+;;; (require 'transcript) would get us SLIB transcript -- not what we want.
+(define (transcript-on arg)
+  (load (in-vicinity (implementation-vicinity)
+		     (string-append "Tscript" (scheme-file-suffix))))
+  (transcript-on arg))
+(define (transcript-off)
+  (error "No transcript active"))
+
+;;;; Macros.
+
+;;; Trace gets re-defmacroed when tracef autoloads.
+(defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x))))
+(defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x))))
+(defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x))))
+(defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@x))))
+
+(defmacro defvar (var val)
+  `(if (not (defined? ,var)) (define ,var ,val)))
+(defmacro defconst (name value)
+  (cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value)))
+	(else (cond ((not (slib:eval `(defined? ,name))))
+		    ((and (symbol? name) (equal? (slib:eval value)
+						 (slib:eval name))))
+		    (else (slib:error 'trying-to-defconst name
+				      'to-different-value value)))
+	      `(define ,name ,value))))
+(defmacro qase (key . clauses)
+  `(case ,key
+     ,@(map (lambda (clause)
+	      (if (list? (car clause))
+		  (cons (apply
+			 append
+			 (map (lambda (elt)
+				(case elt
+				  ((unquote) '(unquote))
+				  ((unquote-splicing) '(unquote-splicing))
+				  (else
+				   (eval (list 'quasiquote (list elt))))))
+			      (car clause)))
+			(cdr clause))
+		  clause))
+	    clauses)))
+(defmacro (casev . args) `(qase ,@args))
+
+(defmacro fluid-let (clauses . body)
+  (let ((ids (map car clauses))
+	(temp (gentemp))
+	(swap (gentemp)))
+    `(let* ((,temp (list ,@(map cadr clauses)))
+	    (,swap (lambda () (set! ,temp (set! ,ids ,temp)))))
+       (dynamic-wind
+	   ,swap
+	   (lambda () ,@body)
+	   ,swap))))
+
+(define print-args
+  (procedure->syntax
+   (lambda (sexp env)
+     (set! env (environment->tree 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 line to enable breakpointing on calls to ERROR
+(define (error . args)
+  (define cep (current-error-port))
+  (if (defined? print-call-stack)
+      (print-call-stack cep))
+  (perror "ERROR")
+  (errno 0)
+  (display "ERROR: " cep)
+  (if (not (null? args))
+      (begin (display (car args) cep)
+	     (for-each (lambda (x) (display #\  cep) (write x cep))
+		       (cdr args))))
+  (newline cep)
+  (cond ((stack-trace) (newline cep)))
+  (display " * Breakpoint established: (continue <val>) to return." cep)
+  (newline cep) (force-output cep)
+  (require 'debug) (apply breakpoint args))
+
+(define (user-interrupt . args)
+  (define cep (current-error-port))
+  (newline cep)
+  (if (defined? print-call-stack)
+      (print-call-stack cep))
+  (display "ERROR: user interrupt" cep)
+  (newline cep)
+  (cond ((stack-trace) (newline cep)))
+  (display " * Breakpoint established: (continue <val>) to return." cep)
+  (newline cep) (force-output cep)
+  (require 'debug) (apply breakpoint args))
+  ))
+
+;;; ABS and MAGNITUDE can be the same.
+(cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
+       (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?)
+(begin
+
+(define (array-null? array)
+  (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd)))
+		       (array-shape array)))))
+(define (create-array prot . args)
+  (if (array-null? prot)
+      (dimensions->uniform-array args (array-prototype prot))
+      (dimensions->uniform-array args (array-prototype prot)
+				 (apply array-ref prot
+					(map car (array-shape prot))))))
+(define (make-array initial-value . dimensions)
+  (apply create-array (vector initial-value) dimensions))
+(define (make-uniform-wrapper prot)
+  (if (string? prot) (set! prot (string->number prot)))
+  (if prot
+      (lambda opt (if (null? opt)
+		      (list->uniform-array 1 prot '())
+		      (list->uniform-array 0 prot (car opt))))
+      vector))
+(define Ac64 (make-uniform-wrapper "+64i"))
+(define Ac32 (make-uniform-wrapper "+32i"))
+(define Ar64 (make-uniform-wrapper "64."))
+(define Ar32 (make-uniform-wrapper "32."))
+(define As64 (make-uniform-wrapper -64))
+(define As32 (make-uniform-wrapper -32))
+(define As16 (make-uniform-wrapper -16))
+(define As8  (make-uniform-wrapper -8))
+(define Au64 (make-uniform-wrapper  64))
+(define Au32 (make-uniform-wrapper  32))
+(define Au16 (make-uniform-wrapper  16))
+(define Au8  (make-uniform-wrapper  8))
+(define At1  (make-uniform-wrapper  #t))
+
+(define (array-shape a)
+  (let ((dims (array-dimensions a)))
+    (if (pair? dims)
+	(map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+	     dims)
+	dims)))
+(define array=? equal?)
+))
+
+(define (alarm-interrupt) (alarm 0))
+(if (defined? setitimer)
+    (begin
+      (define profile-alarm #f)
+      (define (profile-alarm-interrupt) (profile-alarm 0))
+      (define virtual-alarm #f)
+      (define (virtual-alarm-interrupt) (virtual-alarm 0))
+      (define milli-alarm #f)
+      (let ((make-alarm
+	     (lambda (sym)
+	       (and (setitimer sym 0 0)	;DJGPP supports only REAL and PROFILE
+		    (lambda (value . interval)
+		      (cadr
+		       (setitimer sym value
+				  (if (pair? interval) (car interval) 0))))))))
+	(set! profile-alarm (make-alarm 'profile))
+	(set! virtual-alarm (make-alarm 'virtual))
+	(set! milli-alarm (make-alarm 'real)))))
+
+;;;; Initialize statically linked add-ons
+(cond ((defined? scm_init_extensions)
+       (scm_init_extensions)
+       (set! scm_init_extensions #f)))
+
+;;; Use *argv* instead of (program-arguments), to allow option
+;;; processing to be done on it.  "ScmInit.scm" must
+;;;	(set! *argv* (program-arguments))
+;;; if it wants to alter the arguments which BOOT-TAIL processes.
+(define *argv* #f)
+
+(if (not (defined? *syntax-rules*))
+    (define *syntax-rules* #f))
+(if (not (defined? *interactive*))
+    (define *interactive* #f))
+
+(define (boot-tail dumped?)
+  (cond ((not *argv*)
+	 (set! *argv* (program-arguments))
+	 (cond (dumped?
+		(set-vicinities! dumped?)
+		(verbose (if (and (isatty? (current-input-port))
+				  (isatty? (current-output-port)))
+			     (if (<= (length *argv*) 1) 2 1)
+			     0))))
+	 (cond ((provided? 'getopt)
+		(set! *optind* 1)
+		(set! *optarg* #f)))))
+
+;;; 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 (or (home-vicinity) (user-vicinity))
+			     (string-append "ScmInit") (scheme-file-suffix))
+		*load-reader*)
+      (errno 0))
+
+  ;; Include line numbers in loaded code.
+  (if (defined? read-numbered)
+      (set! *load-reader* read-numbered))
+
+  (cond
+   ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
+    (require 'getopt)
+;;; (else
+;;;  (define *optind* 1)
+;;;  (define getopt:opt #f)
+;;;  (define (getopt argc argv optstring) #f))
+
+    (let* ((simple-opts "muvqibs")
+	   (arg-opts '("a kbytes" "-version" "-help"
+		       "no-init-file" "-no-init-file" "p number"
+		       "h feature" "r feature" "d filename"
+		       "f filename" "l filename"
+		       "c string" "e string" "o filename"))
+	   (opts (apply string-append ":" simple-opts
+			(map (lambda (o)
+			       (string-append (string (string-ref o 0)) ":"))
+			     arg-opts)))
+	   (argc (length *argv*))
+	   (didsomething #f)
+	   (moreopts #t)
+	   (exe-name (symbol->string (scheme-implementation-type)))
+	   (up-name (apply string (map char-upcase (string->list exe-name)))))
+
+      (define (do-thunk thunk)
+	(if *interactive*
+	    (thunk)
+	    (let ((complete #f))
+	      (dynamic-wind
+		  (lambda () #f)
+		  (lambda ()
+		    (thunk)
+		    (set! complete #t))
+		  (lambda ()
+		    (if (not complete) (close-port (current-input-port))))))))
+
+      (define (do-string-arg)
+	(require 'string-port)
+	(do-thunk
+	 (lambda ()
+	   ((if *syntax-rules* macro:eval eval)
+	    (call-with-input-string
+		(string-append "(begin " *optarg* ")")
+	      read))))
+	(set! didsomething #t))
+
+      (define (do-load file)
+	(do-thunk
+	 (lambda ()
+	   (cond (*syntax-rules* (require 'macro) (macro:load file))
+		 (else (load file)))))
+	(set! didsomething #t))
+
+      (define (usage preopt opt postopt success?)
+	(define cep (if success? (current-output-port) (current-error-port)))
+	(define indent (make-string 6 #\ ))
+	(define i 3)
+	(cond ((char? opt) (set! opt (string opt)))
+	      ;;((symbol? opt) (set! opt (symbol->string opt)))
+	      )
+	(display (string-append preopt opt postopt) cep)
+	(newline cep)
+	(display (string-append "Usage: "
+				exe-name
+				" [-a kbytes] [-" simple-opts "]") cep)
+	(for-each
+	 (lambda (o)
+	   (display (string-append " [-" o "]") cep)
+	   (set! i (+ 1 i))
+	   (cond ((zero? (modulo i 5)) (newline cep) (display indent cep))))
+	 (cdr arg-opts))
+	(display " [-- | -s | -] [file] [args...]" cep) (newline cep)
+	(if success? (display success? cep) (quit #f)))
+
+      ;; -a int => ignore (handled by scm_init_from_argv)
+      ;; -c str => (eval str)
+      ;; -e str => (eval str)
+      ;; -d str => (require 'databases) (open-database str)
+      ;; -f str => (load str)
+      ;; -l str => (load str)
+      ;; -r sym => (require sym)
+      ;; -h sym => (provide sym)
+      ;; -o str => (dump str)
+      ;; -p int => (verbose int)
+      ;; -m     => (set! *syntax-rules* #t)
+      ;; -u     => (set! *syntax-rules* #f)
+      ;; -v     => (verbose 3)
+      ;; -q     => (verbose 0)
+      ;; -i     => (set! *interactive* #t)
+      ;; -b     => (set! *interactive* #f)
+      ;; -s     => set argv, don't execute first one
+      ;; -no-init-file => don't load init file
+      ;; --no-init-file => don't load init file
+      ;; --help => print and exit
+      ;; --version => print and exit
+      ;; --     => last option
+
+      (let loop ((option (getopt-- argc *argv* opts)))
+	(case option
+	  ((#\a)
+	   (cond ((> *optind* 3)
+		  (usage "scm: option `-" getopt:opt "' must be first" #f))
+		 ((or (not (exact? (string->number *optarg*)))
+		      (not (<= 1 (string->number *optarg*) 10000)))
+		  ;;	This size limit should match scm.c ^^
+		  (usage "scm: option `-" getopt:opt
+			 (string-append *optarg* "' unreasonable") #f))))
+	  ((#\e #\c) (do-string-arg))	;sh-like
+	  ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*)
+	  ((#\d) (require 'databases)
+	   (open-database *optarg*))
+	  ((#\o) (require 'dump)
+	   (if (< *optind* (length *argv*))
+	       (dump *optarg* #t)
+	       (dump *optarg*)))
+	  ((#\r) (do-thunk (lambda ()
+			     (if (and (= 1 (string-length *optarg*))
+				      (char-numeric? (string-ref *optarg* 0)))
+				 (case (string-ref *optarg* 0)
+				   ((#\2) (require 'r2rs))
+				   ((#\3) (require 'r3rs))
+				   ((#\4) (require 'r4rs))
+				   ((#\5) (require 'r5rs)
+				    (set! *syntax-rules* #t))
+				   (else (require (string->symbol *optarg*))))
+				 (require (string->symbol *optarg*))))))
+	  ((#\h) (do-thunk (lambda () (provide (string->symbol *optarg*)))))
+	  ((#\p) (verbose (string->number *optarg*)))
+	  ((#\q) (verbose 0))
+	  ((#\v) (verbose 3))
+	  ((#\i) (set! *interactive* #t) ;sh-like
+	   (verbose (max 2 (verbose))))
+	  ((#\b) (set! didsomething #t)
+	   (set! *interactive* #f))
+	  ((#\s) (set! moreopts #f)	;sh-like
+	   (set! didsomething #t)
+	   (set! *interactive* #t))
+	  ((#\m) (set! *syntax-rules* #t))
+	  ((#\u) (set! *syntax-rules* #f))
+	  ((#\n) (if (not (string=? "o-init-file" *optarg*))
+		     (usage "scm: unrecognized option `-n" *optarg* "'" #f)))
+	  ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f))
+	  ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f))
+	  ((#f) (set! moreopts #f)	;sh-like
+	   (cond ((and (< *optind* (length *argv*))
+		       (string=? "-" (list-ref *argv* *optind*)))
+		  (set! *optind* (+ 1 *optind*)))))
+	  (else
+	   (or (cond ((not (string? option)) #f)
+		     ((string-ci=? "no-init-file" option))
+		     ((string-ci=? "version" option)
+		      (display
+		       (string-append exe-name " "
+				      (scheme-implementation-version)
+				      "
+Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+"
+				      up-name
+				      " may be distributed under the terms of"
+				      " the GNU General Public Licence;
+certain other uses are permitted as well."
+				      " For details, see the file `COPYING',
+which is included in the "
+				      up-name " distribution.
+There is no warranty, to the extent permitted by law.
+"
+				      ))
+		      (cond ((execpath) =>
+			     (lambda (path)
+			       (display " This executable was loaded from ")
+			       (write path)
+			       (newline))))
+		      (quit #t))
+		     ((string-ci=? "help" option)
+		      (usage "This is "
+			     up-name
+			     ", a Scheme interpreter."
+			     (let ((sihp (scheme-implementation-home-page)))
+			       (if sihp
+				   (string-append "Latest info: " sihp "
+")
+				   "")))
+		      (quit #t))
+		     (else #f))
+	       (usage "scm: unknown option `--" option "'" #f))))
+
+	(cond ((and moreopts (< *optind* (length *argv*)))
+	       (loop (getopt-- argc *argv* opts)))
+	      ((< *optind* (length *argv*)) ;No more opts
+	       (set! *argv* (list-tail *argv* *optind*))
+	       (set! *optind* 1)
+	       (cond ((and (not didsomething) *script*)
+		      (do-load *script*)
+		      (set! *optind* (+ 1 *optind*))))
+	       (cond ((and (> (verbose) 2)
+			   (not (= (+ -1 *optind*) (length *argv*))))
+		      (display "scm: extra command arguments unused:"
+			       (current-error-port))
+		      (for-each (lambda (x) (display (string-append " " x)
+						     (current-error-port)))
+				(list-tail *argv* (+ -1 *optind*)))
+		      (newline (current-error-port)))))
+	      ((and (not didsomething) (= *optind* (length *argv*)))
+	       (set! *interactive* #t)))))
+
+    (cond ((not *interactive*) (quit))
+	  ((and *syntax-rules* (not (provided? 'macro)))
+	   (require 'repl)
+	   (require 'macro)
+	   (let* ((oquit quit))
+	     (set! quit (lambda () (repl:quit)))
+	     (set! exit quit)
+	     (repl:top-level macro:eval)
+	     (oquit))))
+    ;;otherwise, fall into natural SCM repl.
+    )
+   (else
+    (begin (errno 0)
+	   (set! *interactive* #t)
+	   (for-each load (cdr (program-arguments)))))))