;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-

;(k-unfasl "jb:k;boot.kfasl#380" :output "jb:k;boot.unkfasl#380" :for-srccom t)
;(k-unfasl "jb:k;lisp-internals.KFASL")

(defconstant $$FASL-OP-END-OF-FILE #X00)
;; Followed by nothing, exits the mini-fasloader

(defconstant $$FASL-OP-STRING      #x01)
;; Followed by a fixnum size, and then the characters

(defconstant $$fasl-op-fixnum		#x02)
(defconstant $$fasl-op-string-character	#x03)
(defconstant $$fasl-op-nil		#x04)
(defconstant $$fasl-op-cons             #x05)
(defconstant $$fasl-op-end-of-object    #x06)
(defconstant $$fasl-op-create-table     #x07)
(defconstant $$fasl-op-reference-table-index	#x08)
(defconstant $$fasl-op-store-table-index	#x09)
(defconstant $$fasl-op-symbol		#x0a)
(defconstant $$fasl-op-compiled-function #x0b)
(defconstant $$fasl-op-defun		#x0c)
(defconstant $$fasl-op-defmacro		#x0d)
(defconstant $$fasl-op-defconstant	#x0e)
(defconstant $$fasl-op-defsubst		#x0f)
(defconstant $$fasl-op-defafun		#x10)
(defconstant $$fasl-op-eval		#x11)
(defconstant $$fasl-op-in-package	#x12)
(defconstant $$fasl-op-bignum		#x13)
(defconstant $$fasl-op-short-float	#x14)
(defconstant $$fasl-op-single-float	#x15)
(defconstant $$fasl-op-double-float	#x16)
(defconstant $$fasl-op-defvar		#x17)
(defconstant $$fasl-op-defparameter	#x18)
(defconstant $$fasl-op-unbound		#x19)
(defconstant $$fasl-op-list             #x1A)
(defconstant $$fasl-op-simple-vector    #x1f)
;; Followed by a fixnum size, and then the objects

;; For future expansion
(defconstant $$FASL-OP-ESCAPE #xFF)

(defvar *k-unfasl-input-stream* () "The stream that K-UNFASL uses to get its input")
(defvar *k-unfasl-output-stream* T "The stream that K-UNFASL sends its output to")
(defvar *k-unfasl-eof-marker* '(this-is-the-eof) "EOF marker for K-UNFASL")
(defvar *k-unfasl-for-srccom* ()
  "Set this if you want to produce output that will minimize the trivial differences between kfasl files")

(defun k-unfasl (name &key (output t) (for-srccom ()))
  (unwind-protect
      (let ((*k-unfasl-for-srccom* for-srccom))
	(if (not (eq output t))
	    (setq *k-unfasl-output-stream* (open output :direction :output)))
	(with-open-file (*k-unfasl-input-stream* name :direction ':input :byte-size 8)
	  (do ((opcode (tyi *k-unfasl-input-stream* '(this-is-the-eof))
		       (tyi *k-unfasl-input-stream* '(this-is-the-eof))))
	      ((= opcode 0)
	       (format t "~%All done UNKFASLing"))
	    (cond ((equal opcode '(this-is-the-eof))
		   (error "Got to EOF before reading eof opcode")))
	    (k-unfasl-print-object (k-unfasl-read-object-1 opcode))
	    (k-unfasl-format "~%~%"))))
    (if (not (eq output t))
	(close *k-unfasl-output-stream*))))

(defun k-unfasl-print-object (obj)
  (if (atom obj)
      (k-unfasl-format "~A" obj)
    (let ((opcode (car obj)))
      (cond					
;;;((eq opcode '[EOF]) (li:error "Unexpected EOF in K-UNFASLOAD"))
;;;((eq opcode $$fasl-op-string) (k-unfasl-read-simple-string))
;;;((eq opcode $$fasl-op-fixnum) (k-unfasl-read-fixnum))
;;;((eq opcode $$fasl-op-bignum) (k-unfasl-read-bignum))
;;;((eq opcode $$fasl-op-nil) 'nil)
;;;((eq opcode $$fasl-op-string-character)(k-unfasl-read-string-character))
	((eq opcode '[SYMBOL])
	 (k-unfasl-print-symbol obj))
	((eq opcode '[DEFUN])
	 (k-unfasl-print-defun obj))
	((eq opcode '[DEFAFUN])
	 (k-unfasl-print-defafun obj))
	((eq opcode '[DEFMACRO])
	 (k-unfasl-print-defmacro obj))
	((eq opcode '[DEFSUBST])          
	 (k-unfasl-print-defsubst obj))
	((eq opcode '[COMPILED-FUNCTION]) 
	 (k-unfasl-print-function obj))
	((eq opcode '[CONS]) 
	 (k-unfasl-print-cons obj))
	((eq opcode '[LIST])
	 (k-unfasl-print-list obj))
	((eq opcode '[SHORT-FLOAT])
	 (k-unfasl-print-short-float obj))
	((eq opcode '[SINGLE-FLOAT])
	 (k-unfasl-print-single-float obj))
	((eq opcode '[DOUBLE-FLOAT])
	 (k-unfasl-print-double-float obj))
	((eq opcode '[DEFVAR])
	 (k-unfasl-print-defvar obj))
	((eq opcode '[DEFCONSTANT])
	 (k-unfasl-print-defconstant obj))
	((eq opcode '[DEFPARAMETER])
	 (k-unfasl-print-defparameter obj))
	((eq opcode '[EVAL])
	 (k-unfasl-print-eval obj))
	((eq opcode '[UNBOUND])
	 (k-unfasl-print-unbound obj))
	((eq opcode '[SIMPLE-VECTOR])	
	 (k-unfasl-print-simple-vector obj))
	((listp obj)
	 (k-unfasl-print-lisp-list obj))
	(t (error "K-UNFASL: Don't know how to print ~S" obj))))))

(defun k-unfasl-read-object ()
  (let ((opcode (k-unfasl-read-opcode)))
    (k-unfasl-read-object-1 opcode)))

(defun k-unfasl-read-object-1 (opcode)
  (cond ((= opcode $$fasl-op-end-of-file) (li:error "Unexpected EOF in K-UNFASLOAD"))
	((= opcode $$fasl-op-string)            (k-unfasl-read-simple-string))
	((= opcode $$fasl-op-fixnum)            (k-unfasl-read-fixnum))
	((= opcode $$fasl-op-bignum)            (k-unfasl-read-bignum))
	((= opcode $$fasl-op-symbol)            (k-unfasl-read-symbol))
	((= opcode $$fasl-op-defun)             (k-unfasl-read-defun))
	((= opcode $$fasl-op-defafun)           (k-unfasl-read-defun))
	((= opcode $$fasl-op-defmacro)          (k-unfasl-read-defmacro))
	((= opcode $$fasl-op-defsubst)          (k-unfasl-read-defsubst))
	((= opcode $$fasl-op-compiled-function) (k-unfasl-read-function))
	((= opcode $$fasl-op-cons)              (k-unfasl-read-cons))
	((= opcode $$fasl-op-list)              (k-unfasl-read-list))
	((= opcode $$fasl-op-nil)               'nil)
	((= opcode $$fasl-op-short-float)	(k-unfasl-read-short-float))
	((= opcode $$fasl-op-single-float)	(k-unfasl-read-single-float))
	((= opcode $$fasl-op-double-float)	(k-unfasl-read-double-float))
	((= opcode $$fasl-op-defvar)		(k-unfasl-do-defvar))
	((= opcode $$fasl-op-string-character)	(k-unfasl-read-string-character))
	((= opcode $$fasl-op-defconstant)	(k-unfasl-do-defconstant))
	((= opcode $$fasl-op-defparameter)	(k-unfasl-do-defparameter))
	((= opcode $$fasl-op-eval)		(k-unfasl-fake-eval))
	((= opcode $$fasl-op-unbound)
	 (li:error "K-UNFASL-READ-OBJECT can't cope with FASL-OP-UNBOUND."))
	((= opcode $$fasl-op-simple-vector)	(k-unfasl-read-simple-vector))
	(t (k-unfasl-opcode-dispatch opcode))))

(defun k-unfasl-opcode-dispatch (opcode)
  (li:error "k-unfasl-opcode-dispatch is missing!" opcode))

(defun k-unfasl-end-of-file? ()
  (let ((opcode (k-unfasl-peek-opcode)))
    (if (= opcode $$fasl-op-end-of-file)
	t
	nil)))

(defun k-unfasl-peek-byte ()
  (tyipeek () *k-unfasl-input-stream* *k-unfasl-eof-marker*))

(defun k-unfasl-read-byte ()
  (read-byte *k-unfasl-input-stream* *k-unfasl-eof-marker*))

(defun k-unfasl-read-opcode ()
  (k-unfasl-read-byte))

(defun k-unfasl-peek-opcode ()
  (k-unfasl-peek-byte))

(defun k-unfasl-read-16-bits ()
  (let ((low-bits  (k-unfasl-read-byte))
	(high-bits (k-unfasl-read-byte)))
    (dpb high-bits (byte 8. 8.) low-bits)))

(defun k-unfasl-read-fixnum ()
  (let ((low-bits    (k-unfasl-read-byte))
	(medium-bits (k-unfasl-read-byte))
	(high-bits   (k-unfasl-read-byte)))
    (k-unfasl-make-fixnum low-bits medium-bits high-bits)))

(defun k-unfasl-make-fixnum (low medium high)
  (dpb high (byte 8. 16.)
       (dpb medium (byte 8. 8.)
	    low)))

(defun k-unfasl-read-bignum ()
  (let* ((words-needed (k-unfasl-read-fixnum))
	 (bignum 0))
    (do ((i 1 (1+ i))
	 (num-base 1 (* num-base 8.)))
	((> i (* 4. words-needed)))
      (setq bignum (+ bignum (* num-base (k-unfasl-read-byte)))))
    bignum
    ))

(defun k-unfasl-read-cons ()
  (cons (k-unfasl-read-object) (k-unfasl-read-object)))

;;; avoid recursion when reading lists
(defun k-unfasl-read-list ()
  (let ((length (k-unfasl-read-fixnum)))
    (let ((l '()))
      (let ((tail l))
	(dotimes (i length)
	  (let ((cons (cons (k-unfasl-read-object)
				    nil)))
	    (if tail
	      (rplacd tail cons)
	      (setq l cons))
	    (setq tail cons))))
      l)))
	  
(defun k-unfasl-read-string-character ()
  (int-char (k-unfasl-read-byte)))

(defun k-unfasl-read-simple-string ()
  (let ((length (k-unfasl-read-fixnum)))
    (let ((string (make-string length)))
      (dotimes (i length)
	(setf (aref string i) (k-unfasl-read-string-character)))
      string)))

(defun k-unfasl-read-simple-vector ()
  (let ((length (k-unfasl-read-fixnum)))
    (let ((vector (make-array length)))
      (dotimes (i length)
	(setf (aref vector i) (k-unfasl-read-object)))
      `([SIMPLE-VECTOR] ,vector))))			

(defun k-unfasl-opcode-dispatch (opcode)
  (error "k-unfasl-opcode-dispatch is missing!" opcode))

(defun k-unfasl-read-symbol ()
  `([SYMBOL]
    ,(k-unfasl-read-object)
    ,(k-unfasl-read-object)))

(defun k-unfasl-read-defsubst ()
  `([DEFSUBST]
    ,(k-unfasl-read-object) ;Throw the source away for now (PLIST eventually).
    ,(k-unfasl-read-defun)))

(defun k-unfasl-read-defmacro ()
  (let ((fname  (k-unfasl-read-object))
	(function (k-unfasl-read-object)))
    `([DEFMACRO] ,fname ,function)))

(defun k-unfasl-read-defun ()
  (let ((name     (k-unfasl-read-object))
	(function (k-unfasl-read-object)))
    `([DEFUN] ,name ,function)))

(defun k-unfasl-do-defconstant ()
  (let* ((symbol (k-unfasl-read-object))
	 (value (k-unfasl-read-object))
	 (documentation (k-unfasl-read-someones-value symbol)))
    `([DEFCONSTANT] ,symbol ,value ,documentation))) 

(defun k-unfasl-do-defparameter ()
  (let* ((symbol (k-unfasl-read-object))
	 (value (k-unfasl-read-object))
	 (documentation (k-unfasl-read-someones-value symbol)))
    `([DEFPARAMETER] ,symbol ,value ,documentation)))

(defun k-unfasl-do-defvar ()
  (let ((symbol (k-unfasl-read-object)))
    ;; if the symbol is bound this shouldn't eval (if it's fasl-op-eval)
    (let ((opcode (k-unfasl-peek-opcode))
	  (value (k-unfasl-read-someones-value symbol))
	  (documentation (k-unfasl-read-object)))
      opcode
      `([DEFVAR] ,symbol ,value ,documentation))))

(defun k-unfasl-read-someones-value (someone)
  someone
  (let ((opcode (k-unfasl-read-opcode)))
    (cond ((= opcode $$fasl-op-unbound)
	   "<UNBOUND WHEN LOADED>")
	  (t (k-unfasl-read-object-1 opcode)))))

(defun k-unfasl-fake-eval ()
  `([EVAL] ,(k-unfasl-read-object)))

(defun k-unfasl-read-function ()
  (let* ((name         (k-unfasl-read-object))
	 (local-refs   (k-unfasl-read-local-refs))
	 (refs         (k-unfasl-read-refs))
	 (entry-points (k-unfasl-read-entry-points))
	 (length       (k-unfasl-read-fixnum))
	 (byte-len (* 8 length)))
    (let ((code-vec (make-array byte-len)))
      (do ((i 0 (1+ i)))
	  ((>= i byte-len))
	(setf (aref code-vec i) (k-unfasl-read-byte)))
      `([COMPILED-FUNCTION] ,name ,local-refs ,refs ,entry-points ([FUNCTION-CODE] ,code-vec) ,(k-unfasl-read-immediates)))))

(defun k-unfasl-read-entry-points ()
  (let* ((n (k-unfasl-read-fixnum))
	 (len (+ n n))
	 (entries '([ENTRIES])))
      (do ((i 0 (+ i 2)))
	  ((>= i len))
	(setq entries `(,@entries 
			([#ARGS] ,(k-unfasl-read-fixnum)    ;number of args
			 [OFFSET] ,(k-unfasl-read-fixnum)))))   ;entry point offset
      entries))

(defun k-unfasl-read-immediates ()
  (let ((list '([IMMEDIATES])))
    (dotimes (i (k-unfasl-read-fixnum))
      (setq list `(,@list
		   (,(k-unfasl-read-fixnum)
		    ,(k-unfasl-read-object)))))
    list))

(defun k-unfasl-read-local-refs ()
  (let* ((n (k-unfasl-read-fixnum))
	 (len (+ n n))
	 (refs '([LOCAL-REFS])))
      (do ((i 0 (+ i 2)))
	  ((>= i len))
	(setq refs `(,@refs
		     (,(k-unfasl-read-fixnum)
		      ,(k-unfasl-read-fixnum)))))
      refs))

(defun k-unfasl-read-refs ()
  (let* ((n (k-unfasl-read-fixnum))
	 (len (+ n n n))
	 (refs '([REFS])))
      (do ((i 0 (+ i 3)))
	  ((>= i len))
	(setq refs `(,@refs ([OFFSET] ,(k-unfasl-read-fixnum)
			     [FUNCTION] ,(k-unfasl-read-object)
			     [#ARGS] ,(k-unfasl-read-fixnum)))))
      refs))

(defun k-unfasl-read-short-float ()
  `([SHORT-FLOAT] 
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)))

(defun k-unfasl-read-single-float ()
  `([SINGLE-FLOAT] 
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)))

(defun k-unfasl-read-DOUBLE-float ()
  `([DOUBLE-FLOAT] 
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)
    ,(k-unfasl-read-byte)))

(defun k-unfasl-format (fmt-string &rest args)
  (apply #'format *k-unfasl-output-stream* fmt-string args))

(defun k-unfasl-print-symbol (obj)
  (k-unfasl-format "~&~A::~A" (caddr obj) (cadr obj)))

(defun k-unfasl-print-defun (obj)
  (k-unfasl-print-defun-1 obj 'defun))

(defun k-unfasl-print-defafun (obj)
  (k-unfasl-print-defun-1 obj 'defafun))

(defun k-unfasl-print-defmacro (obj)
  (k-unfasl-print-defun-1 obj 'defmacro))

(defun k-unfasl-print-defsubst (obj)
;  (k-unfasl-format "~&DEFSUBST NAME: ~&")
;  (k-unfasl-print-object (car obj))
;  (k-unfasl-format "~&DEFSUBST SOURCE: ~&")
;  (k-unfasl-print-object (cadr obj))
  (k-unfasl-print-defun-1 (caddr obj) 'defsubst))

(defun k-unfasl-print-defun-1 (obj type)
  (k-unfasl-format "~&(~A " type)
  (k-unfasl-print-object (cadr obj))
  (k-unfasl-format "~&")
  (k-unfasl-print-function (caddr obj))
  (k-unfasl-format ")" type))

(defun k-unfasl-print-function (obj)
  (k-unfasl-format "~&COMPILED FUNCTION INFO:~&")
  (k-unfasl-format "~&NAME: ") (k-unfasl-print-object (cadr obj))
  (loop for elt in (cddr obj)
	do (k-unfasl-print-function-element elt)))

(defun k-unfasl-print-function-element (elt)
  (progn (k-unfasl-format "~&~A:" (car elt))
	 (if (and *k-unfasl-for-srccom*
		  (eq (car elt) '[FUNCTION-CODE]))
	     (k-unfasl-format "~&[A-Code-Object]")
	   (loop for thing in (cdr elt)
		 do (progn (k-unfasl-format "~&")
			   (k-unfasl-print-object thing))))))

(defun k-unfasl-print-cons (obj)
  (k-unfasl-format "(")
  (k-unfasl-print-object (cadr obj))
  (k-unfasl-format " ")
  (k-unfasl-print-object (caddr obj))
  (k-unfasl-format ")"))

(defun k-unfasl-print-list (obj)
  (k-unfasl-format "(")
  (do ((elt (cdr obj) (cdr elt)))
      ((null (cdr elt))
       (k-unfasl-print-object (car elt)))
    (k-unfasl-format " ")
    (k-unfasl-print-object (car elt)))
  (k-unfasl-format ")"))

(defun k-unfasl-print-short-float (obj)
  (k-unfasl-format "~A" obj))

(defun k-unfasl-print-single-float (obj)
    (k-unfasl-format "~A" obj))

(defun k-unfasl-print-double-float (obj)
  (k-unfasl-format "~A" obj))

(defun k-unfasl-print-defvar (obj)
  (k-unfasl-print-defvar-1 obj 'defvar))

(defun k-unfasl-print-defconstant (obj)
    (k-unfasl-print-defvar-1 obj 'defconstant))

(defun k-unfasl-print-defparameter (obj)
  (k-unfasl-print-defvar-1 obj 'defparameter))

(defun k-unfasl-print-defvar-1 (obj type)
  (k-unfasl-format "(~A" type)
  (do ((elt (cdr obj) (cdr elt)))
      ((null (cdr elt)) ())
    (k-unfasl-format " ")
    (k-unfasl-print-object (car elt)))
  (k-unfasl-format ")"))

(defun k-unfasl-print-eval (obj)
  (k-unfasl-format "~&(eval (")
  (do ((elt (cadr obj) (cdr elt)))
      ((null (cdr elt))
       (k-unfasl-print-object (car elt)))
    (k-unfasl-print-object (car elt))
    (k-unfasl-format " "))
  (k-unfasl-format "))"))

(defun k-unfasl-print-unbound (obj)		
  (k-unfasl-format "~A" obj))

(defun k-unfasl-print-simple-vector (obj)
  (k-unfasl-format "~A" obj))

(defun k-unfasl-print-lisp-list (obj)
  (k-unfasl-format "(")
  (do ((elt obj (cdr elt)))
      ((null (cdr elt))
       (k-unfasl-print-object (car elt))
       (k-unfasl-format ")"))
    (k-unfasl-print-object (car elt))
    (k-unfasl-format " ")))