 obj is nil or false, this can return a false value.  OTOH
;; usually this is only for non-immediates.
(define (readable? obj)
  (hashq-ref readables obj))

;;;
;;; Writer helpers
;;;

(define (write-component-procedure o file env)
  "Return #f if circular reference"
  (cond ((immediate? o) (write o file) #t)
	((readable? o) (write (readable-expression o) file) #t)
	((excluded? o env) (display #f file) #t)
	(else
	 (let ((info (object-info o env)))
	   (cond ((not (binding? info)) (write-readably o file env) #t)
		 ((not (eq? (visiting info) #:defined)) #f) ;forward reference
		 (else (display (binding info) file) #t))))))

;;; write-component OBJECT PATCHER FILE ENV
;;;
(define-macro (write-component object patcher file env)
  `(or (write-component-procedure ,object ,file ,env)
       (begin
         (display #f ,file)
         (add-patcher! ,patcher ,env))))

;;;
;;; Strings
;;;

(define-method (enumerate! (o <string>) env) #f)

;;;
;;; Vectors
;;;

(define-method (enumerate! (o <vector>) env)
  (or (not (vector? o))
      (let ((literal? #t))
	(array-for-each (lambda (o)
			  (if (not (enumerate-component! o env))
			      (set! literal? #f)))
			o)
	literal?)))

(define-method (write-readably (o <vector>) file env)
  (if (not (vector? o))
      (write o file)
      (let ((n (vector-length o)))
	(if (zero? n)
	    (display "#()" file)
	    (let ((not-literal? (not (literal? o env))))
	      (display (if not-literal?
			   "(vector "
			   "#(")
		       file)
	      (if (and not-literal?
		       (literal? (vector-ref o 0) env))
		  (display #\' file))
	      (write-component (vector-ref o 0)
			       `(vector-set! ,o 0 ,(vector-ref o 0))
			       file
			       env)
	      (do ((i 1 (+ 1 i)))
		  ((= i n))
		(display #\space file)
		(if (and not-literal?
			 (literal? (vector-ref o i) env))
		    (display #\' file))
		(write-component (vector-ref o i)
				 `(vector-set! ,o ,i ,(vector-ref o i))
				 file
				 env))
	      (display #\) file))))))


;;;
;;; Arrays
;;;

(define-method (enumerate! (o <array>) env)
  (enumerate-component! (shared-array-root o) env))

(define (make-mapper array)
  (let* ((n (array-rank array))
	 (indices (reverse (if (<= n 11)
			       (list-tail '(t s r q p n m l k j i)  (- 11 n))
			       (let loop ((n n)
					  (ls '()))
				 (if (zero? n)
				     ls
				     (loop (- n 1)
					   (cons (gensym "i") ls))))))))
    `(lambda ,indices
       (+ ,(shared-array-offset array)
	  ,@(map (lambda (ind dim inc)
		   `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind)))
		 indices
		 (array-dimensions array)
		 (shared-array-increments array))))))

(define (write-array prefix o not-literal? file env)
  (letrec ((inner (lambda (n indices)
		    (if (not (zero? n))
			(let ((el (apply array-ref o
					 (reverse (cons 0 indices)))))
			  (if (and not-literal?
				   (literal? el env))
			      (display #\' file))
			  (write-component
			   el
			   `(array-set! ,o ,el ,@indices)
			   file
			   env)))
		    (do ((i 1 (+ 1 i)))
			((= i n))
		      (display #\space file)
		      (let ((el (apply array-ref o
					 (reverse (cons i indices)))))
			  (if (and not-literal?
				   (literal? el env))
			      (display #\' file))
			  (write-component
			   el
			   `(array-set! ,o ,el ,@indices)
			   file
			   env))))))
    (display prefix file)
    (let loop ((dims (array-dimensions o))
	       (indices '()))
      (cond ((null? (cdr dims))
	     (inner (car dims) indices))
	    (else
	     (let ((n (car dims)))
	       (do ((i 0 (+ 1 i)))
		   ((= i n))
		 (if (> i 0)
		     (display #\space file))
		 (display prefix file)
		 (loop (cdr dims) (cons i indices))
		 (display #\) file))))))
    (display #\) file)))

(define-method (write-readably (o <array>) file env)
  (let ((root (shared-array-root o)))
    (cond ((literal? o env)
	   (if (not (vector? root))
	       (write o file)
	       (begin
		 (display #\# file)
		 (display (array-rank o) file)
		 (write-array #\( o #f file env))))
	  ((binding? root env)
	   (display "(make-shared-array " file)
	   (if (literal? root env)
	       (display #\' file))
	   (write-component root
			    (goops-error "write-readably(<array>): internal error")
			    file
			    env)
	   (display #\space file)
	   (display (make-mapper o) file)
	   (for-each (lambda (dim)
		       (display #\space file)
		       (display dim file))
		     (array-dimensions o))
	   (display #\) file))
	  (else
	   (display "(list->uniform-array " file)
	   (display (array-rank o) file)
	   (display " '() " file)
	   (write-array "(list " o #f file env)))))

;;;
;;; Pairs
;;;

;;; These methods have more complex structure than is required for
;;; most objects, since they take over some of the logic of
;;; `write-component'.
;;;

(define-method (enumerate! (o <pair>) env)
  (let ((literal? (enumerate-component! (car o) env)))
    (and (enumerate-component! (cdr o) env)
	 literal?)))

(define-method (write-readably (o <pair>) file env)
  (let ((proper? (let loop ((ls o))
		   (or (null? ls)
		       (and (pair? ls)
			    (not (binding? (cdr ls) env))
			    (loop (cdr ls))))))
	(1? (or (not (pair? (cdr o)))
		(binding? (cdr o) env)))
	(not-literal? (not (literal? o env)))
	(infos '())
	(refs (ref-stack env)))
    (display (cond ((not not-literal?) #\()
		   (proper? "(list ")
		   (1? "(cons ")
		   (else "(cons* "))
	     file)
    (if (and not-literal?
	     (literal? (car o) env))
	(display #\' file))
    (write-component (car o) `(set-car! ,o ,(car o)) file env)
    (do ((ls (cdr o) (cdr ls))
	 (prev o ls))
	((or (not (pair? ls))
	     (binding? ls env))
	 (if (not (null? ls))
	     (begin
	       (if (not not-literal?)
		   (display " ." file))
	       (display #\space file)
	       (if (and not-literal?
			(literal? ls env))
		   (display #\' file))
	       (write-component ls `(set-cdr! ,prev ,ls) file env)))
	 (display #\) file))
      (display #\space file)
      (set! infos (cons (object-info ls env) infos))
      (push-ref! ls env) ;*fixme* optimize
      (set! (visiting? (car infos)) #t)
      (if (and not-literal?
	       (literal? (car ls) env))
	  (display #\' file))
      (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
      )
    (for-each (lambda (info)
		(set! (visiting? info) #f))
	      infos)
    (set! (ref-stack env) refs)
    ))

;;;
;;; Objects
;;;

;;; Doesn't yet handle unbound slots

;; Don't export this function!  This is all very temporary.
;;
(define (get-set-for-each proc class)
  (for-each (lambda (slot)
	      (unless (memq (slot-definition-allocation slot)
                            '(#:class #:each-subclass))
                (let ((ref (slot-definition-slot-ref slot))
                      (set (slot-definition-slot-set! slot))
                      (index (slot-definition-index slot)))
                  (if ref
                      (proc ref set)
                      (proc (standard-get index) (standard-set index))))))
	    (class-slots class)))

(define (access-for-each proc class)
  (for-each (lambda (slot)
              (unless (memq (slot-definition-allocation slot)
                            '(#:class #:each-subclass))
                (let ((name (slot-definition-name slot))
                      (accessor (and=> (slot-definition-accessor slot)
                                       generic-function-name))
                      (ref (slot-definition-slot-ref slot))
                      (set (slot-definition-slot-set! slot))
                      (index (slot-definition-index slot)))
                  (if ref
                      (proc name accessor ref set)
                      (proc name accessor
                            (standard-get index) (standard-set index))))))
	    (class-slots class)))

(define-macro (restore class slots . exps)
  "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
  `(let ((o ((@@ (oop goops) %allocate-instance) ,class '())))
     (for-each (lambda (name val)
                 (slot-set! o name val))
               ',slots
               (list ,@exps))
     o))

(define-method (enumerate! (o <object>) env)
  (get-set-for-each (lambda (get set)
		      (let ((val (get o)))
			(if (not (unbound? val))
			    (enumerate-component! val env))))
		    (class-of o))
  #f)

(define-method (write-readably (o <object>) file env)
  (let ((class (class-of o)))
    (display "(restore " file)
    (display (class-name class) file)
    (display " (" file)
    (let ((slotdefs
	   (filter (lambda (slotdef)
		     (not (or (memq (slot-definition-allocation slotdef)
				    '(#:class #:each-subclass))
			      (and (slot-bound? o (slot-definition-name slotdef))
				   (excluded?
				    (slot-ref o (slot-definition-name slotdef))
				    env)))))
		   (class-slots class))))
      (if (not (null? slotdefs))
	  (begin
	    (display (slot-definition-name (car slotdefs)) file)
	    (for-each (lambda (slotdef)
			(display #\space file)
			(display (slot-definition-name slotdef) file))
		      (cdr slotdefs)))))
    (display #\) file)
    (access-for-each (lambda (name aname get set)
		       (display #\space file)
		       (let ((val (get o)))
			 (cond ((unbound? val)
				(display '(make-unbound) file))
			       ((excluded? val env))
			       (else
				(if (literal? val env)
				    (display #\' file))
				(write-component val
						 (if aname
						     `(set! (,aname ,o) ,val)
						     `(slot-set! ,o ',name ,val))
						 file env)))))
		     class)
    (display #\) file)))

;;;
;;; Classes
;;;

;;; Currently, we don't support reading in class objects
;;;

(define-method (enumerate! (o <class>) env) #f)

(define-method (write-readably (o <class>) file env)
  (display (class-name o) file))

;;;
;;; Generics
;;;

;;; Currently, we don't support reading in generic functions
;;;

(define-method (enumerate! (o <generic>) env) #f)

(define-method (write-readably (o <generic>) file env)
  (display (generic-function-name o) file))

;;;
;;; Method
;;;

;;; Currently, we don't support reading in methods
;;;

(define-method (enumerate! (o <method>) env) #f)

(define-method (write-readably (o <method>) file env)
  (goops-error "No read-syntax for <method> defined"))

;;;
;;; Environments
;;;

(define-class <environment> ()
  (object-info 	  #:accessor object-info
	       	  #:init-form (make-hash-table 61))
  (excluded	  #:accessor excluded
		  #:init-form (make-hash-table 61))
  (pass-2?	  #:accessor pass-2?
		  #:init-value #f)
  (ref-stack	  #:accessor ref-stack
		  #:init-value '())
  (objects	  #:accessor objects
		  #:init-value '())
  (pre-defines	  #:accessor pre-defines
		  #:init-value '())
  (locals	  #:accessor locals
		  #:init-value '())
  (stand-ins	  #:accessor stand-ins
		  #:init-value '())
  (post-defines	  #:accessor post-defines
		  #:init-value '())
  (patchers	  #:accessor patchers
		  #:init-value '())
  (multiple-bound #:accessor multiple-bound
		  #:init-value '())
  )

(define-method (initialize (env <environment>) initargs)
  (next-method)
  (cond ((get-keyword #:excluded initargs #f)
	 => (lambda (excludees)
	      (for-each (lambda (e)
			  (hashq-create-handle! (excluded env) e #f))
			excludees)))))

(define-method (object-info o env)
  (hashq-ref (object-info env) o))

(define-method ((setter object-info) o env x)
  (hashq-set! (object-info env) o x))

(define (excluded? o env)
  (hashq-get-handle (excluded env) o))

(define (add-patcher! patcher env)
  (set! (patchers env) (cons patcher (patchers env))))

(define (push-ref! o env)
  (set! (ref-stack env) (cons o (ref-stack env))))

(define (pop-ref! env)
  (set! (ref-stack env) (cdr (ref-stack env))))

(define (container env)
  (car (ref-stack env)))

(define-class <object-info> ()
  (visiting  #:accessor visiting
	     #:init-value #f)
  (binding   #:accessor binding
	     #:init-value #f)
  (literal?  #:accessor literal?
	     #:init-value #f)
  )

(define visiting? visiting)

(define-method (binding (info <boolean>))
  #f)

(define-method (binding o env)
  (binding (object-info o env)))

(define binding? binding)

(define-method (literal? (info <boolean>))
  #t)

;;; Note that this method is intended to be used only during the
;;; writing pass
;;;
(define-method (literal? o env)
  (or (immediate? o)
      (excluded? o env)
      (let ((info (object-info o env)))
	;; write-component sets all bindings first to #:defining,
	;; then to #:defined
	(and (or (not (binding? info))
		 ;; we might be using `literal?' in a write-readably method
		 ;; to query about the object being defined
		 (and (eq? (visiting info) #:defining)
		      (null? (cdr (ref-stack env)))))
	     (literal? info)))))

;;;
;;; Enumeration
;;;

;;; Enumeration has two passes.
;;;
;;; Pass 1: Detect common substructure, circular references and order
;;;
;;; Pass 2: Detect literals

(define (enumerate-component! o env)
  (cond ((immediate? o) #t)
	((readable? o) #f)
	((excluded? o env) #t)
	((pass-2? env)
	 (let ((info (object-info o env)))
	   (if (binding? info)
	       ;; if circular reference, we print as a literal
	       ;; (note that during pass-2, circular references are
	       ;;  forward references, i.e. *not* yet marked with #:pass-2
	       (not (eq? (visiting? info) #:pass-2))
	       (and (enumerate! o env)
		    (begin
		      (set! (literal? info) #t)
		      #t)))))
	((object-info o env)
	 => (lambda (info)
	      (set! (binding info) #t)
	      (if (visiting? info)
		  ;; circular reference--mark container
		  (set! (binding (object-info (container env) env)) #t))))
	(else
	 (let ((info (make <object-info>)))
	   (set! (object-info o env) info)
	   (push-ref! o env)
	   (set! (visiting? info) #t)
	   (enumerate! o env)
	   (set! (visiting? info) #f)
	   (pop-ref! env)
	   (set! (objects env) (cons o (objects env)))))))


;;;
;;; Main engine
;;;

(define binding-name car)
(define binding-object cdr)

(define (pass-1! alist env)
  ;; Determine object order and necessary bindings
  (for-each (lambda (binding)
	      (enumerate-component! (binding-object binding) env))
	    alist))

(define (make-local i)
  (string->symbol (string-append "%o" (number->string i))))

(define (name-bindings! alist env)
  ;; Name top-level bindings
  (for-each (lambda (b)
	      (let ((o (binding-object b)))
		(if (not (or (immediate? o)
			     (readable? o)
			     (excluded? o env)))
		    (let ((info (object-info o env)))
		      (if (symbol? (binding info))
			  ;; already bound to a variable
			  (set! (multiple-bound env)
				(acons (binding info)
				       (binding-name b)
				       (multiple-bound env)))
			  (set! (binding info)
				(binding-name b)))))))
	    alist)
  ;; Name rest of bindings and create stand-in and definition lists
  (let post-loop ((ls (objects env))
		  (post-defs '()))
    (cond ((or (null? ls)
	       (eq? (binding (car ls) env) #t))
	   (set! (post-defines env) post-defs)
	   (set! (objects env) ls))
	  ((not (binding (car ls) env))
	   (post-loop (cdr ls) post-defs))
	  (else
	   (post-loop (cdr ls) (cons (car ls) post-defs)))))
  (let pre-loop ((ls (reverse (objects env)))
		 (i 0)
		 (pre-defs '())
		 (locs '())
		 (sins '()))
    (if (null? ls)
	(begin
	  (set! (pre-defines env) (reverse pre-defs))
	  (set! (locals env) (reverse locs))
	  (set! (stand-ins env) (reverse sins)))
	(let ((info (object-info (car ls) env)))
	  (cond ((not (binding? info))
		 (pre-loop (cdr ls) i pre-defs locs sins))
		((boolean? (binding info))
		 ;; local
		 (set! (binding info) (make-local i))
		 (pre-loop (cdr ls)
			   (+ 1 i)
			   pre-defs
			   (cons (car ls) locs)
			   sins))
		((null? locs)
		 (pre-loop (cdr ls)
			   i
			   (cons (car ls) pre-defs)
			   locs
			   sins))
		(else
		 (let ((real-name (binding info)))
		   (set! (binding info) (make-local i))
		   (pre-loop (cdr ls)
			     (+ 1 i)
			     pre-defs
			     (cons (car ls) locs)
			     (acons (binding info) real-name sins)))))))))

(define (pass-2! env)
  (set! (pass-2? env) #t)
  (for-each (lambda (o)
	      (let ((info (object-info o env)))
		(set! (literal? info) (enumerate! o env))
		(set! (visiting info) #:pass-2)))
	    (append (pre-defines env)
		    (locals env)
		    (post-defines env))))

(define (write-define! name val literal? file)
  (display "(define " file)
  (display name file)
  (display #\space file)
  (if literal? (display #\' file))
  (write val file)
  (display ")\n" file))

(define (write-empty-defines! file env)
  (for-each (lambda (stand-in)
	      (write-define! (cdr stand-in) #f #f file))
	    (stand-ins env))
  (for-each (lambda (o)
	      (write-define! (binding o env) #f #f file))
	    (post-defines env)))

(define (write-definition! prefix o file env)
  (display prefix file)
  (let ((info (object-info o env)))
    (display (binding info) file)
    (display #\space file)
    (if (literal? info)
	(display #\' file))
    (push-ref! o env)
    (set! (visiting info) #:defining)
    (write-readably o file env)
    (set! (visiting info) #:defined)
    (pop-ref! env)
    (display #\) file)))

(define (write-let*-head! file env)
  (display "(let* (" file)
  (write-definition! "(" (car (locals env)) file env)
  (for-each (lambda (o)
	      (write-definition! "\n       (" o file env))
	    (cdr (locals env)))
  (display ")\n" file))

(define (write-rebindings! prefix bindings file env)
  (for-each (lambda (patch)
	      (display prefix file)
	      (display (cdr patch) file)
	      (display #\space file)
	      (display (car patch) file)
	      (display ")\n" file))
	    bindings))

(define (write-definitions! selector prefix file env)
  (for-each (lambda (o)
	      (write-definition! prefix o file env)
	      (newline file))
	    (selector env)))

(define (write-patches! prefix file env)
  (for-each (lambda (patch)
	      (display prefix file)
	      (display (let name-objects ((patcher patch))
			 (cond ((binding patcher env)
				=> (lambda (name)
				     (cond ((assq name (stand-ins env))
					    => cdr)
					   (else name))))
			       ((pair? patcher)
				(cons (name-objects (car patcher))
				      (name-objects (cdr patcher))))
			       (else patcher)))
		       file)
	      (newline file))
	    (reverse (patchers env))))

(define (write-immediates! alist file)
  (for-each (lambda (b)
	      (if (immediate? (binding-object b))
		  (write-define! (binding-name b)
				 (binding-object b)
				 #t
				 file)))
	    alist))

(define (write-readables! alist file env)
  (let ((written '()))
    (for-each (lambda (b)
		(cond ((not (readable? (binding-object b))))
		      ((assq (binding-object b) written)
		       => (lambda (p)
			    (set! (multiple-bound env)
				  (acons (cdr p)
					 (binding-name b)
					 (multiple-bound env)))))
		      (else
		       (write-define! (binding-name b)
				      (readable-expression (binding-object b))
				      #f
				      file)
		       (set! written (acons (binding-object b)
					    (binding-name b)
					    written)))))
	      alist)))

(define-method (save-objects (alist <pair>) (file <string>) . rest)
  (let ((port (open-output-file file)))
    (apply save-objects alist port rest)
    (close-port port)
    *unspecified*))

(define-method (save-objects (alist <pair>) (file <output-port>) . rest)
  (let ((excluded (if (>= (length rest) 1) (car rest) '()))
	(uses     (if (>= (length rest) 2) (cadr rest) '())))
    (let ((env (make <environment> #:excluded excluded)))
      (pass-1! alist env)
      (name-bindings! alist env)
      (pass-2! env)
      (if (not (null? uses))
	  (begin
	    (write `(use-modules ,@uses) file)
	    (newline file)))
      (write-immediates! alist file)
      (if (null? (locals env))
	  (begin
	    (write-definitions! post-defines "(define " file env)
	    (write-patches! "" file env))
	  (begin
	    (write-definitions! pre-defines "(define " file env)
	    (write-empty-defines! file env)
	    (write-let*-head! file env)
	    (write-rebindings! "  (set! " (stand-ins env) file env)
	    (write-definitions! post-defines "  (set! " file env)
	    (write-patches! "  " file env)
	    (display "  )\n" file)))
      (write-readables! alist file env)
      (write-rebindings! "(define " (reverse (multiple-bound env)) file env))))

(define-method (load-objects (file <string>))
  (let* ((port (open-input-file file))
	 (objects (load-objects port)))
    (close-port port)
    objects))

(define iface (module-public-interface (current-module)))

(define-method (load-objects (file <input-port>))
  (let ((m (make-module)))
    (module-use! m the-scm-module)
    (module-use! m iface)
    (save-module-excursion
     (lambda ()
       (set-current-module m)
       (let loop ((sexp (read file)))
	 (if (not (eof-object? sexp))
	     (begin
	       (eval sexp m)
	       (loop (read file)))))))
    (module-map (lambda (name var)
		  (cons name (variable-ref var)))
		m)))
