;;====Fromwil:NewMacros:Version 2:utils.sch====
; Utilities (need to be loaded before interpreter)

; THE FOLLOWING THREE DEFINITIONS ARE IMPLEMENTATION-DEPENDENT

(define scheme-eval
  ;; #'schi:scheme-eval                 ; Pseudoscheme
  ;; (*value t-standard-env 'eval)      ; T
  ;; (access-scheme-48 'eval)           ; Scheme-48
  ;; eval
  (lambda (exp ignored) (##eval-global exp))    ; Gambit
  )

(define (make-transformer-environment)
  ;; schi:usual-context                         ; Pseudoscheme
  ;; ((*value t-standard-env 'make-locale) scheme-env 'transformer-env) ; T
  ;; (access-scheme-48 'user-initial-environment) ;Scheme-48
  '()
  )

; Most Schemes already have some kind of ERROR form defined.
; (define error (access-scheme-48 'error))

; Evaluate an expression written in the transformer language

(define (eval-transformer exp env)
  (let ((exp (if (and (pair? exp)
                      (eq? (car exp) 'syntax-rules))
                 (rewrite-syntax-rules exp (lambda (x) x) eq?)
                 exp)))
    (scheme-eval exp env)))

(define (syntax-error message form)
  (error message form))

; In lieu of define-record-type

(define (vector-predicate type-name)
  (lambda (obj)
    (and (vector? obj)
         (> (vector-length obj) 0)
         (eq? (vector-ref obj 0) type-name))))

(define (vector-accessor type-name index)
  (let ((pred (vector-predicate type-name)))
    (lambda (obj)
      (if (pred obj)
          (vector-ref obj index)
          (error "bad argument" type-name obj)))))

(define (vector-updater type-name index)
  (let ((pred (vector-predicate type-name)))
    (lambda (obj val)
      (if (pred obj)
          (vector-set! obj index val)
          (error "bad argument" type-name obj)))))

; Misc.

(define (any pred l)
  (and (not (null? l))
       (or (pred (car l))
           (any pred (cdr l)))))

(define (every? pred l)
  (cond ((null? l) #t)
        ((pred (car l)) (every? pred (cdr l)))
        (else #f)
) )

(define (right-assq x l)
  (if (null? l)
      #f
      (if (eq? x (cdar l))
          (car l)
          (right-assq x (cdr l)))))

(define (make-table)
  (list 'table))

(define (table-ref table key)
  (let ((probe (assq key (cdr table))))
    (if probe
        (cdr probe)
        #f)))

(define (table-set! table key value)
  (set-cdr! table (cons (cons key value) (cdr table))))

;;             	    --- E O F ---                      	;;