#| -*- Mode:LISP; Package:COMPILER; Base:10; Fonts:(CPTFONTB) -*-

  Copyright LISP Machine, Inc. 1985
   See filename "Copyright.Text" for
  licensing and release information.

  This is how one might want to store lisp forms in an array for later
  putting in some database.

Example use:

(SETQ A (MAKE-ARRAY-FOR-DUMPING-EXAMPLE 100))

(DUMP-FORMS-TO-ARRAY A '((print "what a hack")))

(FASLOAD-FROM-ARRAY A)

|#

(DEFUN MAKE-STREAM-TO-ARRAY (ARRAY &AUX STREAM)
  (SETQ STREAM #'(LAMBDA (OP &OPTIONAL ARG1 &REST ARGS)
		   (SI:SELECTQ-WITH-WHICH-OPERATIONS OP
		     (:TYO
		       (VECTOR-PUSH-EXTEND ARG1 ARRAY))
		     (:STRING-OUT
		       (DO ((J (OR (CAR ARGS) 0) (1+ J))
			    (END (OR (CADR ARGS) (LENGTH ARG1))))
			   ((= J END))
			 (VECTOR-PUSH-EXTEND (AREF ARG1 J) ARRAY)))
		     (T
		       (STREAM-DEFAULT-HANDLER STREAM OP ARG1 ARGS))))))


(DEFUN MAKE-STREAM-FROM-ARRAY (ARRAY &AUX STREAM (INDEX 0) PLIST)
    (SETQ STREAM #'(LAMBDA (OP &OPTIONAL ARG1 &REST ARGS)
		   (SI:SELECTQ-WITH-WHICH-OPERATIONS OP
		     (:TYI
		       (IF (= INDEX (LENGTH ARRAY))
			   NIL
			 (AREF ARRAY (PROG1 INDEX (INCF INDEX)))))
		     (:UNTYI
		       (DECF INDEX))
		     (:GENERIC-PATHNAME
		       #'(LAMBDA (OP &REST ARGS)
			   (SI:SELECTQ-WITH-WHICH-OPERATIONS OP
			     (:PUTPROP
			       (SETF (GETF PLIST (CADR ARGS)) (CAR ARGS)))
			     (:PLIST
			       PLIST)
			     (:REMPROP
			       (REMF PLIST (CAR ARGS)))
			     (:GET
			       (GETF PLIST (CAR ARGS))))))
		     (:INFO NIL)
		     (:PATHNAME "an array")
		     (T
		       (STREAM-DEFAULT-HANDLER STREAM OP ARG1 ARGS))))))

(DEFUN DUMP-FORMS-TO-ARRAY (ARRAY FORMS-LIST &OPTIONAL ATTRIBUTE-LIST)
  (LET ((FASD-STREAM (MAKE-STREAM-TO-ARRAY ARRAY)))
    (LET ((FASD-PACKAGE NIL))			;in case fasd-attributes-list bashes it
      (LOCKING-RESOURCES
	(FASD-INITIALIZE)
	(FASD-START-FILE)
	(FASD-ATTRIBUTES-LIST
	  (IF (GETL (LOCF ATTRIBUTE-LIST) '(:PACKAGE))
	      ATTRIBUTE-LIST
	    (LIST* ':PACKAGE ':USER ATTRIBUTE-LIST)))
	(DOLIST (FORM FORMS-LIST)
	  (IF ( (FASD-TABLE-LENGTH) QC-FILE-WHACK-THRESHOLD)
	      (FASD-END-WHACK))
	  (FASD-FORM FORM))
	(FASD-END-WHACK)
	(FASD-END-FILE)))))


(DEFUN MAKE-ARRAY-FOR-DUMPING-EXAMPLE (size)
  (make-array size :fill-pointer 0 :adjustable t
	      :type 'art-16b))

(DEFUN FASLOAD-FROM-ARRAY (ARRAY &OPTIONAL PKG NO-MSG-P)
  (SI:FASLOAD-INTERNAL (MAKE-STREAM-FROM-ARRAY ARRAY) PKG NO-MSG-P))