;;;  -*- Mode:Common-Lisp; Package:COMPILER; Base:8; Patch-file: T -*-


;;; Given an s-exp, dump a group to cons up that s-exp and return it.

;;; This is the main function of FASD.  It takes a Lisp object and
;;; dumps it.  The second (optional) arg is a FASL-OP to use on
;;; any lists in the structure.  It returns the IDX of the object.

;;;  8/28/86 JK - Add support for dumping IEEE floating point numbers.
;;; 10/17/86 JK - Change FASD-CONSTANT to use %DATA-TYPE, which compiles to a DISPATCH
;;;               instruction under version 10 of the VM2 compiler.
;;; 10/18/86 DNG- Give meaningful message when flavor instance can't be dumped.
;;; 12/05/87 DNG- Fix dumping of package objects. [SPR 6159]
(DEFUN FASD-CONSTANT (S-EXP &OPTIONAL (LIST-OP #+Elroy
					       FASL-OP-VM2-LIST
					       #-Elroy
					       FASL-OP-LIST))	
  (PROG (TEM)
	(AND FASD-NEW-SYMBOL-FUNCTION		        ;For FASD-SYMBOLS-PROPERTIES, make sure we examine all 
	     (= (%data-type s-exp) dtp-symbol)	        ;symbols in the data that we dump.
	     (FUNCALL FASD-NEW-SYMBOL-FUNCTION S-EXP))
	(when (SETQ TEM (FASD-TABLE-LOOKUP S-EXP))	        ;If this object already dumped,
	  (COND ((>= TEM (LSH 1 20))
		 (FASD-START-GROUP NIL 2 FASL-OP-LARGE-INDEX)
		 (FASD-NIBBLE (LDB (BYTE 10 20) TEM))
		 (FASD-NIBBLE (LDB (BYTE 20 0) TEM)))
		(T
		 (FASD-START-GROUP NIL 1 FASL-OP-INDEX)	        ;Just reference it in the FASL-TABLE.
		 (FASD-NIBBLE TEM)))
	  (RETURN TEM))
	(select (%data-type s-exp)
	  (dtp-fix (FASD-FIXED S-EXP))
	  (dtp-character (FASD-CHARACTER S-EXP))
	  (dtp-symbol (FASD-SYMBOL S-EXP))
	  (si:dtp-array (if (stringp s-exp)
			    (RETURN (FASD-STRING S-EXP))
			  (if (packagep s-exp)
			      (FASD-EVAL-CONSTRUCT-CONSTANT `(pkg-find-package ,(package-name s-exp)))
			    (RETURN (FASD-ARRAY S-EXP)))))
	  (#+Elroy si:dtp-function #-Elroy dtp-fef-pointer (FASD-FEF S-EXP))	;remove SI prefix when we compile natively -JK
	  #+Elroy
	  (si:dtp-short-float (FASD-IEEE-SHORT-FLOAT S-EXP))
	  #+Elroy
	  (dtp-single-float (FASD-IEEE-SINGLE-FLOAT S-EXP))	;Modify current float data-types for VM2
	  (dtp-extended-number (cond
				 #+Elroy
				 ((TYPEP S-EXP 'DOUBLE-FLOAT)
				  (FASD-IEEE-DOUBLE-FLOAT S-EXP))	;Add new double-float data-type for VM2
				 ((integerp s-exp)
				  (FASD-FIXED S-EXP))
				 ((RATIONALP S-EXP)
				  (RETURN (FASD-RATIONAL S-EXP)))
				 ((COMPLEXP S-EXP)
				  (RETURN (FASD-COMPLEX S-EXP)))))
	  #-Elroy
	  (dtp-small-flonum (FASD-SMALL-FLOAT S-EXP))
	  #-Elroy
	  (dtp-single-float (FASD-FLOAT S-EXP))
	  (#+Elroy si:dtp-function #-Elroy dtp-fef-pointer (FASD-FEF S-EXP))
	  (dtp-list (RETURN (FASD-LIST S-EXP LIST-OP)))
	  (dtp-instance (FASD-EVAL-CONSTRUCT-CONSTANT
			  (OR (SEND S-EXP :SEND-IF-HANDLES :FASD-FORM)
			      (AND (SEND S-EXP :OPERATION-HANDLED-P :RECONSTRUCTION-INIT-PLIST)
				   `(APPLY #'MAKE-INSTANCE
					   '(,(TYPE-OF S-EXP) . ,(SEND S-EXP :RECONSTRUCTION-INIT-PLIST))))
			      (FERROR NIL "Can't dump instance ~S to object file because it doesn't have
 a :FASD-FORM or :RECONSTRUCTION-INIT-PLIST method." S-EXP)
			      )))
	  (otherwise (FERROR NIL "~S is a ~S, which is not a valid data-type for FASD-CONSTANT"
			 S-EXP (TYPE-OF S-EXP))))
	(RETURN (FASD-TABLE-ADD S-EXP))))