;;;; s11n.scm


(declare
  (fixnum))


(module s11n (serialize deserialize serialization-mode)
  (import scheme chicken foreign)

(use srfi-69 extras)

(include "constants.scm")

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

(define procedure_to_id
  (foreign-lambda* c-string ((scheme-object p)) 
    "return(C_lookup_procedure_id((void *)C_block_item(p, 0)));") )

(define fixnum_to_bytes (##core#primitive "fixnum_to_bytes"))
(define word_to_bytes (##core#primitive "word_to_bytes"))
(define header_to_bytes (##core#primitive "header_to_bytes"))


(define serialization-mode (make-parameter 'host))


(define (serialize x #!optional (port (current-output-port)) serializer)
  (let ((table (make-hash-table eq?))
	(pos 0) )
    (define (emitb b)
      (write-char (integer->char b) port) )
    (define (emit s)
      (display s port) )
    (define (emitw w)
      (display (word_to_bytes w) port) )
    (define (walkslots x i)
      (let ((len (##sys#size x)))
	(do ((i i (add1 i)))
	    ((>= i len))
	  (walk (##sys#slot x i)) ) ) )
    (define (emitbytes x)
      (let ((len (##sys#size x)))
	(do ((i 0 (add1 i)))
	    ((>= i len))
	  (emitb (##sys#byte x i)) ) ) )
    (define (fail msg x)
      (if serializer
	  (walk (serializer x))
	  (error 'serialize (string-append "unable to serialize object - " msg) x)))
    (define (walk x)
      #+debug
      (fprintf 
       (current-error-port)
       "Emitting: ~a"
       (##sys#with-print-length-limit 
	80
	(lambda () (with-output-to-string (cut pp x)))))
      (cond ((fixnum? x) 
	     (emitb fixnum-tag)
	     (emit (fixnum_to_bytes x)) )
	    ((char? x)
	     (emitb char-tag)
	     (emitw (char->integer x)) )
	    ((##sys#immediate? x)
	     (select x
	       (((##core#undefined)) (emitb void-tag))
	       ((#t) (emitb true-tag))
	       ((#f) (emitb false-tag))
	       ((#!eof) (emitb eof-tag))
	       (('()) (emitb null-tag))
	       (else (fail "can not serialize immediate value" x))) )
	    ((hash-table-ref/default table x #f) =>
	     (lambda (pos)
	       (emitb backref-tag)
	       (emitw pos) ) )
	    (else
	     (hash-table-set! table x pos)
	     (set! pos (add1 pos))
	     (cond ((procedure? x)
		    (emitb procedure-tag)
		    (emit (header_to_bytes x))
		    (let ((id (procedure_to_id x)))
		      (cond ((not id)
			     (set! pos (sub1 pos))
			     (fail "unable to serialize procedure (no table entry found)" x) )
			    (else
			     (walk id)
			     (walkslots x 1) ) ) ) )
		   ((##core#inline "C_specialp" x)
		    (cond ((port? x)
			   (let ((name (##sys#slot x 3)))
			     (cond ((string=? "(stdin)" name)
				    (emitb stdport-tag)
				    (emitb 0) )
				   ((string=? "(stdout)" name)
				    (emitb stdport-tag)
				    (emitb 1) )
				   ((string=? "(stderr)" name)
				    (emitb stdport-tag)
				    (emitb 2) )
				   ((not (zero? (##sys#pointer->address x)))
				    (fail "can not serialize stream port" x) )
				   (else
				    (emitb vector-tag)
				    (emit (header_to_bytes x))
				    (emitw 0)
				    (walkslots x 1) ) ) ) )
			  (else
			   (fail "can not serialize pointer-like object" x)
			   #| (emitb special-tag)
			   (emit (header_to_bytes x))
			   (walkslots x 1) |#) ) )
		   ((##core#inline "C_byteblockp" x)
		    (emitb bytevector-tag)
		    (emit (header_to_bytes x))
		    (emitbytes x) )
		   ((symbol? x)
		    (emitb
		     (if (not (##core#inline "C_lookup_symbol" x))
			 gensym-tag
			 symbol-tag) )
		    (walk (##sys#slot x 1)) )
		   ((hash-table? x)
		    (emitb hash-table-tag)
		    (walk (hash-table->alist x))
		    (walkslots x 3) )
		   (else
		    (emitb vector-tag)
		    (emit (header_to_bytes x))
		    (walkslots x 0) ) ) ) ) )
    (when (eq? (serialization-mode) 'portable)
      (emitb (if (##sys#fudge 3) sixtyfour-bit-tag thirtytwo-bit-tag))
      (emitb +endianness-tag+) )
    (walk x) ) )

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

(define stdin-port ##sys#standard-input)
(define stdout-port ##sys#standard-output)
(define stderr-port ##sys#standard-error)

(define (deserialize #!optional (port (current-input-port)) fallback (safe #t))
  (let ((backrefs (make-vector 100))
	(backref-count 0) )
    (define (getb)
      (let ((c (read-char port)))
	(if (eof-object? c)
	    (error 'deserialize "unexpected end of input" port)
	    (char->integer c))))
    (define (getw)
      (##core#inline "bytes_to_word" (read-string +sizeof-ulong+ port)) )
    (define (addref x)
      (when (>= backref-count (vector-length backrefs))
	(set! backrefs (vector-resize backrefs (* 2 backref-count))) )
      (vector-set! backrefs backref-count x)
      (set! backref-count (add1 backref-count))
      x)
    (define (fetchslots x i)
      (let ((len (##sys#size x)))
	(do ((i i (add1 i)))
	    ((>= i len) x)
	  (##sys#setslot x i (fetch)) ) ) )
    (define (fetch)
      (let ((tag (getb)))
	(select tag
	  ((sixtyfour-bit-tag) (fetch))
	  ((thirtytwo-bit-tag) (fetch))
	  ((big-endian-tag) (fetch))
	  ((little-endian-tag) (fetch))
	  ((void-tag) (void))
	  ((null-tag) '())
	  ((eof-tag) #!eof)
	  ((true-tag) #t)
	  ((false-tag) #f)
	  ((backref-tag)
	   (let ((w (getw)))
	     (vector-ref backrefs w)) )
	  ((fixnum-tag)
	   (##core#inline "bytes_to_fixnum" (read-string +sizeof-word+ port)) )
	  ((char-tag)
	   (integer->char (getw)) )
	  ((gensym-tag)
	   (addref #f)
	   (let* ((r (sub1 backref-count))
		  (x (##sys#make-symbol (fetch))) )
	     (vector-set! backrefs r x)
	     x) )
	  ((symbol-tag)
	   (addref #f)
	   (let* ((r (sub1 backref-count))
		  (x (##sys#intern-symbol (fetch)) ))
	     (vector-set! backrefs r x)
	     x) )
	  ((stdport-tag)
	   (addref #f)
	   (let* ((n (getb))
		  (r (sub1 backref-count))
		  (p (case n
		       ((0) stdin-port)
		       ((1) stdout-port)
		       ((2) stderr-port)
		       (else (error 'deserialize "invalid standard-port number" n)) ) ) )
	     (vector-set! backrefs r p)
	     p) )
	  ((hash-table-tag)
	   (addref #f)
	   (let ((r (sub1 backref-count))
		 (ht (##sys#make-structure 'hash-table #f 0 #f #f)) )
	     (vector-set! backrefs r ht)
	     (let* ((table (fetch))
		    (test (fetch))
		    (hashf (fetch)) 
		    (ht2 (alist->hash-table table)) )
	       (##sys#setslot ht 1 (##sys#slot ht2 1))
	       (##sys#setslot ht 2 (##sys#slot ht2 2))
	       (##sys#setslot ht 3 test)
	       (##sys#setslot ht 4 hashf)
	       ht) ) )
	  (else
	   (let* ((h (read-string +sizeof-header+ port))
		  (x (addref (bytes_to_block h))) 
		  (r (sub1 backref-count)) )
	     (##core#inline "set_header" x h)
	     (select tag
	       ((bytevector-tag)
		(##core#inline "insert_bytes" x (read-string (##sys#size x) port))
		x)
	       ((vector-tag) (fetchslots x 0))
	       #;((special-tag)
		(when safe
		  (error 'deserialize "unable to deserialize pointer-like object" x) )
		(##core#inline "insert_bytes" x (read-string +sizeof-word+ port))
		(fetchslots x 1) )
	       ((procedure-tag)
		(let ((id (fetch)))
		  (cond ((##core#inline "set_procedure_ptr" x (##sys#make-c-string id))
			 (fetchslots x 1) )
			(fallback 
			 (let ((proc (fallback id (fetchslots x 1))))
			   (vector-set! backrefs r proc)
			   proc) )
			(else (error 'deserialize "unable to deserialize procedure - no table entry found" id))) ) )
	       (else (error 'deserialize "invalid tag" tag)) ) ) ) ) ) )
    (fetch) ) )

)