path: root/Init5d2.scm

;; Copyright (C) 1991-1999 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 GUILE.
;;
;; The exception is that, if you link the GUILE 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 GUILE 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 GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, 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 GUILE, 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) "5d2")
(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)			'(#\/))
	   ((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)

;;; 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.

;;; 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 library-vicinity #f)
(define home-vicinity #f)
(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 ()
			(try-load (in-vicinity (implementation-vicinity)
					       "require.scm")))
		      (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 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))))
(set-vicinities! *load-pathname*)

;;; Here for backward compatability
(define scheme-file-suffix
  (case (software-type)
    ((NOSVE) (lambda () "_scm"))
    (else (lambda () ".scm"))))

(set! *features*
      (append '(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 (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)
  (call-with-input-file file
    (lambda (inport)
      (do ((c (read-char inport) (read-char inport)))
	  ((eof-object? c))
	(write-char c)))))
(define (terms)
  (display-file "/usr/doc/copyright/GPL"))

;; Array syntax:
;; n is a decimal number, which may be elided for a default value of 1.
;; #nA\( ... ) character array
;; #nAt( ... ) boolean array
;; #nAe[sfdl]( ... ) exact number array
;; #nAu[sfdl]( ... ) positive exact number array
;; #nAi[sfdl]( ... ) inexact real number array
;; #nAic[sfdl]( ... ) inexact complex number array

(define (read:array rank port)
  (let ((prot
	 (case (char-downcase (peek-char port))
	   ((#\\) (read-char port) #\a)
	   ((#\t) (read-char port) #t)
	   ((#\e)
	    (read-char port)
	    (case (char-downcase (peek-char port))
	      ((#\s) (read-char port) 'exact-short)
	      ((#\f #\d #\l) (read-char port) -2)
	      (else -2)))
	   ((#\u)
	    (read-char port)
	    (case (char-downcase (peek-char port))
	      ((#\s #\f #\d #\l) (read-char port) 2)
	      (else 2)))
	   ((#\i)
	    (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)))
	       0+1.0i)
	      ((#\s #\f) (read-char port) 1.0)
	      ((#\d #\l) (read-char port) 1/3)
	      (else 1/3)))
	   (else #f))))
    (list->uniform-array rank prot (read port))))

(define (read:sharp c port)
  (define (barf c)
    (error "unknown # object" c))
  (define chr0 (char->integer #\0))
  (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 loop ((arg (- (char->integer c) chr0)))
       (let ((c (peek-char port)))
	 (cond ((char-numeric? c)
		(loop (+ (* 10 arg)
			 (- (char->integer (read-char port)) chr0))))
	       ((memv c '(#\a #\A))
		(read-char port)
		(read:array arg port))
	       (else
		(warn "obsolete array read syntax")
		(read:array arg port))))))
    ((#\!) (if (= 1 (line-number))
	       (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 c)))
    (else (barf c))))

;; We can assume TOK has at least 2 characters.
(define read:sharp-char
  (letrec ((control (lambda (c)
		      (and (char? c)
			   (if (eqv? c #\?)
			       (integer->char 127)
			       (integer->char
				(logand 31 (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)
	 (and (char=? #\- (string-ref tok 1))
	      (if (= 3 (string-length tok))
		  (control (string-ref tok 2))
		  (let ((c (read:sharp-char
			    (substring tok 2 (string-length tok)))))
		    (and c (control c))))))
	((#\^)
	 (and (= 2 (string-length tok))
	      (control (string-ref tok 1))))
	((#\M #\m)
	 (and (char=? #\- (string-ref tok 1))
	      (if (= 3 (string-length tok))
		  (meta (string-ref tok 2))
		  (let ((c (read:sharp-char
			    (substring tok 2 (string-length tok)))))
		    (and c (meta c))))))))))

;;;; 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.
(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
  (if (defined? cr) cr (lambda (x) x)))

(if (not (defined? the-macro))
    (define the-macro identity))
(define 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 ATARIST) "wb")
		     (else "w")))
(define OPEN_BOTH (case (software-type)
		    ((MS-DOS WINDOWS ATARIST) "r+b")
		    (else "r+")))
(define (_IONBF mode) (string-append mode "0"))
(define (_TRACKED mode) (string-append mode "?"))

(define could-not-open #f)

(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 (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-io-file str) (open-file str OPEN_BOTH))

(define close-input-port close-port)
(define close-output-port close-port)
(define close-io-port close-port)

(define (call-with-input-file str proc)
  (let* ((file (open-input-file str))
	 (ans (proc file)))
    (close-input-port file)
    ans))

(define (call-with-output-file str proc)
  (let* ((file (open-output-file str))
	 (ans (proc file)))
    (close-output-port file)
    ans))

(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 (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")
  (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 (pp . args)
  (for-each pretty-print args)
  (if #f #f))

(define (file-exists? str)
  (let ((port (open-file str OPEN_READ)))
    (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 +)

(if (not (memq 'ed *features*))
    (begin
      (define (ed . args)
	(system (apply string-append
		       (or (getenv "EDITOR") "editor")
		       (map (lambda (s) (string-append " " s)) args))))
      (set! *features* (cons 'ed *features*))))

(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)

;;; 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))))

(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 (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))
      ;;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))
      (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)
	       ;;HERE is where the suffix gets specified
	       (and (not (has-suffix? file sfs))
		    (begin (set! filesuf (string-append file sfs))
			   (try-load filesuf)))))
      (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)

(load (in-vicinity (library-vicinity) "require"))

;;; DO NOT MOVE!  This must be done after "require.scm" is loaded.
(define slib:load-source scm:load-source)
(define slib:load scm:load)

(cond ((or (defined? dyn:link)
	   (defined? vms:dynamic-link-call)
	   (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms")))
       (load (in-vicinity (implementation-vicinity) "Link"))))

(cond ((defined? link:link)
       (define (slib:load-compiled . args)
	 (or (apply link:link args)
	     (error "Couldn't link files " args)))
       (provide 'compiled)))

(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
  (if (equal? "a" (symbol->string 'a))
      (lambda (str) (string->symbol (string-downcase str)))
      (lambda (str) (string->symbol (string-upcase str)))))

(define logical:logand logand)
(define logical:logior logior)
(define logical:logxor logxor)
(define logical:lognot lognot)
(define logical:ash ash)
(define logical:logcount logcount)
(define logical:integer-length integer-length)
(define logical:integer-expt integer-expt)

(define logical:bit-field bit-field)
(define bit-extract bit-field)
(define logical:bitwise-if bitwise-if)
(define logical:copy-bit copy-bit)
(define logical:copy-bit-field copy-bit-field)

(define (logical:ipow-by-squaring x k acc proc)
  (cond ((zero? k) acc)
	((= 1 k) (proc acc x))
	(else (logical:ipow-by-squaring (proc x x)
					(quotient k 2)
					(if (even? k) acc (proc acc x))
					proc))))

;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 (cdr exp)))))))

(define defmacro
  (let ((defmacro-transformer
	  (lambda (name parms . body)
	    `(define ,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)))

(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 (tracef . args) (require 'trace) (apply tracef args))
(define (trace:tracef . args) (require 'trace) (apply trace:tracef args))
(define (trace-all . args) (require 'debug) (apply trace-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 redefmacroed when tracef autoloads.
(defmacro trace x
  (if (null? x) '()
      `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x))))
(defmacro break x
  (if (null? x) '()
      `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) 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 casev (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 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))
    (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) (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 uniform-vector? array?)
      (define make-uniform-vector dimensions->uniform-array)
;      (define uniform-vector-ref array-ref)
      (define (uniform-vector-set! u i o)
	(uniform-vector-set1! u o i))
;      (define uniform-vector-fill! array-fill!)
;      (define uniform-vector-read! uniform-array-read!)
;      (define uniform-vector-write uniform-array-write)

      (define (make-array fill . args)
	(dimensions->uniform-array args () fill))
      (define (make-uniform-array prot . args)
	(dimensions->uniform-array args prot))
      (define (list->array ndim lst)
	(list->uniform-array ndim '() lst))
      (define (list->uniform-vector prot lst)
	(list->uniform-array 1 prot lst))
      (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 (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? *R4RS-macro*))
    (define *R4RS-macro* #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)))
      (errno 0))

  (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 "muqvbis")
	   (arg-opts '("a kbytes" "no-init-file" "-no-init-file"
				  "-version" "-help" "p number"
				  "r feature" "f filename" "l filename"
				  "d 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 *R4RS-macro* macro:eval eval)
	    (call-with-input-string
	     (string-append "(begin " *optarg* ")")
	     read))))
	(set! didsomething #t))

      (define (do-load file)
	(do-thunk
	 (lambda ()
	   (cond (*R4RS-macro* (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 4)) (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 'database-utilities) (open-database str)
      ;; -f str => (load str)
      ;; -l str => (load str)
      ;; -r str => (require str)
      ;; -o str => (dump str)
      ;; -p int => (verbose int)
      ;; -m     => (set! *R4RS-macro* #t)
      ;; -u     => (set! *R4RS-macro* #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 'database-utilities)
		 (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 'rev3-procedures)
					  (require 'rev2-procedures))
				   ((#\3) (require 'rev3-procedures))
				   ((#\4) (require 'rev4-optional-procedures))
				   ((#\5) (require 'values)
					  (require 'macro)
					  (require 'eval)
					  (set! *R4RS-macro* #t))
				   (else (require (string->symbol *optarg*))))
				 (require (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! *R4RS-macro* #t))
	  ((#\u) (set! *R4RS-macro* #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 *R4RS-macro* (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)))))))