;;; $Id: typedscm.ss,v 1.21 2006/01/18 23:17:27 leavens Exp $
;;; Copyright (C) 2006 Iowa State University
;;;
;;; This file is part of Typedscm.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1,
;;; of the License, or (at your option) any later version.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with Typedscm; see the file LesserGPL.txt.  If not,
;;; write to the Free Software Foundation, Inc., 51 Franklin St, Fifth
;;; Floor, Boston, MA 02110-1301 USA.

;;; Typedscm language for use with EOPL(2e).

(module typedscm mzscheme
 
  (provide quit force-output exit)
  (provide (rename ts:collection-path collection-path))
  (provide random void promise? file-exists?)
  (provide (all-from (lib "testing.scm" "typedscm")))
  (provide (all-from
	    (lib "tc-ignore-types-at-runtime.scm" "typedscm" "drscheme")))
  (provide (rename typedscm-void? void?))
  (provide (all-from-except (lib "eopl.ss" "eopl")
                            eopl:define eopl:module-begin
			    eopl:call-with-current-continuation))
  (provide (rename eopl:pretty-print pretty-print))
  (provide (rename eopl:error error))
  (provide (rename eopl:define define))
  (provide (rename eopl:module-begin #%module-begin))
  (provide (rename eopl:call-with-current-continuation
                   call-with-current-continuation))
  (provide (rename ts:current-directory current-directory))
  (provide eopl:set-error-stop! eopl:get-error-stop eopl:call-error-stop)
  
  (define eopl:set-error-stop!
    (lambda (alpha)
      (namespace-set-variable-value! 'eopl:error-stop alpha #t)))

  (define eopl:get-error-stop
    (lambda ()
      (namespace-variable-value 'eopl:error-stop)))

  (define eopl:call-error-stop
    (lambda ()
      ((namespace-variable-value 'eopl:error-stop))))
  
  (provide require-for-syntax)  ;; we allow full use of modules

  ;; standardization of DrScheme for typedscm
 
  (require (lib "displayln-mod.scm" "typedscm"))
  
  ;; Some other things to make DrScheme more like SCM
  (print-vector-length #f)
  (define quit exit)
  (define force-output
    (lambda ()
      (flush-output)))

  ;; needed for portability with Chez Scheme
  (define ts:collection-path
    (letrec ((replace-backslashes
	      (lambda (str pos len)
		(cond
		 ((negative? pos) str)
		 ((not (char=? #\\ (string-ref str pos)))
		  (replace-backslashes str (- pos 1) len))
		 (else
		  (replace-backslashes
		   (string-append (substring str 0 pos)
				  "/"
				  (let ((next-pos (+ pos 1)))
				    (if (>= next-pos len)
					""
					(substring str next-pos len))))
		   (- pos 1)
		   len))))))
    (lambda args
      (let* ((pathstr
	      (mzc:path->string (apply mzc:collection-path args)))
	     (len (string-length pathstr)))
	(replace-backslashes pathstr (- len 1) len)))))

  (define ts:current-directory
    (lambda args
      (if (null? args)
	  (path->string (mzc:current-directory))
	  (mzc:current-directory (car args)))))

  (require (rename mzscheme mzc:path->string path->string))
  (require (rename mzscheme mzc:current-library-collection-paths
		   current-library-collection-paths))
  (require (rename mzscheme mzc:current-directory
		   current-directory))
  (require (rename mzscheme mzc:collection-path collection-path))
  (require (all-except (lib "eopl.ss" "eopl")
                       define #%module-begin call-with-current-continuation
                       list-of))
  (require (rename (lib "eopl.ss" "eopl") eopl:define define))
  (require (rename (lib "eopl.ss" "eopl") eopl:module-begin #%module-begin))
  (require (rename (lib "eopl.ss" "eopl")
                   eopl:call-with-current-continuation
                   call-with-current-continuation))

  (require (lib "testing.scm" "typedscm"))
  (require (lib "tc-ignore-types-at-runtime.scm" "typedscm" "drscheme"))

  )