;;; Non-R4RS functions, edit for compatability
;;; dsssl-compat.scm
;;; Copyright Henry S. Thompson 1996
;;; Alpha version 0.6, not for onward distribution

;;; Produced at HCRC, Edinburgh with support for the UK Economic and Social
;;;  Research Council and SunSoft

;;; THIS VERSION FOR ELK
;;; Last edited: Fri Aug  9 1996

(define sce-error
  (lambda (type string)
    (error type string)))

(define this-scheme 'elk)
(define defmacro '())

(case this-scheme
  ((gambit)
   (set! reverse!
         (lambda (l)
           (if (pair? l)
             (let loop ((ptr l)
                        (result '()))
               (if (pair? ptr)
                 (let ((tmp (cdr ptr)))
                   (set-cdr! ptr result)
                   (loop tmp ptr))
                 result))
             l))))
  (else (set! defmacro
  ;; calling sequence (defmacro (macname arg ...) body-expr)
  define-macro)))

;;; properties are not in r4rs, so someone may need this
;;; NOT DEBUGGED YET!!!

(define def-properties
  (lambda ()
   (set! *properties* '())
   (set! get (lambda (sym key)
	       (let ((pl (assq sym *properties*)))
		 (if pl ((cond ((assq key (cdr pl))
				=>
				cdr)
			       (else #f)))))))    
   (set! put (lambda args
	       (let ((sym (car args))
		     (key (cadr args)))
		 (let ((pl (assq sym *properties*)))
		   (if (cddr args)
		       ;; new value
		       (if pl
			   (cond ((assq key (cdr pl))
				  =>
				  (lambda (entry)
				    (set-cdr! entry (caddr args))))
				 (else (set-cdr! pl
						 (cons (cons key (caddr args))
						       (cdr pl)))))
			   (set! *properties*
				 (cons (list sym (cons key (caddr args)))
				       *properties*)))
		     ;; remove value
		     (if pl
			 (cond ((assq key (cdr pl))
				=>
				(lambda (entry)
				  (let loop ((ptr pl))
				       (if (eq? (cadr ptr) entry)
					   (set-cdr! ptr (cddr ptr))
					 (loop (cdr ptr)))))))))))))))


;; The following is for d!read as borrowed from s48

(define ascii-limit 255)
(define char->ascii char->integer)
(define ascii->char integer->char)
(define ascii-whitespaces 
  (map char->ascii '(#\tab #\newline #\space)))
(define input-port-option
  (lambda (plist)
    (if (pair? plist)
      (car plist)
      (current-input-port))))
(define (reverse-list->string l n)
      (list->string (reverse l)))
(define (make-immutable! x) x)


