; Module header is generated automatically
#cs(module myenv mzscheme
(require (lib "defmacro.ss"))

;; $Id: myenv.ss,v 1.14 2002/03/28 22:23:06 nwv Exp $
;; $Source: /home/nwv/cvsroot/projects/ssax-plt/myenv.ss,v $
;; [ssax-plt] This is a modified version of "official/lib/myenv.scm".
 ;(module myenv mzscheme
 ;  (require (lib "defmacro.ss"))
 ;  (require (rename (lib "pretty.ss") pp pretty-print))

; 		   My Standard Scheme "Prelude"
;
; This version of the prelude contains several forms and procedures
; that are specific to a Gambit-C 3.0 system.
; See myenv-scm.scm, myenv-bigloo.scm, etc. for versions
; of this prelude that are tuned to other Scheme systems.
;
; Id: myenv.scm,v 1.2 2001/09/21 19:53:30 oleg Exp


; assert the truth of an expression (or of a sequence of expressions)
;
; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...]
;
; If (and ?expr ?expr ...) evaluates to anything but #f, the result
; is the value of that expression.
; If (and ?expr ?expr ...) evaluates to #f, an error is reported.
; The error message will show the failed expressions, as well
; as the values of selected variables (or expressions, in general).
; The user may explicitly specify the expressions whose
; values are to be printed upon assertion failure -- as ?r-exp that
; follow the identifier 'report:'
; Typically, ?r-exp is either a variable or a string constant.
; If the user specified no ?r-exp, the values of variables that are
; referenced in ?expr will be printed upon the assertion failure.

(define-macro (assert expr . others)
			; given the list of expressions or vars,
			; make the list appropriate for cerr
  (define (make-print-list prefix lst)
    (cond
     ((null? lst) '())
     ((symbol? (car lst))
      (cons #\newline
	(cons (list 'quote (car lst))
	  (cons ": " (cons (car lst) (make-print-list #\newline (cdr lst)))))))
     (else 
      (cons prefix (cons (car lst) (make-print-list "" (cdr lst)))))))

			; return the list of all unique "interesting"
			; variables in the expr. Variables that are certain
			; to be bound to procedures are not interesting.
  (define (vars-of expr)
    (let loop ((expr expr) (vars '()))
      (cond
       ((not (pair? expr)) vars)	; not an application -- ignore
       ((memq (car expr) 
	      '(quote let let* letrec let-values* lambda cond quasiquote
		      case define do assert))
	vars)				; won't go there
       (else				; ignore the head of the application
	(let inner ((expr (cdr expr)) (vars vars))
	  (cond 
	   ((null? expr) vars)
	   ((symbol? (car expr))
	    (inner (cdr expr)
		   (if (memq (car expr) vars) vars (cons (car expr) vars))))
	   (else
	    (inner (cdr expr) (loop (car expr) vars)))))))))

  (cond
   ((null? others)		; the most common case
    `(or ,expr (begin (cerr "failed assertion: " ',expr nl "bindings"
			    ,@(make-print-list #\newline (vars-of expr)) nl)
		      (error "assertion failure"))))
   ((eq? (car others) 'report:) ; another common case
    `(or ,expr (begin (cerr "failed assertion: " ',expr
			    ,@(make-print-list #\newline (cdr others)) nl)
		      (error "assertion failure"))))
   ((not (memq 'report: others))
    `(or (and ,expr ,@others)
	 (begin (cerr "failed assertion: " '(,expr ,@others) nl "bindings"
		      ,@(make-print-list #\newline
			 (vars-of (cons 'and (cons expr others)))) nl)
		      (error "assertion failure"))))
   (else			; report: occurs somewhere in 'others'
    (let loop ((exprs (list expr)) (reported others))
      (cond
       ((eq? (car reported) 'report:)
	`(or (and ,@(reverse exprs))
	     (begin (cerr "failed assertion: " ',(reverse exprs)
			  ,@(make-print-list #\newline (cdr reported)) nl)
		    (error "assertion failure"))))
       (else (loop (cons (car reported) exprs) (cdr reported)))))))
)
    
(define-macro (assure exp error-msg) `(assert ,exp report: ,error-msg))

;; [ssax-plt] Different definition of `identify-error'.

;(define (identify-error msg args . disposition-msgs)
;  (##identify-error "ERROR" #f #f msg args disposition-msgs))

(define identify-error
  (let ((display-list (lambda (lst)
                        (for-each (lambda (arg)
                                    (display " ")
                                    (display arg))
                                  lst))))
    (lambda (msg args . disposition-msgs)
      (parameterize ((current-output-port (current-error-port)))
        (newline)
        (display "ERROR: ")
        (display msg)
        (display-list args)
        (unless (null? disposition-msgs)
          (newline)
          (display "ERROR DISPOSITION:")
          (display-list disposition-msgs))
        (newline)))))

; like cout << arguments << args
; where argument can be any Scheme object. If it's a procedure
; (without args) it's executed rather than printed (like newline)

(define (cout . args)
  (for-each (lambda (x)
              (if (procedure? x) (x) (display x)))
            args))

;; [ssax-plt] In `cerr', `##stderr' replaced with `(current-error-port)'.

(define (cerr . args)
  (for-each (lambda (x)
              (if (procedure? x)
                  (x (current-error-port))
                  (display x (current-error-port))))
            args))

;(##define-macro (nl) '(newline))
(define nl (string #\newline))

;; [ssax-plt] `##fixnum.' prefix removed.

; Some useful increment/decrement operators
; Note, ##fixnum prefix is Gambit-specific, it means that the
; operands assumed FIXNUM (as they ought to be anyway).
; This perfix could be safely removed: it'll leave the code just as
; correct, but more portable (and less efficient)

				; Mutable increment
(define-macro (++! x) `(set! ,x (+ 1 ,x)))

				; Read-only increment
(define-macro (++ x) `(+ 1 ,x))

				; Mutable decrement
(define-macro (--! x) `(set! ,x (- ,x 1)))

				; Read-only decrement
(define-macro (-- x) `(- ,x 1))


; Some useful control operators

;; [ssax-plt] PLT defines `when'.

			; if condition is true, execute stmts in turn
			; and return the result of the last statement
			; otherwise, return #f
;(define-macro (when condition . stmts)
;  `(and ,condition (begin ,@stmts)))

  
			; if condition is false execute stmts in turn
			; and return the result of the last statement
			; otherwise, return #t
			; This primitive is often called 'unless'
(define-macro (whennot condition . stmts)
  `(or ,condition (begin ,@stmts)))


;; [ssax-plt] PLT defines `begin0'.

			; Execute a sequence of forms and return the
			; result of the _first_ one. Like PROG1 in Lisp.
			; Typically used to evaluate one or more forms with
			; side effects and return a value that must be
			; computed before some or all of the side effects
			; happen.
;(define-macro (begin0 form . forms)
;  (let ((var (gensym)))
;    `(let ((,var ,form)) ,@forms ,var)))

  
			; Prepend an ITEM to a LIST, like a Lisp macro PUSH
			; an ITEM can be an expression, but ls must be a VAR
(define-macro (push! item ls)
  `(set! ,ls (cons ,item ,ls)))

			; Is str the empty string?
			; string-null? str -> bool
			; See Olin Shiver's Underground String functions
(define-macro (string-null? str) `(zero? (string-length ,str)))



; Support for multiple-values and let-values* form
; Multiple values are not present natively in Gambit.
; What follows is an _approximation_: it is not very good in case
; of continuations captured while evaluating an argument expression of
; values. Note that the only meaningful way to use 'values' procedure is
; in conjunction with call-with-values or let-values*

;; [ssax-plt] PLT defines `values' and `call-with-values'.

; (define values list)

; (define (call-with-values producer consumer)
;   (apply consumer (producer)))

;; [ssax-plt] We use the `let-values*' from Kirill Lisovsky's port of SSAX 4.9
;;            instead of the current SSAX one.

; Like let* but allowing for multiple-value bindings
;(define-macro (let-values* bindings . body)
;  (if (null? bindings) (cons 'begin body)
;      (apply (lambda (vars initializer)
;	 (let ((cont
;		(cons 'let-values*
;		      (cons (cdr bindings) body))))
;	   (cond
;	    ((not (pair? vars))		; regular let case, a single var
;	     `(let ((,vars ,initializer)) ,cont))
;	    ((null? (cdr vars))		; single var, see the prev case
;	     `(let ((,(car vars) ,initializer)) ,cont))
;	    ((null? (cddr vars))	; two variables
;	     (let ((val (gensym)))
;	       `(let* ((,val ,initializer)
;		       (,(car vars) (car ,val))
;		       (,(cadr vars) (cadr ,val))) ,cont)))
;	   (else			; the most generic case
;	    `(apply (lambda ,vars ,cont) ,initializer)))))
;       (car bindings))))

(define-macro let-values* (lambda (bindings . body)
  (if (null? bindings) (cons 'begin body)
      (apply (lambda (vars initializer)
	 (let ((cont 
		(cons 'let-values* 
		      (cons (cdr bindings) body))))
	   (cond
	    ((not (pair? vars))		; regular let case, a single var
	     `(let ((,vars ,initializer)) ,cont))
	    ((null? (cdr vars))		; single var, see the prev case
	     `(let ((,(car vars) ,initializer)) ,cont))
	   (else			; the most generic case
	    `(call-with-values (lambda () ,initializer)
	      (lambda ,vars ,cont))))))
       (car bindings)))))


			; assoc-primitives with a default clause
			; If the search in the assoc list fails, the
			; default action argument is returned. If this
			; default action turns out to be a thunk,
			; the result of its evaluation is returned.
			; If the default action is not given, an error
			; is signaled

(define-macro (assq-def key alist . default-action-arg)
  (let ((default-action
        (if (null? default-action-arg)
          `(error "failed to assq key '" ,key "' in a list " ,alist)
          (let ((defact-symb (gensym)))
	    `(let ((,defact-symb ,(car default-action-arg)))
               (if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))))))
    `(or (assq ,key ,alist) ,default-action)))

(define-macro (assv-def key alist . default-action-arg)
  (let ((default-action
        (if (null? default-action-arg)
          `(error "failed to assv key '" ,key "' in a list " ,alist)
          (let ((defact-symb (gensym)))
	    `(let ((,defact-symb ,(car default-action-arg)))
               (if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))))))
    `(or (assv ,key ,alist) ,default-action)))

(define-macro (assoc-def key alist . default-action-arg)
  (let ((default-action
        (if (null? default-action-arg)
          `(error "failed to assoc key '" ,key "' in a list " ,alist)
          (let ((defact-symb (gensym)))
	    `(let ((,defact-symb ,(car default-action-arg)))
               (if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))))))
    `(or (assoc ,key ,alist) ,default-action)))


			; Convenience macros to avoid quoting of symbols
			; being deposited/looked up in the environment
(define-macro (env.find key) `(%%env.find ',key))
(define-macro (env.demand key) `(%%env.demand ',key))
(define-macro (env.bind key value) `(%%env.bind ',key ,value))

			; Implementation of SRFI-0
			; Only feature-identifiers srfi-0 and gambit
			; assumed predefined
(define-macro (cond-expand . clauses)
  (define feature-ids '(plt srfi-0))
  (define (feature-req-satisfies? fr) ; does feature-request satisfies?
    (cond
     ((memq fr feature-ids) #t)
     ((not (pair? fr)) #f)
     ((eq? 'and (car fr))
      (let loop ((clauses (cdr fr)))
	(or (null? clauses)
	    (and (feature-req-satisfies? (car clauses))
		 (loop (cdr clauses))))))
     ((eq? 'or (car fr))
      (let loop ((clauses (cdr fr)))
	(and (pair? clauses)
	     (or (feature-req-satisfies? (car clauses))
		 (loop (cdr clauses))))))
     ((eq? 'not (car fr))
      (not (feature-req-satisfies? (and (pair? (cdr fr)) (cadr fr)))))
     (else #f)))
  (let loop ((clauses clauses))
    (if (null? clauses) '(error "Unfulfilled cond-expand")
	(let* ((feature-req (if (pair? (car clauses)) (caar clauses)
				(error "<cond-expand clause> is not a list")))
	       (cmd-or-defs* (cons 'begin (cdar clauses))))
	  (cond
	   ((and (eq? 'else feature-req) (null? (cdr clauses)))
	    cmd-or-defs*)
	   ((feature-req-satisfies? feature-req)
	    cmd-or-defs*)
	   (else (loop (cdr clauses))))))))

;; [ssax-plt] Begin misc. other definitions needed by other modules.

(define (call-with-input-string str proc)
  (proc (open-input-string str)))

; I guess there's only one way to write this... :)
;(define (string-index str chr)
;  (let ((len (string-length str)))
;    (let search ((i 0))
;      (cond ((= i len)                       #f)
;            ((char=? chr (string-ref str i)) i)
;            (else                            (search (+ i 1)))))))
 
(define (with-input-from-string str thunk)
  (parameterize ((current-input-port (open-input-string str)))
    (thunk)))

;; [ssax-plt] End misc. other definitions needed by other modules.

;; [ssax-plt] Finish module.
;(provide (all-defined) pp))


;==============================================================================
; DL: this piece of code is taken from the previous version of "myenv.scm"
; Stubs

(define-macro (inc x) `(+ 1 ,x))
(define-macro (dec x) `(- ,x 1))

(define (cons* a1 a2 . rest)
  (if (null? rest)
      (cons a1 a2)
      (cons a1 (apply cons* (cons a2 rest)))))

;; Gambit's include and declare are disabled
(define-macro include (lambda (file) #f))
(define-macro declare (lambda x #f))

(provide (all-defined)))