(require 'srfi-1)
(require 'srfi-13)
;; need srfi-9, too

;; Provide mostly-MzScheme-compatible hash-table interface over
;; chicken's native hash-tables.

(define hash-table-for-each
  (let ((old hash-table-for-each))
    (lambda (ht p)
      (old p ht))))

(define hash-table-get
  (let ((default "default"))
    (lambda (ht key thunk)
      (let ((result (hash-table-ref ht key default)))
	(if (eq? result default)
	    (thunk)
	    result)))))

(define (hash-table-map ht p)
  (map (lambda (cell) (p (car cell) (cdr cell)))
       (hash-table->list ht)))

(define hash-table-put! hash-table-set!)

;; (hash-table-remove! ht key) already present and correct

;; make-hash-table: point of departure: doesn't support weak tables
(define make-hash-table
  (let ((old make-hash-table))
    (lambda args
      (if (memv 'equal args)
	  (old equal?)
	  (old eq?)))))

(define (unimplemented-procedure name)
  (lambda x (error "Unimplemented procedure" name x)))

(define numerator (unimplemented-procedure 'numerator))
(define denominator (unimplemented-procedure 'denominator))
(define rationalize (unimplemented-procedure 'rationalize))
(define make-rectangular (unimplemented-procedure 'make-rectangular))
(define make-polar (unimplemented-procedure 'make-polar))
(define real-part (unimplemented-procedure 'real-part))
(define imag-part (unimplemented-procedure 'imag-part))
(define magnitude (unimplemented-procedure 'magnitude))
(define angle (unimplemented-procedure 'angle))

(define-record-printer (variant-instance x p)
  (for-each (lambda (x) (display x p))
	    (list "#<"
		  ;;(variant-type-name (variant-instance-variant-type x))
		  ;;" "
		  (variant-instance-variant-name x)
		  " "))
  (write (vector->list (variant-instance-field-values x)) p)
  (display ">" p))

(define-record-printer (variant-type x p)
  (for-each (lambda (x) (display x p))
	    (list "#<variant-type "
		  (variant-type-name x)
		  " "
		  (vector->list (variant-type-variant-names x))
		  ">")))

(define-record-printer (syntax-wrap x p)
  (for-each (lambda (x) (display x p))
	    (list "#<wrap "
		  (syntax-wrap-wrapped-exp x)
		  " "
		  (syntax-wrap-pending-substs x)
		  " "
		  (syntax-wrap-pending-marks x)
		  ">")))

(define-record-printer (syntax-substitution x p)
  (for-each (lambda (x) (display x p))
	    (list "#<subst "
		  (syntax-substitution-old-sym x)
		  " "
		  (syntax-substitution-old-marks x)
		  " "
		  (syntax-substitution-new-sym x)
		  ">")))

(define (command-line-arguments)
  (cddr (argv)))