;;;; chicken-dump.scm


(use srfi-4 srfi-69 lolevel matchable posix)

(include "constants.scm")

#>
#include "s11n-c.c"
<#


(define bytes_to_block (##core#primitive "bytes_to_block"))

(define (dump port)
  (let ((indent 0)
	(items 0)
	(header "")
	(backref-count 0) )
    (define (getb)
      (char->integer (read-char port)) )
    (define (getw)
      (##core#inline "bytes_to_word" (read-string +sizeof-ulong+ port)) )
    (define (fetchslots x i)
      (fluid-let ((indent (add1 indent)))
	(let ((len (##sys#size x)))
	  (do ((i i (add1 i)))
	      ((>= i len) x)
	    (fetchh (sprintf "[~a]" i))) ) ) )
    (define (out i? fstr . args)
      (display (make-string indent))
      (when i? (printf "#~a:" (sub1 items)))
      (printf "~a ~?~%" header fstr args) )
    (define (outh fstr . args)
      (printf "~a[~?]~%" (make-string indent) fstr args) )
    (define (fetchh hd)
      (fluid-let ((header hd))
	(fetch)))
    (define (fetch)
      (let ((tag (getb)))
	(select tag
	  ((sixtyfour-bit-tag) (out #f "64-bit mark") (fetch))
	  ((thirtytwo-bit-tag) (out #f "32-bit mark") (fetch))
	  ((big-endian-tag) (out #f "big endian mark") (fetch))
	  ((little-endian-tag) (out #f "little endian mark") (fetch))
	  ((void-tag) (out #f "void"))
	  ((null-tag) (out #f "()"))
	  ((eof-tag) (out #f "#!eof"))
	  ((true-tag) (out #f "#t"))
	  ((false-tag) (out #f "#f"))
	  ((backref-tag) 
	   (let ((w (getw)))
	     (out #f "back reference -> #~a" w) ) )
	  ((fixnum-tag)
	   (out #f "fixnum ~a" (##core#inline "bytes_to_fixnum" (read-string +sizeof-word+ port)) ))
	  ((char-tag)
	   (out #f "char ~s" (integer->char (getw)) ))
	  ((gensym-tag)
	   (set! items (add1 items))
	   (out #t "uninterned symbol:")
	   (fetchh "(name)") )
	  ((symbol-tag)
	   (set! items (add1 items))
	   (out #t "symbol:")
	   (fetchh "(name)"))
	  ((stdport-tag)
	   (set! items (add1 items))
	   (let* ((n (getb))
		  (r (sub1 backref-count)))
	     (case n
	       ((0) (out #t "stdin port"))
	       ((1) (out #t "stdout port"))
	       ((2) (out #t "stderr port"))
	       (else (out #t "invalid standard port - file possibly corrupt") ) ) ) )
	  ((hash-table-tag)
	   (set! items (add1 items))
	   (out #t "hash table:")
	   (fluid-let ((indent (+ 2 indent)))
	     (fetchh "(items)") )
	   (fluid-let ((indent (+ 2 indent)))
	     (fetchh "(comparison procedure)") )
	   (fluid-let ((indent (+ 2 indent)))
	     (fetchh "(hash function)") ))
	  (else
	   (call/cc 
	    (lambda (return)
	      (set! items (add1 items))
	      (let* ((h (read-string +sizeof-header+ port))
		     (x (bytes_to_block h)))
		(##core#inline "set_header" x h)
		(select tag
		  ((bytevector-tag)
		   (##core#inline "insert_bytes" x (read-string (##sys#size x) port))
		   (cond ((string? x) (out #t "string ~s" x))
			 ((number? x) (out #t "float ~s" x))
			 ((##core#inline "C_lambdainfop" x)
			  (out #t "lambda info ~a" x) )
			 (else
			  (out #t "byte-vector ~s" (byte-vector->u8vector x)) ) ) )
		  ((vector-tag)
		   (let ((off 0))
		     (cond ((vector? x) (out #t "vector"))
			   ((pair? x)
			    (out #t "pair:")
			    (fluid-let ((indent (add1 indent)))
			      (fetchh "(car)")
			      (fetchh "(cdr)")  )
			    (return #f) )
			   ((##sys#generic-structure? x) 
			    (out #t "structure:")
			    (fetchh "(tag)")
			    (set! off 1) )
			   (else (out #t "unknown vector-like object:")) )
		     (fetchslots x off)))
		  ((special-tag)
		   (out #t "(invalid) special vector-like object:")
		   (##core#inline "insert_bytes" x (read-string +sizeof-word+ port))
		   (fetchslots x 1) )
		  ((procedure-tag)
		   (out #t "procedure:")
		   (fluid-let ((indent (add1 indent)))
		     (fetchh "(id)")
		     (fetchslots x 1) ) )
		  (else (out #t "invalid tag ~a - file possibly corrupt" tag)) ) ) ) ) ) ) ) )
    (let loop ()
      (unless (eof-object? (peek-char port))
	(printf "~a:~%" (file-position port))
	(fetch) 
	(newline)
	(loop)))))

(define (version)
  (printf "chicken-dump ~a~%" +version+)
  (exit 0) )

(define (usage)
  (printf "usage: chicken-dump [FILE | OPTION ...]

  -v  -version                   show version and exit
  -h  -help                      show this message and exit~%")
  (exit 0) )

(define *dumped* #f)

(define (dump-file fn)
  (printf "~%File: ~a~%~%" fn)
  (set! *dumped* #t)
  (call-with-input-file fn dump) )

(let loop ((args (command-line-arguments)))
  (match args
    (() (unless *dumped* (usage)))
    (((or "-v" "-version") . _) (version))
    (((or "-h" "-help" "--help") . _) (usage))
    ((file . more)
     (dump-file file)
     (loop more)) ) )