;;; -*- Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Loader for Spice Lisp.
;;; Written by Skef Wholey.
;;;

(defvar *load-verbose* ()
  "The default for the :Verbose argument to Load.")

(defvar *load-set-default-pathname*  t
  "The default for the :Set-Default-Pathname argument to Load.")

(defvar *load-pathname-defaults* ()
  "The pathname-defaults pathname for Load and Compile-File.")

(defvar *load-print-stuff* ()
  "True if we're gonna mumble about what we're loading.")

;;; From the package system:

(declare (special *symbol-allocation-space*))

;;; Macros, variables, and functions to manipulate the table and stack:

(defvar *free-fop-tables* ()
  "List of free fop tables for the fasloader.")

(defvar *current-fop-table* ()
  "The current fop table.")

(defvar *current-fop-table-size* ()
  "The length of the current fop table.")

(defvar *current-fop-table-index* ()
  "The current fop table index.")

(defmacro push-table (thing)
  `(prog1 (setf (svref *current-fop-table* *current-fop-table-index*) ,thing)
	  (incf *current-fop-table-index*)
	  (when (= *current-fop-table-index* *current-fop-table-size*)
	    (setq *current-fop-table*
		  (replace (make-vector (setq *current-fop-table-size*
					      (* *current-fop-table-size* 2)))
			   *current-fop-table*)))))

(defvar *fop-stack* ()
  "The fop stack (we only need one!).")

(defvar *fop-stack-index* ()
  "The index into the fop stack.")

(defvar *fop-stack-index-on-entry* ()
  "The current index into the fop stack when we last recursively entered LOAD.")

(defvar *fop-stack-size* ()
  "The size of the fop stack.")

(defmacro push-stack (thing)
  `(let ((thing-foo ,thing))
     (setf (svref *fop-stack* *fop-stack-index*) thing-foo)
     (incf *fop-stack-index*)
     (when (= *fop-stack-index* *fop-stack-size*)
       (setq *fop-stack*
	     (replace (make-vector
		       (setq *fop-stack-size* (* *fop-stack-size* 2)))
		      *fop-stack*)))
     thing-foo))

(defmacro pop-stack ()
  `(progn (decf *fop-stack-index*)
	  (svref *fop-stack* *fop-stack-index*)))

(defmacro top-stack ()
  `(svref *fop-stack* (1- *fop-stack-index*)))

;;; FOP database:

(defvar fop-codes ()
  "Vector indexed by a FaslOP that yields the FOP's name.")

;;; The number of arguments to a FaslOP is minus the number of bytes that
;;; follow the FaslOP if that number is negative, or the number of bytes
;;; to construct an integer out of if it is positive.

(defvar fop-arglengths ()
  "Vector indexed by a FaslOP that yields the number of bytes of arguments.")

(defvar fop-functions ()
  "Vector indexed by a FaslOP that yields a function of 0 arguments which
  will perform the operation.")

;;; Something to help define FOP-Functions:

(defmacro fop-fun (&rest forms)
  `#'(lambda () ,@forms))

(defun define-fop (op name arglen function)
  (declare (fixnum op))
  "Stores information about the given Op on its name's property list,
  the FOP-Codes vector, and the FOP-Arglengths vector.  Code to perform
  the Op (Function) is stored in FOP-Functions."
  (setf (svref fop-codes op) name)
  (setf (get name 'fop-code) op)
  (setf (svref fop-arglengths op) arglen)
  (setf (svref fop-functions op) function))

(declare (special *package*))

(declare (special current-space current-code-format fop-file load-operand))

;;; Init procedure for the tables:

(defun fasload-init ()
  "Init function for the fasloader."
  (setq fop-codes (make-vector 256))
  (setq fop-arglengths (make-vector 256))
  (setq fop-functions (make-vector 256))
  (setq *free-fop-tables* (list (make-vector 1000)))
  (setq *fop-stack* (make-vector 100))
  (setq *fop-stack-size* 100)
  (setq *fop-stack-index* 0)
  (define-fop 0 'fop-nop 0
    (fop-fun))
  (define-fop 1 'fop-pop 0
    (fop-fun (push-table (pop-stack))))
  (define-fop 2 'fop-push 4
    (fop-fun (push-stack (svref *current-fop-table* load-operand))))
  (define-fop 3 'fop-byte-push 1
    (fop-fun (push-stack (svref *current-fop-table* load-operand))))
  (define-fop 4 'fop-empty-list 0
    (fop-fun (push-stack ())))
  (define-fop 5 'fop-truth 0
    (fop-fun (push-stack t)))
  (define-fop 6 'fop-symbol-save 4
    (fop-fun (push-stack (load-symbol *package*))
	     (push-table (top-stack))))
  (define-fop 7 'fop-small-symbol-save 1
    (fop-fun (push-stack (load-symbol *package*))
	     (push-table (top-stack))))
  (define-fop 8 'fop-symbol-in-package-save 4
    (fop-fun (push-stack (load-symbol
			  (prog1 (svref *current-fop-table* load-operand)
				 (setq load-operand (load-u-integer 4)))))
	     (push-table (top-stack))))
  (define-fop 9 'fop-small-symbol-in-package-save 4
    (fop-fun (push-stack (load-symbol
			  (prog1 (svref *current-fop-table* load-operand)
				 (setq load-operand (load-u-integer 1)))))
	     (push-table (top-stack))))
  (define-fop 10 'fop-symbol-in-byte-package-save 1
    (fop-fun (push-stack (load-symbol
			  (prog1 (svref *current-fop-table* load-operand)
				 (setq load-operand (load-u-integer 4)))))
	     (push-table (top-stack))))
  (define-fop 11 'fop-small-symbol-in-byte-package-save 1
    (fop-fun (push-stack (load-symbol
			  (prog1 (svref *current-fop-table* load-operand)
				 (setq load-operand (load-u-integer 1)))))
	     (push-table (top-stack))))
  (define-fop 12 'fop-uninterned-symbol-save 4
    (fop-fun (push-stack (load-uninterned-symbol))
	     (push-table (top-stack))))
  (define-fop 13 'fop-uninterned-small-symbol-save 1
    (fop-fun (push-stack (load-uninterned-symbol))
	     (push-table (top-stack))))
  (define-fop 14 'fop-package 0
    (fop-fun (push-stack (find-package (pop-stack)))))
  (define-fop 15 'fop-list 1
    (fop-fun (push-stack (make-stack-list load-operand ()))))
  (define-fop 16 'fop-list* 1
    (fop-fun (push-stack (make-stack-list load-operand (pop-stack)))))
  (define-fop 17 'fop-list-1 0
    (fop-fun (push-stack (make-stack-list 1 ()))))
  (define-fop 18 'fop-list-2 0
    (fop-fun (push-stack (make-stack-list 2 ()))))
  (define-fop 19 'fop-list-3 0
    (fop-fun (push-stack (make-stack-list 3 ()))))
  (define-fop 20 'fop-list-4 0
    (fop-fun (push-stack (make-stack-list 4 ()))))
  (define-fop 21 'fop-list-5 0
    (fop-fun (push-stack (make-stack-list 5 ()))))
  (define-fop 22 'fop-list-6 0
    (fop-fun (push-stack (make-stack-list 6 ()))))
  (define-fop 23 'fop-list-7 0
    (fop-fun (push-stack (make-stack-list 7 ()))))
  (define-fop 24 'fop-list-8 0
    (fop-fun (push-stack (make-stack-list 8 ()))))
  (define-fop 25 'fop-list*-1 0
    (fop-fun (push-stack (make-stack-list 1 (pop-stack)))))
  (define-fop 26 'fop-list*-2 0
    (fop-fun (push-stack (make-stack-list 2 (pop-stack)))))
  (define-fop 27 'fop-list*-3 0
    (fop-fun (push-stack (make-stack-list 3 (pop-stack)))))
  (define-fop 28 'fop-list*-4 0
    (fop-fun (push-stack (make-stack-list 4 (pop-stack)))))
  (define-fop 29 'fop-list*-5 0
    (fop-fun (push-stack (make-stack-list 5 (pop-stack)))))
  (define-fop 30 'fop-list*-6 0
    (fop-fun (push-stack (make-stack-list 6 (pop-stack)))))
  (define-fop 31 'fop-list*-7 0
    (fop-fun (push-stack (make-stack-list 7 (pop-stack)))))
  (define-fop 32 'fop-list*-8 0
    (fop-fun (push-stack (make-stack-list 8 (pop-stack)))))
  (define-fop 33 'fop-integer 4
    (fop-fun (push-stack (load-s-integer load-operand))))
  (define-fop 34 'fop-small-integer 1
    (fop-fun (push-stack (load-s-integer load-operand))))
  (define-fop 35 'fop-word-integer 0
    (fop-fun (push-stack (load-s-integer 4))))
  (define-fop 36 'fop-byte-integer 0
    (fop-fun (push-stack (load-s-integer 1))))
  (define-fop 37 'fop-string 4
    (fop-fun (push-stack (load-string))))
  (define-fop 38 'fop-small-string 1
    (fop-fun (push-stack (load-string))))
  (define-fop 39 'fop-vector 4
    (fop-fun (push-stack (make-stack-vector))))
  (define-fop 40 'fop-small-vector 1
    (fop-fun (push-stack (make-stack-vector))))
  (define-fop 41 'fop-uniform-vector 4
    (fop-fun (push-stack (make-stack-uniform-vector))))
  (define-fop 42 'fop-small-uniform-vector 1
    (fop-fun (push-stack (make-stack-uniform-vector))))
  (define-fop 43 'fop-int-vector 4
    (fop-fun (push-stack (make-stack-int-vector))))
  (define-fop 44 'fop-uniform-int-vector 4
    (fop-fun (push-stack (make-stack-uniform-int-vector))))
  (define-fop 45 'fop-float 0
    (fop-fun (push-stack (load-float))))
  (define-fop 52 'fop-alter 1
    (fop-fun (alter-item load-operand (pop-stack) (pop-stack))))
  (define-fop 53 'fop-eval 0
    (fop-fun
     (let ((result (eval (pop-stack))))
       (if *load-print-stuff* (print result))
       (push-stack result))))
  (define-fop 54 'fop-eval-for-effect 0
    (fop-fun
     (if *load-print-stuff*
	 (print (eval (pop-stack)))
	 (eval (pop-stack)))))
  (define-fop 55 'fop-funcall 1
    (fop-fun (let ((args (make-stack-list load-operand ())))
	       (push-stack (apply (pop-stack) args)))))
  (define-fop 56 'fop-funcall-for-effect 1
    (fop-fun (let ((args (make-stack-list load-operand ())))
	       (apply (pop-stack) args))))
  (define-fop 57 'fop-code-format 1
    (fop-fun (setq current-code-format load-operand)))
  (define-fop 58 'fop-code 4
    (fop-fun (if (= current-code-format %fasl-code-format)
		 (push-stack (load-function load-operand (load-u-integer 4)))
		 (error "~S: Bad code format for this implementation"
			 current-code-format))))
  (define-fop 59 'fop-small-code 1
    (fop-fun (if (eql current-code-format %fasl-code-format)
		 (push-stack (load-function load-operand (load-u-integer 2)))
		 (error "~S: Bad code format for this implementation"
			 current-code-format))))
  (define-fop 60 'fop-static-heap 0
    (fop-fun (setq current-space static-space)))
  (define-fop 61 'fop-dynamic-heap 0
    (fop-fun (setq current-space dynamic-space)))
  (define-fop 62 'fop-verify-table-size 4
    (fop-fun (if (/= *current-fop-table-index* load-operand)
		 (error "~S: Fasl table of improper size.  Bug!"))))
  (define-fop 63 'fop-verify-empty-stack 0
    (fop-fun (if (/= *fop-stack-index* *fop-stack-index-on-entry*)
		 (error "Fasl stack not empty.  Bug!"))))
  (define-fop 64 'fop-end-group 0
    (fop-fun))
  (define-fop 65 'fop-pop-for-effect 0
    (fop-fun (pop-stack)))
  (define-fop 66 'fop-misc-trap 0
    (fop-fun (push-stack (%sp-make-immediate-type 0 0))))
  (define-fop 67 'fop-read-only-heap 0
    (fop-fun (setq current-space read-only-space)))
  (define-fop 68 'fop-character 3
    (fop-fun (push-stack (int-char load-operand))))
  (define-fop 69 'fop-short-character 1
    (fop-fun (push-stack (int-char load-operand))))
  (define-fop 70 'fop-ratio 0
    (fop-fun (push-stack
	      (let ((den (pop-stack)))
		(%primitive make-ratio (pop-stack) den)))))
  (define-fop 71 'fop-complex 0
    (fop-fun (error "Complex numbers not supported in this implementation.")))
  (define-fop 72 'fop-some-vax-foo 0
    (fop-fun (error "This FOP makes no sense on a Perq!")))
  (define-fop 73 'fop-some-vax-foo 0
    (fop-fun (error "This FOP makes no sense on a Perq!")))
  (define-fop 74 'fop-fset 0
    (fop-fun (let ((function (pop-stack)))
	       (setf (symbol-function (pop-stack)) function))))
  (define-fop 75 'fop-lisp-symbol-save 4
    (fop-fun (push-stack (load-symbol *lisp-package*))
	     (push-table (top-stack))))
  (define-fop 76 'fop-lisp-small-symbol-save 1
    (fop-fun (push-stack (load-symbol *lisp-package*))
	     (push-table (top-stack))))
  (define-fop 77 'fop-keyword-symbol-save 4
    (fop-fun (push-stack (load-symbol *keyword-package*))
	     (push-table (top-stack))))
  (define-fop 78 'fop-keyword-small-symbol-save 1
    (fop-fun (push-stack (load-symbol *keyword-package*))
	     (push-table (top-stack))))
  (do ((index 79 (1+ index)))
      ((= index 255))
    (define-fop index 'losing-fop 0
      `(lambda () (error "~S: Losing FaslOP!" ,index))))
  (define-fop 255 'fop-end-header 0
    (fop-fun)))

;;; Fasload:

(defun fasload (stream)
  (let* ((fop-file stream)
	 (*current-fop-table* (pop *free-fop-tables*))
	 (*current-fop-table-size*)
	 (*current-fop-table-index* 0)
	 (*fop-stack-index-on-entry* *fop-stack-index*))
    (if (null *current-fop-table*)
	(setq *current-fop-table* (make-vector 1000)))
    (setq *current-fop-table-size*
	  (length (the simple-vector *current-fop-table*)))
    (do ((loaded-group (load-group stream) (load-group stream)))
	((not loaded-group)))
    (push *current-fop-table* *free-fop-tables*))
  t)

;;; Load-Group returns t if it successfully loads a group from the file,
;;; or () if EOF was encountered while trying to read from the file.

(defun load-group (file)
  (when (check-header file)
    (do* ((byte (read-byte file) (read-byte file))
	  (fop (svref fop-codes byte) (svref fop-codes byte))
	  (arglen (svref fop-arglengths byte) (svref fop-arglengths byte))
	  (load-operand arglen)
	  (current-space dynamic-space)
	  (current-code-format 'uninitialized-code-format))
	 ((eq fop 'fop-end-group) t)
      (declare (fixnum byte arglen))
      (if (> arglen 0)
	  (setq load-operand (load-u-integer arglen))
	  (setq load-operand (- load-operand)))
      (funcall (svref fop-functions byte)))))

;;; Check-Header returns t if t succesfully read a header from the file,
;;; or () if EOF was hit before anything was read.  An error is signaled
;;; if garbage is encountered.

(defun check-header (file)
  (let ((byte (read-byte file NIL '*eof*)))
    (cond ((eq byte '*eof*) ())
	  ((eq byte (char-int #\F))
	   (do ((byte (read-byte file) (read-byte file))
		(count 1 (1+ count)))
	       ((= byte 255) t)
	     (declare (fixnum byte))
	     (if (and (< count 9)
		      (not (eq byte (char-int (schar "FASL FILE" count)))))
		 (error "Bad FASL file format."))))
	  (t (error "Bad FASL file format.")))))

;;; Load-U-Integer loads an unsigned integer N bytes long from the File.

(defun load-u-integer (length)
  (declare (fixnum length))
  (case length					; be fast for 1 & 4
    (1 (read-byte fop-file))
    (4 (+ (read-byte fop-file) (ash (read-byte fop-file) 8)
	  (ash (read-byte fop-file) 16) (ash (read-byte fop-file) 24)))
    (t
     (do ((index length (1- index))
	  (result 0 (+ result (ash (read-byte fop-file) bits)))
	  (bits 0 (+ bits 8)))
	 ((= index 0) result)
       (declare (fixnum index))
       (declare (integer result bits))))))

;;; Load-S-Integer loads a signed integer Length bytes long from the File.

(defun load-s-integer (length)
  (declare (fixnum length))
  (do* ((index length (1- index))
	(byte 0 (read-byte fop-file))
	(result 0 (+ result (ash byte bits)))
	(bits 0 (+ bits 8)))
       ((= index 0)
	(if (logbitp 7 byte)	; look at sign bit
	    (- result (ash 1 bits))
	    result))
    (declare (fixnum index byte bits))
    (declare (integer result))))

;;; Load-Symbol loads a symbol N characters long from the File and interns
;;; that symbol in the given Package.

(defun load-symbol (package)
  (let ((pname))
    (%primitive set-allocation-space 2)
    (setq pname (make-string load-operand))
    (%primitive set-allocation-space 0)
    (read-n-bytes fop-file pname 0 load-operand)
    (intern pname package)))

;;; Load-Uninterned-Symbol loads a symbol N characters long from the File
;;; and creates an uninterned symbol with that name.

(defun load-uninterned-symbol ()
  (let ((pname))
    (%primitive set-allocation-space 2)
    (setq pname (make-string load-operand))
    (%primitive set-allocation-space 0)
    (read-n-bytes fop-file pname 0 load-operand)
    (prog2
     (%primitive set-allocation-space 2)
     (make-symbol pname)
     (%primitive set-allocation-space 0))))

;;; Load-String loads a string.

(defun load-string ()
  (let ((string (make-string load-operand)))
    (read-n-bytes fop-file string 0 load-operand)
    string))

;;; Make-Stack-List makes a list of the top Length things on the Fop-Stack.
;;; The last cdr of the list is set to Last.

(defun make-stack-list (length last)
  (declare (fixnum length))
  (do* ((index length (1- index))
	(result last (cons (pop-stack) result)))
       ((= index 0) result)
    (declare (fixnum index))))

;;; Make-Stack-Vector makes a vector of the top Load-operand things on the
;;; Fop-Stack.

(defun make-stack-vector ()
  (do ((index (1- load-operand) (1- index))
       (result (make-vector load-operand)))
      ((< index 0) result)
    (declare (fixnum index))
    (declare (simple-vector result))
    (setf (aref result index) (pop-stack))))

;;; Make-Stack-Uniform-Vector fills a vector N long with the top of the
;;; Fop-Stack.

(defun make-stack-uniform-vector ()
  (make-array load-operand :initial-value (pop-stack)))

;;; Make-Stack-Int-Vector is hairy...@@@@

(defun make-stack-int-vector ()
  ())

;;; Make-Stack-Uniform-Int-Vector is less hairy...@@@@

(defun make-stack-uniform-int-vector ()
  ())


;;; Load-Float loads a float from the file.

(defun load-float ()
  (let* ((n (read-byte fop-file))
	 (exponent (load-s-integer (ceiling n 8.)))
	 (m (read-byte fop-file))
	 (mantissa (load-s-integer (ceiling m 8.)))
	 (number (if (or (> n 8.) (> m 32.))
		     (coerce mantissa 'long-float)
		     (coerce mantissa 'short-float))))
    (multiple-value-bind (f e s) (decode-float number)
      e						; ignored
      (* s (scale-float f exponent)))))

;;; Alter-Item changes the Indexth slot of the Object to Newval.

(defun alter-item (index newval object)
  (declare (fixnum index))
  (typecase object
    (list (case index
	    (0 (rplaca object newval))
	    (1 (rplacd object newval))
	    (t (error "~S: Bad index for FaslOP Alter.  Bug!"))))
    (symbol (case index
	      (0 (set object newval))
	      (1 (fset object newval))
	      (2 (%sp-set-plist object newval))
	      (t (error "~S: Bad index for FaslOP Alter.  Bug!"))))
    (array (setf (aref object index) newval))
    (t (error "~S: Bad object for FaslOP Alter.  Bug!"))))

;;; Load-Function loads a function object.  Box-Num objects are popped off the
;;; stack for the boxed storage section, then code-length bytes of code are
;;; read in.

(defun load-function (box-num code-length)
  (declare (fixnum box-num code-length))
  (let ((function (%sp-alloc-function box-num)))
    (do ((index (1- box-num) (1- index)))	; symbol/constant area
	((= index 4))
      (declare (fixnum index))
      (%primitive header-set function index (pop-stack)))
    (%primitive header-set function 4 (pop-stack)) ; argument name vectors
    (%primitive header-set function 3 (pop-stack)) ; name of the function
    (%primitive header-set function 2 (pop-stack)) ; fixnum with arg info
    (%primitive header-set function 1 (pop-stack)) ; place holder (misc-op)
    (%primitive header-set function 0 (pop-stack)) ; fixnum with arg info
    (let ((code (%sp-alloc-u-vector code-length 3)))
      (read-n-bytes fop-file code 0 code-length)
      (%primitive header-set function 1 code))
    (if *load-print-stuff* (print function))
    function))

;;; Sloload:

;;; Something not EQ to anything read from a file:

(defconstant load-eof-value '(()))

;;; Sloload loads a text file into the given Load-Package.

(defun sloload (stream)
  (do ((sexpr (read stream nil load-eof-value)
	      (read stream nil load-eof-value)))
      ((eq sexpr load-eof-value))
	(if *load-print-stuff*
	    (print (eval sexpr))
	    (eval sexpr))))))

;;; Load:

(defun load (filename &rest keywords)
  "Loads the file named by Filename into the Lisp environment.  See manual
   for details."
  (with-keywords keywords
      ((:verbose verbose *load-verbose*)
       (:print *load-print-stuff* ())
       (:if-does-not-exist if-does-not-exist :error))
    (let ((fasl? ())
	  (stream)
	  (*package* *package*))
      (if (streamp filename)
	  (setq fasl? (equal (stream-element-type stream) '(unsigned-byte 8))
		stream filename)
	  (let ((pathname (pathname filename)))
	    (setq fasl? (string-equal (pathname-type pathname) "SFASL"))
	    (setq stream
		  (open pathname
			:direction :input
			:element-type (if fasl? '(unsigned-byte 8)
					        'string-char)
			:if-does-not-exist if-does-not-exist))))
      (cond (stream
	     (if verbose (format t "Loading stuff from ~A.~%" stream))
	     (unwind-protect
	       (if fasl? (fasload stream) (sloload stream))
	       (close stream))
	     t)
	    (t nil)))))