; -*- Mode:LISP; Package:FCOLD; Base:8; Lowercase:T; Readtable:ZL -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;	   (c) Copyright 1988 GigaMOS Systems Inc,

; Utilities for cold-load generator

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; To compile this:			       ;;;
;;;   (1) Load the old QFASL of it	       ;;;
;;;   (2) Run (LOAD-PARAMETERS)		       ;;;
;;;   (3) Now you may compile it	       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Little variables that have to do with the word format
(defvar big-fixnum)
(defvar little-fixnum)
(defvar q-typed-pointer-mask)	;Due to deficiencies in LDB and DPB
(defvar q-pointer-mask)

;;; Disk unit number

(defvar *unit-number*)

;;; The virtual memory

(defvar n-vmem-pages 16.)

;(i,0) is virtual page number, (i,1) is rqb
;Both slots are nil if unused
(defvar vmem-pages (make-array (list n-vmem-pages 2)))

(defvar vmem-page-reuse-pointer)

(defvar vmem-part-base)
(defvar vmem-part-size)
(defvar vmem-highest-address nil)

(defun vmem-initialize (part-name)
  (setq vmem-page-reuse-pointer 0)
  (multiple-value (vmem-part-base vmem-part-size) (sys:find-disk-partition part-name))
  (or vmem-part-base (ferror "~S partition not found on disk unit 0" part-name))
  (dotimes (i n-vmem-pages)
    (aset nil vmem-pages i 0)
    (aset nil vmem-pages i 1)))

;Write out all the buffered pages and return the rqb's
(defun vmem-finish (&aux rqb)
  (dotimes (i n-vmem-pages)
    (cond ((setq rqb (aref vmem-pages i 1))
	   (vmem-disk-io rqb (aref vmem-pages i 0) t)
	   (sys:return-disk-rqb rqb)
	   (aset nil vmem-pages i 1)))))

(defun vmem-disk-io (rqb vpn writep)
  (and (or (minusp vpn) ( vpn vmem-part-size))
       (ferror "Disk I//O outside of partition"))
  (funcall (if writep #'sys:disk-write #'sys:disk-read) rqb *unit-number* (+ vpn vmem-part-base)))

;Given address returns art-16b array containing that page.  With second arg of nil
;initializes to dtp-trap instead of reading in from disk.
(defun vmem-find-page (address &optional (get-from-disk-p t))
  (if (> (logand q-pointer-mask address) vmem-highest-address)
      (ferror "vmem-highest-address exceeded"))
  (do ((i 0 (1+ i))
       (vpn (truncate ;(ldb fsym:%%q-pointer address)
	              (logand q-pointer-mask address)
		      fsym:page-size))
       (rqb) (buf) (tem))
      (( i n-vmem-pages)
       (setq i vmem-page-reuse-pointer)
       (setq vmem-page-reuse-pointer (\ (1+ i) n-vmem-pages))
       (cond ((setq rqb (aref vmem-pages i 1))
	      (vmem-disk-io rqb (aref vmem-pages i 0) t))	;Swap this guy out
	     (t (setq rqb (sys:get-disk-rqb))
		(aset rqb vmem-pages i 1)))
       (aset vpn vmem-pages i 0)
       (setq buf (sys:rqb-buffer rqb))
       (cond (get-from-disk-p
	       (vmem-disk-io rqb vpn nil))
	     (t (setq tem (dpb fsym:dtp-trap fsym:%%q-data-type (* vpn fsym:page-size)))
		(do ((j 0 (1+ j))
		     (high (ldb (BYTE 16. 16.) tem))
		     (low (ldb (BYTE 16. 0.) tem)))
		    (( j fsym:page-size))
		  (aset (+ low j) buf (+ j j))
		  (aset high buf (+ j j 1)))))
       buf)
    (cond ((eq (aref vmem-pages i 0) vpn)	;Already swapped in
	   (and (= vmem-page-reuse-pointer i)
		(setq vmem-page-reuse-pointer (\ (1+ i) n-vmem-pages)))
	   (return (sys:rqb-buffer (aref vmem-pages i 1)))))))

(defun print-vmem-status ()
  (dotimes (i n-vmem-pages)
    (format t "~%Buffer index ~s holds virtual page ~s, rqb ~s"
	    i
	    (aref vmem-pages i 0)
	    (aref vmem-pages i 1))))

(defun vread (address)
  (let ((buf (vmem-find-page address))
	(i (* 2 (\ address fsym:page-size))))
    (dpb (aref buf (1+ i)) (BYTE 16. 16.) (aref buf i))))

(defun vwrite (address value)
  (let ((buf (vmem-find-page address))
	(i (* 2 (\ address fsym:page-size))))
    (aset (ldb (BYTE 16. 0.) value) buf i)
    (aset (ldb (BYTE 16. 16.) value) buf (1+ i))))

(defun vwrite-low (address value)
  (let ((buf (vmem-find-page address))
	(i (* 2 (\ address fsym:page-size))))
    (aset value buf i)))

(defun vwrite-high (address value)
  (let ((buf (vmem-find-page address))
	(i (* 2 (\ address fsym:page-size))))
    (aset value buf (1+ i))))

(defun vcontents (address)
  (logand q-typed-pointer-mask (vread address)))

(defun vstore-contents (address value)
  (let ((buf (vmem-find-page address))
	(i (* 2 (\ address fsym:page-size))))
    (aset (ldb (BYTE 16. 0.) value) buf i)
    (aset (deposit-field (aref buf (1+ i))
			 (- fsym:%%q-all-but-typed-pointer (byte 16. 0))
			 (ldb (BYTE 16. 16.) value))
	  buf (1+ i))))

;(defun vstore-cdr-code (address value)
;  (let ((buf (vmem-find-page address))
;	(i (* 2 (\ address fsym:page-size))))
;    (aset (dpb value (- fsym:%%q-cdr-code #o2000) (aref buf (1+ i))) buf (1+ i))))

;(defun vwrite-cdr (address cdr-code value)
;  (vwrite address (dpb cdr-code fsym:%%q-cdr-code value)))

(defsubst vmake-pointer (data-type address)
  (dpb data-type fsym:%%q-all-but-pointer address))

(defsubst vpointer (value)
  (logand q-pointer-mask value))

(defsubst vdata-type (value)
  (ldb fsym:%%q-data-type value))

(defsubst vfix (value)
  (vmake-pointer fsym:dtp-fix value))

(defun vlist (area &rest elements)
 ;converted
  (if (null elements)
      qnil
    (let ((value (vmake-pointer fsym:dtp-list
				(store-cdr-q area -1 (car elements)))))
      (do ((p (cdr elements) (cdr p)))
	  ((null p))
	(store-cdr-q area (if (null (cdr p)) qnil -1) (car p)))
      value)))

(defun vlist* (area &rest elements &aux last)
 ;converted
  (cond ((null elements) (ferror "Too few arguments to VLIST*"))
	((null (cdr elements)) (car elements))
	(t
	 (let ((value (vmake-pointer fsym:dtp-list
				     (setq last (store-cdr-q area -1 (car elements))))))
	   (do ((p (cdr elements) (cdr p)))
	       ((null p))
	     (if (cdr p) (setq last (store-cdr-q area -1 (car p)))
	       (vwrite (1+ last) (car p))))	;store in CDR position of last cons.
	   value))))

(defun vcar (location)
  (cond ((not (zerop (logand 1 location)))
	 (fsignal "Car of odd location")))
  (vcontents location))

(defun vcdr (location)
  (cond ((not (zerop (logand 1 location)))
	 (fsignal "Cdr of odd location")))
  (vcontents (1+ location)))

;If no property, returns a NIL in this machine.
;If property found, returns other-machine pointer to cell whose car is the property value.
(defun vget-location-or-nil (location property)
  (do ((cell (vcontents location) (vcdr (vcdr cell))))
      ((= cell qnil) qnil)
    (if (= (vcontents cell) property)
	(return (vcdr cell)))))

;;;; a bit of stuff for debugging

(defun vprint-q (q)
 ;converted.
  (format t "#<~a ~a>"
	  (vdata-type-symbol (vdata-type q))
	  (vpointer q)))

(defun vdata-type-symbol (dt-code)
  (let ((ans (rassq dt-code fsym:q-data-types-alist)))
    (if ans ans dt-code)))

(defvar vprinlength #o200)
(defvar vprinlevel  #o20)
(defvar vmax-stringlength #o200)

(defun vprint (typed-pointer &optional (vprinlevel vprinlevel))
  (let ((prinlength-count 0)
	(data-type (vdata-type typed-pointer))
	(pointer (vpointer typed-pointer)))
    (cond ((vatom? typed-pointer)
	   (cond ((= data-type fsym:dtp-symbol)
		  (vprint-string (vcontents pointer)))
		 ((= data-type fsym:dtp-fix)
		  (prin1 pointer))
		 (t (vprint-bomb typed-pointer))))
	  ((= data-type fsym:dtp-array-pointer)
	   (let ((header (vcontents pointer)))
	     (cond ((= (mask-field-from-fixnum fsym:%%array-type-field header)
		       fsym:art-string)
		    (princ "/"")
		    (vprint-string typed-pointer)
		    (princ "/""))
		   (t (vprint-bomb typed-pointer)))))
	  ((= data-type fsym:dtp-list)
	   (cond ((= vprinlevel 0)
		  (princ "#"))
		 (t
		  (princ "(")
		  (prog ((l typed-pointer)
			 (first-time t))
		     l	(cond ((> (setq prinlength-count (1+ prinlength-count))
				  vprinlength)
			       (princ "...")
			       (return nil))
			      ((vatom? l)
			       (cond ((vnull? l)
				      (princ ")")
				      (return nil))
				     (t
				      (princ " . ")
				      (vprint l (1- vprinlevel))
				      (princ ")")
				      (return nil)))))
			(if (null first-time)
			    (princ " "))
			(vprint (vcar l) (1- vprinlevel))
			(setq l (vcdr l))
			(setq first-time nil)
			(go l)))))
	  (t (vprint-bomb typed-pointer)))))

(defun vprint-bomb (typed-pointer)
  (vprint-q typed-pointer))

(defun vprint-string (string)
  (let* ((pointer (vpointer string))
	 (header (vcontents pointer))
	 (long-flag (ldb fsym:%%array-long-length-flag header))
	 (len (min vmax-stringlength
		   (if (zerop long-flag)
		       (ldb fsym:%%array-index-length-if-short header)
		     (vpointer (1+ (vcontents pointer)))))))
    (dotimes (c len)
      (let ((wd (vread (+ pointer 1 long-flag (lsh c -2)))))
	(tyo (logand 377 (ash wd (minus (* 8 (logand c 3)))))))))
  )

(defun vatom? (typed-pointer)
  (let ((data-type (vdata-type typed-pointer)))
    (cond ((or (= data-type fsym:dtp-symbol)
	       (= data-type fsym:dtp-fix)
	       (= data-type fsym:dtp-extended-number))
	   t))))

(defun vnull? (typed-pointer)
  (= typed-pointer qnil))

(defun mask-field-from-fixnum (ppss word)
   (logand word (dpb -1 ppss 0)))

(defvar sym-package (pkg-find-package "FCOLD-SYMBOLS"))
;(defvar misc-function-list)
;(defvar misc-instruction-list)

;;; Set up the fsym: package by loading the appropriate files
(defun load-parameters ()
  (load "FALCON: NCOLD; FQCOM LISP >" sym-package)
  (load "FALCON: NCOLD; FQDEFS LISP >" sym-package)
  (LOAD "FALCON: NCOLD; FSYSCONF LISP >" sym-package)
  ;(setq misc-function-list nil)
  ;(setq misc-instruction-list nil)
  ;(load "SYS: COLD; DEFMIC LISP >" sym-package)
  (dolist (l fsym:system-constant-lists)	;Make declarations so can compile self
    (dolist (s (symeval l))
      (putprop s t 'special)))
  (setq big-fixnum (1- (ash 1 (1- fsym:%%q-pointer)))
	little-fixnum (1- (- big-fixnum))
	q-typed-pointer-mask (1- (ash 1 fsym:%%q-typed-pointer))
	q-pointer-mask (1- (ash 1 fsym:%%q-pointer))))  

;;; These have to be explicitly declared special because they only exist in
;;; the cold-load generator, and are not sent over.
(proclaim '(special fsym:cold-load-area-sizes fsym:cold-load-region-sizes
		    fsym:scratch-pad-pointers fsym:scratch-pad-parameters
		    fsym:scratch-pad-parameter-offset fsym:q-corresponding-variable-lists
		   ;fsym:support-vector-contents
		    fsym:constants-page
		    fsym:read-only-area-list fsym:wired-area-list fsym:pdl-buffer-area-list
		    fsym:list-structured-areas fsym:static-areas fsym:unstructured-areas
		   ;fsym:a-memory-array-locations
		    fsym:new-array-index-order
		    fsym:prin1 fsym:base fsym:ibase fsym:*nopoint fsym:for-cadr
		    fsym:*print-base* fsym:*read-base* fsym:*print-radix*
		    fsym:lambda-list-keywords))


;;;; Basic area-processing and data-storing stuff

;;; Note that area names are always symbols in the fsym: package

(defvar symbol-creation-trace-list nil)
(defvar qnil)
(defvar qtruth)
(defvar area-origins (make-array #o400))
(defvar area-alloc-pointers (make-array #o400))
(defvar area-alloc-bounds (make-array #o400))

;;; Region areas correspond with area areas in that there are the same number of regions
;;; as there are areas.  If this tenuous connection is broken, this will have to change.
(defvar area-corresponding-arrays
	'fsym:(area-name region-origin region-length region-free-pointer
	      region-gc-pointer region-bits area-region-list area-region-bits
	      area-region-size
	      region-area-map
	      region-list-thread))

(defvar micro-code-entry-corresponding-arrays
	'fsym:(micro-code-entry-area
	      micro-code-entry-name-area
	      micro-code-entry-args-info-area
	      micro-code-entry-arglist-area
	      micro-code-entry-max-pdl-usage))

(defvar areas-with-fill-pointers
	(append '(fsym:micro-code-symbol-area
		   fsym:micro-code-symbol-name-area
		   fsym:support-entry-vector
		   fsym:constants-area
		   fsym:area-name)
		micro-code-entry-corresponding-arrays))

;;; areas in this list get art-q-list
(defvar list-referenced-areas areas-with-fill-pointers)

;;; areas in this list get art-q, all other areas get art-inum
(defvar array-referenced-areas 'fsym:(;system-communication-area
				     region-moby-bits-array
				     region-namespace-origin
				     region-spare))

(defun create-areas (&aux high-loc the-region-bits)
  (do ((l fsym:cold-load-area-sizes (cddr l)))	;Area sizes in pages
      ((null l))
    (putprop (car l) (cadr l) 'area-size))
  (fillarray area-origins '(nil))
  ;; Set up the area origin and allocation tables
  (loop with quantum = fsym:page-size
	for area in fsym:initial-area-list
	for area-number from 0 by 1
	for loc = 0 then (+ loc size)
	as size = (* (ceiling (* (get-area-size area) fsym:page-size) quantum)
		     quantum)
	when (eq area 'fsym:init-list-area)	;Last fixed area
	  do (setq quantum fsym:%address-space-quantum-size)
	     (let ((foo (\ (+ loc size) quantum)))	;Start next area on quantum boundary
	       (or (zerop foo) (setq size (+ (- size foo) quantum))))
	do (aset loc area-origins area-number)
	when (eq area 'fsym:extra-pdl-area)
	  do (if (not (zerop (\ (+ loc size) 1_13.)))
		 (ferror "EXTRA-PDL-AREA does not end on a lvl-1 map boundary"))
	finally (setq high-loc loc))
  (copy-array-contents area-origins area-alloc-pointers)
  (copy-array-portion area-origins 1 400 area-alloc-bounds 0 400)
  (aset high-loc area-alloc-bounds (1- (length fsym:initial-area-list)))
  (setq vmem-highest-address high-loc)
  ;; Fill various areas with default stuff
  (init-area-contents 'fsym:area-region-size 40000)	;these are ART-INUM now.
  (init-area-contents 'fsym:region-allocation-status big-fixnum)
  (init-area-contents 'fsym:region-area-map (vpointer -1))
  (init-area-contents 'fsym:region-origin 0)  ;so good type in free region#'s
  (init-area-contents 'fsym:region-length 0)  ;..
  (init-area-contents 'fsym:region-free-pointer 0)
  (init-area-contents 'fsym:region-gc-pointer 0)
  (init-area-contents 'fsym:region-bits 0)  ;Suitable for free region
  (init-area-contents 'fsym:area-region-bits 0)
  (init-area-contents 'fsym:region-moby-bits-array (vfix 0))
  (init-area-contents 'fsym:region-namespace-origin (vfix 0))
  (init-area-contents 'fsym:region-spare (vfix 0))
  ;; Every page thinks it has volatile pointers.  This makes the first scavenge slow,
  ;; but guarantees consistency without any awkward initializations.
  (init-area-contents 'fsym:virtual-page-volatility -1)
  (init-area-contents 'fsym:virtual-page-data 0) ;at least for reproducability.
  ;; Crank up region size for certain big areas
  (do l fsym:cold-load-region-sizes (cddr l) (null l)
      (vwrite (+ (get-area-origin 'fsym:area-region-size) (get-area-number (car l)))
	      (cadr l)))
  ;; Set up contents of certain initial areas
  (do ((i 0 (1+ i))
       (al fsym:initial-area-list (cdr al))
       (fixed-p t))
      ((null al))
    (and (eq (car al) 'fsym:working-storage-area) (setq fixed-p nil))
    (vwrite (+ (get-area-origin 'fsym:area-region-list) i) i)
    (vwrite (+ (get-area-origin 'fsym:region-list-thread) i) (+ i little-fixnum))
    (vwrite (+ (get-area-origin 'fsym:region-bits) i)
	    (setq the-region-bits 
		  (+ (dpb (cond ((memq (car al) fsym:read-only-area-list) #o1200)	;ro
				      ((memq (car al) fsym:wired-area-list) #o1400)	;rw
				      ((memq (car al) fsym:pdl-buffer-area-list)
				       #o500)			;may be in pdl-buffer, no access.
				      (t #o1300))			;rwf
				fsym:%%region-map-bits
				0)
		     (dpb 1 fsym:%%region-oldspace-meta-bit 0)
		     (dpb (if (eq (car al) 'fsym:extra-pdl-area) 0 1)
			  fsym:%%region-extra-pdl-meta-bit 0)
		     (dpb (if (memq (car al) fsym:unstructured-areas)
			      fsym:%region-representation-type-unstructured
			    fsym:%region-representation-type-lisp)
			  fsym:%%region-representation-type 0)
		     (dpb (cond ((eq (car al) 'fsym:extra-pdl-area) fsym:%region-space-extra-pdl)
				(fixed-p fsym:%region-space-fixed)
				((memq (car al) fsym:static-areas) fsym:%region-space-static)
				(t fsym:%region-space-new))
			  fsym:%%region-space-type 0)
		     (dpb (let ((v (memq (car al) fsym:cold-load-area-volatilities)))
			    (if v (cadr v) 0))
			  fsym:%%region-volatility
			  0)
		     ;; Set up the scavenge enable.  Note!  The extra-pdl does not follow the
		     ;; prescribed protocol for header/body forward, and gets randomly reset.
		     ;; Fortunately it never points at anything.
		     (dpb (if fixed-p
			      (if (memq (car al) fsym:unstructured-areas) 0 1)
			    (if (memq (car al) fsym:static-areas) 1 0))
			  fsym:%%region-scavenge-enable
			  0)
		     (dpb (if (memq (car al) '(fsym:pdl-area fsym:special-pdl-area)) 1 0)
			  fsym:%%region-scavenge-carefully
			  0))))
    (vwrite (+ (get-area-origin 'fsym:region-area-map) i) i)
    (vwrite (+ (get-area-origin 'fsym:area-region-bits) i)
	    the-region-bits)
    (vwrite (+ (get-area-origin 'fsym:region-origin) i)
	    (aref area-origins i))
    (vwrite (+ (get-area-origin 'fsym:region-length) i)
	    (- (aref area-alloc-bounds i) (aref area-origins i)))))

(defun get-area-number (area)
  (cond ((numberp area) area)
	((find-position-in-list area fsym:initial-area-list))	;No symeval, might have changed.
	((ferror "~S bad area-name" area))))

(defun get-area-origin (area)
  (aref area-origins (get-area-number area)))

(defun get-area-bound (area)
  (aref area-alloc-bounds (get-area-number area)))

(defun get-area-free-pointer (area)
  (aref area-alloc-pointers (get-area-number area)))

(defun fill-odd-q-if-necessary (area &aux address)
  (setq area (get-area-number area))
  (setq address (aref area-alloc-pointers area))
  (cond ((zerop (logand address 1)) nil)
	(t (setq address (allocate-block area 1))
	   (vwrite address (vmake-pointer fsym:$$dtp-filler 0))
	   t)))

(defun allocate-cons (area &aux address size)
  (setq area (get-area-number area))
  (setq address (aref area-alloc-pointers area))
  (setq size (if (zerop (logand address 1)) 2 3))
  (setq address (allocate-block area size))
  (cond ((zerop (logand address 1)) address)
	(t (vwrite address (vmake-pointer fsym:$$dtp-filler 0))
	   (1+ address))))

(defun allocate-block (area size &aux address high)
  (setq area (get-area-number area))
  (setq address (aref area-alloc-pointers area))
  (setq high (+ address size))
  (and (> high (aref area-alloc-bounds area))
       (ferror "~A area overflow" (nth area fsym:initial-area-list)))
  (aset high area-alloc-pointers area)
  ;Page in all the fresh pages without really paging them in, thus initializing them
  (do ((vpn (ceiling address fsym:page-size) (1+ vpn))
       (hpn (ceiling high fsym:page-size)))
      (( vpn hpn))
    (vmem-find-page (* vpn fsym:page-size) nil))
  address)

;;; In pages
(defun get-area-size (area)
  (check-arg area (memq area fsym:initial-area-list) "an area-name")
  (cond ((get area 'area-size))
	(t 1)))

;;; Doesn't advance allocation pointer, i.e. sets it back to origin when done
(defun init-area-contents (area contents)
  (let ((count (* fsym:page-size (get-area-size area))))
    (setq area (get-area-number area))
    (do ((adr (allocate-block area count) (1+ adr))
	 (n count (1- n)))
	((zerop n)
	 (aset (aref area-origins area) area-alloc-pointers area))
      (vwrite adr contents))))

(defvar store-halfwords-address)
(defvar store-halfwords-count)
(defvar store-halfwords-buffer)

(defun begin-store-halfwords (name-of-area n-words)
  (let* ((area-number (get-area-number name-of-area))
	 (address (allocate-block area-number n-words)))
    (setq store-halfwords-address address
	  store-halfwords-count (* 2 n-words))
    address))

(defun store-halfword (hwd)
  (if (oddp (setq store-halfwords-count (1- store-halfwords-count)))
      (setq store-halfwords-buffer hwd)
      (vwrite store-halfwords-address (dpb hwd (BYTE 16. 16.) store-halfwords-buffer))
      (setq store-halfwords-address (1+ store-halfwords-address))))

(defun end-store-halfwords ()
  (or (zerop store-halfwords-count)
      (ferror "store-halfword called wrong number of times")))

;;; Given an object in our world, construct a matching one in the cold load world
;;; and return a cold-load pointer to it.
(defun make-q-list (area s-exp &aux bsize value)
 ;converted
  (cond ((numberp s-exp)
	 (cond ((small-floatp s-exp) (make-small-flonum s-exp))
	       ((floatp s-exp) (store-flonum 'fsym:working-storage-area s-exp))
	       ((complexp s-exp) (store-complex 'fsym:working-storage-area s-exp))
	       ((integerp s-exp)
		(cond ((and ( s-exp big-fixnum) ( s-exp little-fixnum)) (vfix s-exp))
		      (t (store-bignum 'fsym:working-storage-area s-exp))))
	       ((rationalp s-exp)
		(store-rational 'fsym:working-storage-area s-exp))
	       (t (ferror "unknown number type ~s" s-exp))))
	((characterp s-exp)
	 (vmake-pointer fsym:dtp-character (char-int s-exp)))
	((symbolp s-exp) (qintern s-exp))
	((stringp s-exp) (store-string 'fsym:p-n-string s-exp))
	((atom s-exp) (ferror "~S unknown type" s-exp))
	(t
;	   (or (memq area fsym:list-structured-areas)
;	       (ferror "make-q-list in non-list-structured area ~S" area))
	   (setq bsize (* 2 (length s-exp)))
	   (setq value (vmake-pointer fsym:dtp-list (allocate-block area bsize)))
	   (do ((s-exp s-exp (cdr s-exp))
		(adr (logand q-pointer-mask value) (+ adr 2)))
	       ((atom s-exp)
		(vwrite (1- adr) (make-q-list area s-exp))) ;store NIL or dotted pair
	     (vwrite adr (make-q-list area (car s-exp)))
	     (vwrite (1+ adr) (vmake-pointer fsym:dtp-list (+ adr 2))))
	   value)))

(defun make-small-flonum (s-exp)  ;I hope the format doesn't change!
  (let ((as-fixnum (%pointer s-exp)))
;; The following line should be removed once we are running in system 99 or above.
;   (setq as-fixnum (%pointer-plus as-fixnum #o40000000))
    (vmake-pointer fsym:dtp-small-flonum as-fixnum)))

(defun magic-aref (a i n)
  (if (< i n) (aref a i) #o200))

(defun store-string (area string)
;   (and (memq area fsym:list-structured-areas)
;	(ferror "store-string in list-structured area"))
   (let* ((n-chars (string-length string))
	  (n-words (+ 1 (ceiling n-chars 4)))
	  adr)
     (setq adr (allocate-block area n-words))
     (vwrite adr (vmake-pointer fsym:$$dtp-array-header-single
				(+ fsym:art-string
				   (if long-flag
				       (dpb 1 fsym:%%array-long-length-flag 0)
				     n-chars))))
     (when long-flag
       (vwrite (1+ adr) n-chars))
     (do ((i (if long-flag 2 1) (1+ i))
	  (j 0 (+ j 4)))
	 ((= i n-words))
       (vwrite (+ adr i)
	       (+ (magic-aref string j n-chars)
		  (ash (magic-aref string (1+ j) n-chars) 8)
		  (ash (magic-aref string (+ j 2) n-chars) 16.)
		  (ash (magic-aref string (+ j 3) n-chars) 24.))))
     (vmake-pointer fsym:dtp-array-pointer adr)))

(defun store-symbol-vector (atom-name area)
;  (and (memq area fsym:list-structured-areas)
;       (ferror "store-symbol-vector in list-structured area ~S" area))
  (and (eq atom-name '**screw**)
       (ferror "you've probably encountered a bug in COLDLD" atom-name))
  (prog (adr sym path real-atom-name package-name pname keyword-p)
     (cond ((setq path (get atom-name 'package-path))
	    (or (= (length path) 2)
		(ferror "package path ~S not 2 long - code not hairy enough"))
	    (setq keyword-p (eq (car path) 'keyword))
	    (setq package-name (qintern (car path))
		  real-atom-name (car (last path))))
	   (t (setq package-name qnil real-atom-name atom-name)))
     (cond ((and (>= (array-length (string atom-name)) 1)
		 (= (aref (string atom-name) 0)
		    #/:))
	    (setq keyword-p t)))
     (when symbol-creation-trace-list	;debugging tool to track down appears twice in 
       (do ((l symbol-creation-trace-list (cdr l)))	;cold load messages.
	   ((null l))
	 (cond ((string= real-atom-name (car l))
		(format t "
A-flavor-of ~S being-created, atom-name ~S, path ~S, package-name ~S, keyword-p ~s"
			real-atom-name atom-name path  package-name keyword-p)))))
     (setq pname (store-string 'fsym:p-n-string (string real-atom-name)))
     (setq adr (allocate-block area fsym:*symbol-size-in-qs*))
     (setq sym (vmake-pointer fsym:dtp-symbol adr))
     (vwrite adr (vmake-pointer fsym:dtp-symbol-header pname))
     (vwrite (+ adr 1) (if keyword-p
			   sym		;keywords self evaluate.
			 (vmake-pointer fsym:dtp-null adr)))
     (vwrite (+ adr 2) (vmake-pointer fsym:dtp-null adr))
     (vwrite (+ adr 3) qnil)
     (vwrite (+ adr 4) package-name)
     (putprop atom-name sym 'q-atom-head)
     (return sym)))

(deff store-bignum 'store-extended-number)
(deff store-flonum 'store-extended-number)

(defun store-extended-number (area number)
;  (and (memq area fsym:list-structured-areas)
;       (ferror "extended-number in list-structured area ~S" area))
  (let* ((size (%structure-total-size number))
	 (adr (allocate-block area size)))
    (loop for i from 0 below size
	  do (vwrite-low (+ adr i) (%p-ldb-offset (BYTE 16. 0.) number i))
	     (vwrite-high (+ adr i) (%p-ldb-offset (BYTE 16. 16.) number i)))
    (vmake-pointer fsym:dtp-extended-number adr)))

(deff store-complex 'store-complex-or-rational)
(deff store-rational 'store-complex-or-rational)

;someday, this can be combined back with store-extended-number, and
;copy over first %structure-boxed-size Qs, then the rest of %structure-total-size
;words
(defun store-complex-or-rational (area number)
  (fsignal "convert this")
  (if (not (or (typep number 'rational)
	       (typep number 'complex)))
      (ferror "not complex or rational"))
;  (and (memq area fsym:list-structured-areas)
;       (ferror "extended-number in list-structured area ~S" area))
  (let ((adr (allocate-block area 3)))
    ;copy over the header
;    (vwrite-low adr (%p-ldb (BYTE 16. 0.) number))
;    (vwrite-high adr (%p-ldb (BYTE 16. 16.) number))
;    (vwrite-cdr (+ adr 1) fsym:cdr-next (make-q-list area (%p-contents-offset number 1)))
;    (vwrite-cdr (+ adr 2) fsym:cdr-nil (make-q-list area (%p-contents-offset number 2)))
;    (vmake-pointer fsym:dtp-extended-number adr)
    ))
  

;;; New version of qintern.  Machine builds obarray when it first comes up (easy enough).
(defun qintern (atom-name)
  (check-type atom-name symbol)
  (cond ((not (eq (car (package-cell-location atom-name)) sym-package))
	 (let* ((sym-atom-name (intern (string atom-name) sym-package))
		(current-package-path-property (get sym-atom-name 'package-path))
		(new-package-path-property
		  (list (intern (package-name (car (package-cell-location atom-name)))
				'cold)
			(intern (string atom-name) 'cold))))
	   (if (not (or (equal current-package-path-property
			       new-package-path-property)
			;for these, we either dont really want it there, or it will get there.
			(memq (car new-package-path-property)
			      '(global fcold fcold-symbols system-internals))))
	       (cond ((null current-package-path-property)
		      (format t "~%Adding package path property ~s for ~s at qintern"
			      new-package-path-property
			      atom-name)
		      (putprop sym-atom-name new-package-path-property 'package-path))
		     (t
		      ;cold load can only deal with each string being in one package.
		      (ferror "Need to add package-path property ~S for symbol ~s, but ~s is already on fsym: symbol"
			      new-package-path-property
			      atom-name
			      current-package-path-property))))
	   (setq atom-name sym-atom-name))))
  (or (get atom-name 'q-atom-head)
      (store-symbol-vector atom-name 'fsym:nr-sym)))

(defun q-atom-head-reset (&optional (pkg sym-package))
  (mapatoms #'(lambda (x) (remprop x 'q-atom-head)) pkg nil))

(defun print-q-symbols (&optional (pkg sym-package))
  (mapatoms #'(lambda (x)
		(let ((q-atom (get x 'q-atom-head)))
		  (if q-atom
		      (format t "~%Symbol ~s, q-atom-head ~s" x q-atom))))
	    pkg
	    nil))

(defun store-list-of-atoms (area loa)
 ;converted
  (fill-odd-q-if-necessary area)
  (let ((adr (allocate-block area (* 2 (length loa)))))
    (do ((loa loa (cdr loa))
	 (adr adr (+ adr 2)))
	((null loa))
      (vwrite adr (q-convert-atom (car loa)))
      (vwrite (1+ adr) (if (null (cdr loa)) qnil (vmake-pointer dtp-list (+ adr 2)))))
    adr))

(defun q-convert-atom (atm)
  (if (numberp atm) (make-q-list nil atm) (qintern atm)))

(defun store-list (area lst)
 ;converted!
  (fill-odd-q-if-necessary area)
  (let ((adr (allocate-block area (* 2 (length lst)))))
    (do ((lst lst (cdr lst))
	 (adr adr (+ adr 2)))
	((null lst))
      (vwrite adr (make-q-list
		    'fsym:init-list-area
		    (car lst)))
      (vwrite (1+ adr) (if (null (cdr lst)) qnil (vmake-pointer dtp-list (+ adr 2))))
    adr)))

(defun store-nils (area number)
  ;This will no longer be LISTified.
  (let ((adr (allocate-block area number)))
    (do ((number number (1- number))
	 (adr adr (1+ adr)))
	((zerop number))
      (vwrite adr qnil))
    adr))

(defun storeq (area data)
  (let ((adr (allocate-block area 1)))
    (vwrite adr data)
    adr))

(defun store-cdr-q (area cdr-data data)
 ;if cdr-data is -1, it means to make it point to next cons cell with DTP-LIST.
  (let ((adr (allocate-cons area)))
    (vwrite adr data)
    (vwrite (1+ adr) (if (minusp cdr-data)
			 (vmake-pointer fsym:dtp-list (+ 2 adr))
		       cdr-data))
    adr))

;;;; Hair for making arrays

(defun init-q-array (area name offset type dimlist displaced-p leader)
  (init-q-array-named-str area name offset type dimlist displaced-p leader nil))

;NOTE!! LEADER IS STOREQ ED DIRECTLY SO IT MUST ALREADY BE MAKE-Q-LIST IFIED
;**array
(defun init-q-array-named-str (area name offset type dimlist displaced-p leader named-str)
	;  leader is contents of array leader, if desired.  it is in "storage order"
	;which is reversed from index order.
	;  if leader is numeric, it means make leader consisting of that many q's
	;initialized to nil.
	;  if name -> nil, return (list <array-adr> <data-length>) and dont try
	;to store in function or value cell.
	;offset 1 for storing pointer to array in value cell, 2 for function cell
;  (and (memq area fsym:list-structured-areas)
;       (ferror "init-q-array in list-structured area"))
  (prog (tem ndims index-length data-length tem1 leader-length header-q h1-q h1-present adr)
	(and (numberp dimlist) (setq dimlist (list dimlist)))
	(setq ndims (length dimlist))
	(when fsym:new-array-index-order
	  (setq dimlist (reverse dimlist)))
	;; The rest of this is correct for column-major order.
	(setq index-length (sys:list-product dimlist))
	(setq leader-length (cond ((null leader) 0)
				  ((numberp leader) (+ 2 leader))
				  (t (+ 2 (length leader)))))
	(setq h1-present (or (not (= 1 ndims))
			     named-str
			     (not (= 0 leader-length))
			     displaced-p))
	(cond ((null (setq tem (assq type fsym:array-elements-per-q)))
	       (ferror "~S bad array type" type)))
	(setq tem (cdr tem))
	(cond ((not (null leader))
	       (setq adr (allocate-block area leader-length))
	       (vwrite adr (vmake-pointer fsym:$$dtp-array-leader-header leader-length))
;	       (vwrite adr (vmake-pointer fsym:dtp-header
;					  (dpb fsym:%header-type-array-leader
;					       fsym:%%header-type-field
;					       leader-length)))
	       (cond ((numberp leader)
		      (dotimes (i leader)
			(vwrite (+ adr i 1) qnil))
  ;named structure in array-leader 1.
		      (if named-str (vwrite (+ adr leader -1)	;(array-leader x 1)
					    (qintern named-str))))
		     (t (do ((l leader (cdr l))
			     (i 1 (1+ i)))
			    ((null l))
			  (vwrite (+ adr i) (car l)))))
	       (vwrite (+ adr leader-length -1) (vfix (- leader-length 2)))
	       ))
	(setq data-length (ceiling index-length tem))
	(setq header-q (vmake-pointer fsym:dtp-array-header
				      (+ (* fsym:array-dim-mult ndims)
					 (symeval type))))
	(and leader (setq header-q (+ header-q fsym:array-leader-bit)))
	(and named-str (setq header-q (+ header-q fsym:array-named-structure-flag)))
	(cond (displaced-p   ;note, no index-offset arrays in cold-load
		(setq tem 1 header-q (+ header-q fsym:array-displaced-bit 2)))
	      (t
		(setq tem 1 header-q (+ header-q index-length))))
	(setq tem1 (setq adr (allocate-block area (+ tem ndims -1))))
	(vwrite adr header-q)
	(and (= tem 2) (vwrite (setq adr (1+ adr)) (vfix index-length)))
	;Store all dimensions except for last
	(do l dimlist (cdr l) (null (cdr l))
	  (vwrite (setq adr (1+ adr)) (vfix (car dimlist))))
	(cond ((null name) (return (list tem1 data-length))))
	(vstore-contents (+ (qintern name) offset)
			 (vmake-pointer fsym:dtp-array-pointer tem1))
	(return data-length)))

(defun store-q-array-leader (arrayp idx data)
  (vwrite (- arrayp (+ 2 idx))			;1 for array header, 1 for ldr len
	  data))

;;;; Setting up various magic data structures,
;;;;  mostly having to do with the microcode and the fixed-areas

;(defun store-support-vector (item)
;  (let ((adr (allocate-block 'fsym:support-entry-vector 1)))
;    (vwrite-cdr adr fsym:cdr-next
;		(cond ((eq (car item) 'fsym:function)
;		       (get-q-fctn-cell (cadr item)))
;		      ((memq (car item) '(quote fsym:quote))
;		       (make-q-list
;			 'fsym:init-list-area
;			 (cadr item)))
;		      (t (ferror "bad-support-code: ~S" item))))
;    adr))

(defun get-q-fctn-cell (fctn &aux tem)
  (and (setq tem (get fctn 'q-atom-head))
       (vcontents (+ tem 2))))

;(defun store-displaced-array-pointer (area)
; (prog (fillp area-array-type data-length adr)
;    (setq fillp (memq area areas-with-fill-pointers))
;    (setq area-array-type 
;	  (cond ((eq area 'fsym:address-space-map) 'fsym:art-16b)	;%address-space-map-byte-size
;		((memq area list-referenced-areas) 'fsym:art-q-list)
;		((memq area array-referenced-areas) 'fsym:art-q)
;		((eq area 'fsym:virtual-page-volatility) 'fsym:art-2b)
;		(t 'fsym:art-inum)))
;    (init-q-array 'fsym:control-tables
;		  area  
;		  2 
;		  area-array-type  
;		  (setq data-length	;In entries, not Qs!
;			(case area
;			  (fsym:virtual-page-volatility
;			   (^ 2 17.))
;			  (fsym:address-space-map
;			   (truncate (1+ q-pointer-mask) fsym:%address-space-quantum-size))
;			  (fsym:system-communication-area
;			   (length fsym:system-communication-area-qs))
;			  (otherwise
;			   (* fsym:page-size (get-area-size area)))))
;		  t 
;		  (and fillp
;		       (list (vfix (cond ((memq area area-corresponding-arrays)
;					  (length fsym:initial-area-list))
;					 ((memq area
;						micro-code-entry-corresponding-arrays)
;					  (length micro-code-entry-vector))
;					 ((eq area 'fsym:address-space-map)
;					  (truncate (1+ q-pointer-mask)
;						    fsym:%address-space-quantum-size))
;					 (t
;					  (* fsym:page-size (get-area-size area))))))))
;    (setq adr (allocate-block 'fsym:control-tables 2))
;    (vwrite adr (vfix (get-area-origin area)))
;    (vwrite (1+ adr) (vfix data-length))))

;;; This abbreviated version of the stuff in UTIL2 should be enough to get us off the ground
(defun get-q-args-prop (fctn &aux tem)
  (cond ((setq tem (get fctn 'fsym:argdesc))
	 (get-q-args-prop-from-argdesc-prop tem))
	((setq tem (get fctn 'fsym:qintcmp))
	 (+ (lsh tem 6) tem))
	;; You may think this is a kludge, but in the Maclisp cold-load generator
	;; it gets the number of arguments out of the Maclisp subr of the same name!
	((setq tem (get fctn 'defmic-nargs-info))
	 (if (consp tem) (+ (lsh (car tem) 6) (cdr tem))
	     (+ (lsh tem 6) tem)))
	(t (ferror "Cannot find arg desc for ~S" fctn))))

(defun get-q-args-prop-from-argdesc-prop (arg-desc)
  (prog (prop min-args max-args count item)
	(setq prop 0 min-args 0 max-args 0)
     l	(cond ((null arg-desc) (return (+ prop (lsh min-args 6) max-args))))
	(setq count (caar arg-desc))
	(setq item (cadar arg-desc)) ;list of arg syntax, quote type, other attributes
	(setq arg-desc (cdr arg-desc))
     l1	(cond ((= 0 count) (go l))
	      ((memq 'fsym:fef-arg-rest item)
	       (setq prop (logior prop (if (or (memq 'fsym:fef-qt-eval item)
					       (memq 'fsym:fef-qt-dontcare item))
					   fsym:%arg-desc-evaled-rest
					   fsym:%arg-desc-quoted-rest)))
	       (go l))
	      ((memq 'fsym:fef-arg-req item)
	       (setq min-args (1+ min-args)))
	      ((memq 'fsym:fef-arg-opt item))
	      (t (go l)))
    	(setq max-args (1+ max-args))
	(or (memq 'fsym:fef-qt-eval item)
	    (memq 'fsym:fef-qt-dontcare item)
	    (setq prop (logior prop fsym:%arg-desc-fef-quote-hair)))
	(setq count (1- count))
	(go l1)))


(defun store-lisp-value-list (x)
  (mapc #'store-lisp-value (symeval x)))

(defun store-lisp-value (sym)
  (storein-q-value-cell sym (make-q-list
			      'fsym:init-list-area
			      (symeval sym))))

(defun cold-load-time-set (sym value)
;  (cond ((or (numberp value)
;	     (stringp value)
;	     (memq value '(fsym:t fsym:nil))))
;	((quotep value)
;	 (setq value (cadr value)))
;	(t (ferror "(setq ~S ~S) no can do" sym value)))
  (storein-q-value-cell sym (make-q-list
			      'fsym:init-list-area
			      value)))

(defun storein-q-value-cell (sym data)
  (vstore-contents (1+ (qintern sym)) data))

;(defun init-scratch-pad-area ()
;  (init-area-contents 'fsym:scratch-pad-init-area (vfix 0))
;  (aset (+ (aref area-origins (get-area-number 'fsym:scratch-pad-init-area))
;	   fsym:scratch-pad-parameter-offset 
;	   (length fsym:scratch-pad-parameters))
;	area-alloc-pointers
;	(get-area-number 'fsym:scratch-pad-init-area))
;  (scratch-store-q 'fsym:initial-top-level-function
;		   (vmake-pointer fsym:dtp-locative
;				  (+ (qintern 'fsym:lisp-top-level) 2)))
;  ;trap-handler (not used)
;  (let ((initial-stack-group-pointer (make-initial-stack-group-structure)))
;    (scratch-store-q 'fsym:current-stack-group initial-stack-group-pointer)
;    (scratch-store-q 'fsym:initial-stack-group initial-stack-group-pointer))
;  (scratch-store-q 'fsym:error-handler-stack-group qnil)  ;initialized at run time
;  (scratch-store-q 'fsym:default-cons-area (vfix (get-area-number 'fsym:working-storage-area))))

;(defun scratch-store-q (symbolic-name data)
;   (prog (tem origin)
;	 (setq origin (get-area-origin 'fsym:scratch-pad-init-area))
;	 (cond ((setq tem (find-position-in-list symbolic-name fsym:scratch-pad-pointers))
;		(vstore-contents (+ origin tem) data))
;	       ((setq tem (find-position-in-list symbolic-name fsym:scratch-pad-parameters))
;		(vstore-contents (+ origin fsym:scratch-pad-parameter-offset tem) data))
;	       (t (ferror "unknown-scratch-quantity: ~S" symbolic-name)))))

;(defun store-a-mem-location-names ()
;    (do ((name fsym:a-memory-location-names (cdr name))
;	 (locn (+ fsym:size-of-hardware-m-memory fsym:a-memory-virtual-address) (1+ locn)))
;	((null name))
;     (store-mem-location (car name) locn))
;    (do name fsym:m-memory-location-names (cdr name) (null name)
;     (store-mem-location (car name) (get (car name) 'fsym:forwarding-virtual-address)))
;    (store-mem-location 'fsym:%gc-generation-number
;			(+ #o400 fsym:%sys-com-gc-generation-number))
;    )

(defun store-mem-location (name locn)
  (storein-q-value-cell name (vmake-pointer fsym:dtp-one-q-forward locn)))

(defun make-ordered-array-list (assoc-list)
  (mapcar #'(lambda (x) (cdr (assq x assoc-list)))
	  fsym:array-types))

(defun make-initial-stack-group-structure ()
  (make-stack-group-structure 'fsym:main-stack-group 'fsym:control-tables
			      'fsym:pdl-area 'fsym:special-pdl-area
			      fsym:sg-state-active))
 
(defun make-stack-group-structure (name sg-area linear-area l-b-p-area initial-state) 
  (prog (sg pdl-array l-b-p-array reg-len spec-len)
	(setq sg (car (init-q-array sg-area nil nil 'fsym:art-stack-group-head '(0)
				    nil (length fsym:stack-group-head-leader-qs))))
	;; 4  leader-header + leader-length-q + array-header-q + long-length-q
	(setq reg-len (- 40000 (+ (length fsym:reg-pdl-leader-qs) 4)))
	(setq spec-len (- 4000 (+ (length fsym:special-pdl-leader-qs) 4)))
	(setq pdl-array
	      (car (init-q-array linear-area nil nil 'fsym:art-reg-pdl (list reg-len)
				 nil (length fsym:reg-pdl-leader-qs))))
	(allocate-block linear-area reg-len)	;advance free pointer
	(setq l-b-p-array
	      (car (init-q-array l-b-p-area nil nil 'fsym:art-special-pdl (list spec-len)
				 nil (length fsym:special-pdl-leader-qs))))
	(allocate-block l-b-p-area spec-len)	;advance free pointer
	(stack-group-linkup sg pdl-array l-b-p-array)
	(store-q-array-leader sg fsym:sg-state (vfix initial-state))
	(store-q-array-leader sg fsym:sg-name (make-q-list
					       'fsym:init-list-area
					       name))
	(store-q-array-leader sg fsym:sg-regular-pdl-limit
			      (make-q-list
				'fsym:init-list-area
				(- reg-len 100)))
	(store-q-array-leader sg fsym:sg-special-pdl-limit
			      (make-q-list
				'fsym:init-list-area
				(- spec-len 100)))
	(return (vmake-pointer fsym:dtp-stack-group sg))))

(defun stack-group-linkup (sg pdl-arrayp l-b-p-arrayp)
  (store-q-array-leader l-b-p-arrayp fsym:special-pdl-sg-head-pointer
			(vmake-pointer fsym:dtp-stack-group sg))
  (store-q-array-leader pdl-arrayp fsym:reg-pdl-sg-head-pointer
			(vmake-pointer fsym:dtp-stack-group sg))
  (store-q-array-leader sg fsym:sg-special-pdl
			(vmake-pointer fsym:dtp-array-pointer l-b-p-arrayp))
  (store-q-array-leader sg fsym:sg-regular-pdl
			(vmake-pointer fsym:dtp-array-pointer pdl-arrayp))
  (store-q-array-leader sg fsym:sg-initial-function-index (vfix 3)))

;This better agree with the order of the list of qs in QCOM
;(defun init-system-communication-area (&aux (nqs 30.) adr)
;  (setq adr (allocate-block 'fsym:system-communication-area nqs))
;  (vwrite (+ adr fsym:%sys-com-area-origin-pntr)
;	  (vmake-pointer fsym:dtp-fix (get-area-origin 'fsym:region-origin)))
;  (vwrite (+ adr fsym:%sys-com-valid-size) (vfix 0))	;fixed later
;  (vwrite (+ adr fsym:%sys-com-page-table-pntr)
;	  (vmake-pointer fsym:dtp-fix (get-area-origin 'fsym:page-table-area)))
;  (vwrite (+ adr fsym:%sys-com-page-table-size)	;Real value put in by microcode
;	  (vfix (* (get-area-size 'fsym:page-table-area) fsym:page-size)))
;  (vwrite (+ adr fsym:%sys-com-obarray-pntr) (qintern 'fsym:obarray))
;  (vwrite (+ adr fsym:%sys-com-ether-free-list) qnil)
;  (vwrite (+ adr fsym:%sys-com-ether-transmit-list) qnil)
;  (vwrite (+ adr fsym:%sys-com-ether-receive-list) qnil)
;  (vwrite (+ adr fsym:%sys-com-band-format) (vfix 0))	;not compressed format
;  (vwrite (+ adr fsym:%sys-com-gc-generation-number) (vfix 0))
;  (vwrite (+ adr fsym:%sys-com-unibus-interrupt-list) (vfix 0))
;  (vwrite (+ adr fsym:%sys-com-temporary) (vfix 0))
;  (vwrite (+ adr fsym:%sys-com-free-area/#-list) 0)	;fixed later
;  (vwrite (+ adr fsym:%sys-com-free-region/#-list) 0)	;fixed later
;  (vwrite (+ adr fsym:%sys-com-memory-size) (vfix #o100000))	;assume 32K, fixed later
;  (vwrite (+ adr fsym:%sys-com-wired-size)  ;region-moby-bits-array is the first pageable area
;	  (vfix (get-area-origin 'fsym:region-moby-bits-array)))
;  (vwrite (+ adr fsym:%sys-com-chaos-free-list) qnil)
;  (vwrite (+ adr fsym:%sys-com-chaos-transmit-list) qnil)
;  (vwrite (+ adr fsym:%sys-com-chaos-receive-list) qnil)
;  (vwrite (+ adr fsym:%sys-com-debugger-requests) (vfix 0))
;  (vwrite (+ adr fsym:%sys-com-debugger-keep-alive) (vfix 0))
;  (vwrite (+ adr fsym:%sys-com-debugger-data-1) (vfix 0))
;  (vwrite (+ adr fsym:%sys-com-debugger-data-2) (vfix 0))
;  ;(vwrite (+ adr fsym:%sys-com-major-version) qnil)	;I.e. fresh cold-load
;  (vwrite (+ adr  fsym:%sys-com-major-version) 
;	  (vfix (fs:reading-from-file (form "SYS:PATCH; SYSTEM PATCH-DIRECTORY >")
;		  (return (cadr form)))))
;  (vwrite (+ adr fsym:%sys-com-desired-microcode-version) qnil)	;Set by system initialization
;  (vwrite (+ adr fsym:%sys-com-highest-virtual-address)
;	  (vfix 0)) ;used only if compressed band.
;  (vwrite (+ adr fsym:%sys-com-pointer-width) (vfix fsym:%%q-pointer))
;  (vwrite (+ adr fsym:%sys-com-number-regions) (vfix fsym:number-of-regions))
;  (vwrite (+ adr fsym:%sys-com-number-areas) (vfix fsym:number-of-areas))
;  (vwrite (+ adr fsym:%sys-com-band-crc) (vfix 0))
;  (or (= nqs (length fsym:system-communication-area-qs))
;      (ferror "QCOM and COLDUT disagree about system-communication-area")))

(defun q-storage-finalize ()
  (mapc #'store-displaced-array-pointer fsym:initial-area-list)
  (scratch-store-q 'fsym:active-micro-code-entries (vfix (length micro-code-entry-vector)))
  ;; Transfer over free pointers
  (do ((area-number 0 (1+ area-number))
       (a-l fsym:initial-area-list (cdr a-l))
       (rfp (get-area-origin 'fsym:region-free-pointer)))
      ((null a-l))
    (vwrite (+ rfp area-number)
	    (- (aref area-alloc-pointers area-number) (aref area-origins area-number)))
    )

;  (let ((high-loc (aref area-alloc-bounds (1- (length fsym:initial-area-list)))))
;    (vwrite (+ (get-area-origin 'fsym:system-communication-area) fsym:%sys-com-valid-size)
;	    (vfix high-loc)))
  ;; Set up the area# and region# free lists
  (vwrite (+ (get-area-origin 'fsym:system-communication-area) fsym:%sys-com-free-area/#-list)
	  (vfix (length fsym:initial-area-list)))
  (vwrite (+ (get-area-origin 'fsym:system-communication-area) fsym:%sys-com-free-region/#-list)
	  (vfix (length fsym:initial-area-list)))
  (do i (length fsym:initial-area-list) (1+ i) (= i (1- fsym:number-of-areas))	;all but the last
    (vwrite (+ (get-area-origin 'fsym:region-list-thread) i) (1+ i))
    (vwrite (+ (get-area-origin 'fsym:area-region-list) i) (1+ i)))
  (vwrite (+ (get-area-origin 'fsym:region-list-thread) (1- fsym:number-of-areas)) 0)
  (vwrite (+ (get-area-origin 'fsym:area-region-list) (1- fsym:number-of-areas)) 0)
  ;; Make certain areas look full
  (dolist (area 'fsym:(region-origin region-length region-free-pointer region-gc-pointer
		      region-bits region-list-thread area-name area-region-list 
		      region-moby-bits-array region-namespace-origin region-spare
		      area-region-bits area-region-size
		      region-area-map
		      virtual-page-volatility virtual-page-data
;		      linear-pdl-area linear-bind-pdl-area
		      ))
    (vwrite (+ (get-area-origin 'fsym:region-free-pointer) (get-area-number area))
	    (* (get-area-size area) fsym:page-size)))
  ;; Initialize unused portions of the disk
  (initialize-unused-pages)
  (init-address-space-map)
  ;; Don't bother setting up the PHT and PPD, the microcode will take care of it
  ;; Cold-booting into this band will then do the right thing with it
  (init-area-contents 'fsym:page-table-area (vfix 0))
  ;; Terminate areas which have overlying lists
 ;  (store-nxtnil-cdr-code 'fsym:area-name)
  )

(defun initialize-unused-pages (&aux area address high)
  (dolist (name-of-area (memq 'fsym:extra-pdl-area
			      fsym:initial-area-list)) ;no trash low fixed areas
    (setq area (get-area-number name-of-area)
	  address (aref area-alloc-pointers area)
	  high (aref area-alloc-bounds area))
    ;Page in all the fresh pages without really paging them in, thus initializing them
    (do ((vpn (ceiling address fsym:page-size) (1+ vpn))
	 (hpn (ceiling high fsym:page-size)))
	(( vpn hpn))
      (vmem-find-page (* vpn fsym:page-size) nil))))

(defun init-address-space-map ()
  (or (= fsym:%address-space-map-byte-size 16.)
      (ferror "This code only works for %address-space-map-byte-size = 16."))
  (let ((map (make-array #o4000 :type 'art-16b)) ;Initializes to 0
	(asm (get-area-origin 'fsym:address-space-map))
	(asqs fsym:%address-space-quantum-size))
    (if (not (zerop (logand 1 (// asm fsym:page-size))))
	(ferror "ADDRESS-SPACE-MAP must allocated on an even page number"))
      ;Reason is, Ucode wants to do LDB to compute address instead of add.
    ;For each non-fixed area, find all the address space quanta in the area's initial
    ;region and store them into the map
    (loop for area from (1+ (get-area-number 'fsym:init-list-area))
		   below (length fsym:initial-area-list)
	  unless (and (zerop (\ (aref area-origins area) asqs))
		      (zerop (\ (aref area-alloc-bounds area) asqs)))
	    do (ferror "Area ~A is not an integral number of address space quanta"
		       (nth area fsym:initial-area-list))
	  do (loop for q from (truncate (aref area-origins area) asqs)
			 below (truncate (aref area-alloc-bounds area) asqs)
		   do (aset area map q)))
    ;Now dump this into the cold load
    (loop for i from 0 below #o2000 for j from 0 by 2
	  do (vwrite (+ asm i)
		     (dpb (aref map (+ j 1)) (BYTE 16. 16.)
			  (aref map j))))
    ;cause address-space-map region to appear full so it gets dumped by band dumper.
    (vwrite (+ (get-area-origin 'fsym:region-free-pointer)
	       (get-area-number 'fsym:address-space-map))
	    (* (get-area-size 'fsym:address-space-map) fsym:page-size))))

(defun make-sorted-region-list ()
  (sort (do ((i 0 (1+ i))
	     (al fsym:initial-area-list (cdr al))
	     (l nil))
	    ((null al)
	     (nreverse l))
	  (push (cons (aref area-origins i) i) l))
	#'(lambda (x y)
	    (cond ((= (car x) (car y))		;if one is zero length, it -must- go first
		   (cond
		     ((= (aref area-origins (cdr x)) (aref area-alloc-bounds (cdr x))) t)
		     ((= (aref area-origins (cdr y)) (aref area-alloc-bounds (cdr y))) nil)
		     (t (ferror "2 non-zero-length areas at same address"))))
		  ((< (car x) (car y)))))))

;;;; Driver

(defvar cold-list-area 'fsym:init-list-area
  "Where FROID (COLDLD) puts lists (usually).")
(defvar evals-to-be-sent-over)
(defvar *target-processor*)

;;; User calls this to build a cold-load onto a band
(defun make-cold (part-name &optional (unit-number 0) (processor-type si:processor-type-code))
  (if (numberp part-name) (setq part-name (format nil "LOD~d" part-name)))
  (setq *unit-number* unit-number)
  (setq *target-processor* processor-type)
  (when (si:find-disk-partition-for-write part-name nil *unit-number*)
    (si:update-partition-comment part-name "cold-incomplete" unit-number)
    (SI:REPORT-ELAPSED-TIME T 0 "COLD-LOAD"
      #'(LAMBDA ()
	  (si:report-elapsed-time t 1 "flushing of old state"
	    #'(lambda ()
		(or (boundp 'big-fixnum) (load-parameters))
		;; Flush old state
		(q-atom-head-reset)
		(q-atom-head-reset (pkg-find-package "GLOBAL"))
		(makunbound '*cold-loaded-file-property-lists*)
		(makunbound 'cold-loaded-function-property-lists)
		(setq evals-to-be-sent-over nil)))
	  (unwind-protect (progn (si:report-elapsed-time t 1 "vmem initialize"
				   'vmem-initialize part-name)
				 (si:report-elapsed-time t 1 "cold loading of files"
				   #'make-cold-1
				   (select processor-type
				     (si:lambda-type-code
				      si:lambda-cold-load-file-list)
				     (si:explorer-type-code
				      si:lambda-cold-load-file-list)))
				 (format nil "Boot off the ~A partition on unit ~a to test it."
					 part-name unit-number))
	    (vmem-finish))
	  (si:update-partition-comment
	    part-name
	    (format nil "cold ~A"
		    (let ((date-and-time
			    (with-output-to-string (str)
			      (time:print-current-time str))))
		      (substring date-and-time 0 (string-search-char #/space date-and-time))))
	    unit-number)))))

(defun make-cold-1 (file-list)
  ;; Divide up virtual memory into areas and initialize tables
  (SI:REPORT-ELAPSED-TIME T 3 'ASSIGN-VALUES #'assign-values fsym:initial-area-list 0)
  (si:report-elapsed-time t 3 'create-areas #'create-areas)
  (make-t-and-nil)
  ;; Initialize various fixed areas and really random data tables
  (si:report-elapsed-time t 3 'init-area-contents #'init-area-contents 'fsym:area-name qnil)
  (si:report-elapsed-time t 3 'store-list-of-atoms
    #'store-list-of-atoms 'fsym:area-name fsym:initial-area-list)
  (si:report-elapsed-time t 3 "set up constants page"
    #'(lambda () (mapc #'store-constant fsym:constants-page)))
  (storein-q-value-cell 'fsym:constants-page
			(vmake-pointer fsym:dtp-list (get-area-origin 'fsym:constants-area)))
  (si:report-elapsed-time t 3 'init-scratch-pad-area 'init-scratch-pad-area)
;  (si:report-elapsed-time t 3 'init-system-communication-area 'init-system-communication-area)
  (si:report-elapsed-time t 3 'initialize-certain-variables 'initialize-certain-variables)
  (si:report-elapsed-time t 3 "init more variables"
    #'(lambda ()
	(mapc #'store-lisp-value-list fsym:q-corresponding-variable-lists)
	(mapc #'store-lisp-value-list fsym:sysconf-constant-lists)))
  (si:report-elapsed-time t 3 'init-random-variables 'init-random-variables)
  (si:report-elapsed-time t 3 'store-a-mem-location-names 'store-a-mem-location-names)
  ;A copy of AREA-LIST was previously sent over.  Change it to share with AREA-NAME.
  (storein-q-value-cell 'fsym:initial-area-list
			(vmake-pointer fsym:dtp-list (get-area-origin 'fsym:area-name)))
  ;;Load up all those QFASL files
  (si:report-elapsed-time t 3 "COLD-FASLOAD"
    #'(LAMBDA ()
	(mapc #'cold-fasload file-list)
	;;Don't let list-structure portion of the readtable end up in a read-only area
	(let ((cold-list-area 'fsym:property-list-area))  ;Random list-structured area
	  (cold-fasload "SYS: IO; RDTBL QFASL >")
	  (cold-fasload "SYS: IO; CRDTBL QFASL >"))))
  ;;Translate all pathnames needed before logical pathnames work
  ;;***not needed now that (si:qld) loads sys:sys;inner-system-file-alist which sets these variables.
;  (dolist (sym si:mini-file-alist-list)
;    (cold-load-time-set sym
;      (loop for (file pack) in (symeval sym)
;	 collect (list (cold-translate-pathname file)
;		       pack
;		       (equalp (send (fs:parse-pathname file) :type) "QFASL")))))
 (setq evals-to-be-sent-over (nreverse evals-to-be-sent-over)) ;do in order specified
 (cold-load-time-set 'fsym:lisp-crash-list evals-to-be-sent-over)
; (storein-q-value-cell 'fsym:lisp-crash-list
;		       ;; This MAKE-Q-LIST must not use the FASL-TEMP-AREA,
;		       ;; because the list structure being created includes
;		       ;; definitions of important macros.
;		       (make-q-list
;			 'fsym:init-list-area
;			 evals-to-be-sent-over))
 (setf (aref area-alloc-pointers (get-area-number 'fsym:region-allocation-status))
       (aref area-alloc-bounds (get-area-number 'fsym:region-allocation-status)))
 (si:report-elapsed-time t 3 'q-storage-finalize 'q-storage-finalize))

;(defun cold-translate-pathname (file)
;  #-ti
;  (send (send (fs:merge-pathname-defaults file)
;	      :translated-pathname)
;	:string-for-mini)
;  #+ti
;  (let ((first-semi (string-search-char (char-int #/;) file)))
;    (cond ((and (not (null first-semi))
;		(string-search-char (char-int #/;) file (1+ first-semi)))
;	   (format t "~&What should ~s translate to? (e.g. L.IO.FILE; ACCESS.QFASL#>) ? " file)
;	   (readline))
;	  (t
;	   (send (send (fs:merge-pathname-defaults file)
;		       :translated-pathname)
;		 :string-for-mini)))))
	   

;nil and t must be stored manually since qnil and qtruth would not be bound when needed
(defun make-t-and-nil ()
 ;converted
  (setq qnil (vmake-pointer fsym:dtp-symbol
		      (allocate-block 'fsym:resident-symbol-area fsym:*symbol-size-in-qs*)))
  (vwrite qnil (vmake-pointer fsym:dtp-symbol-header
			      (store-string 'fsym:p-n-string "NIL")))
  (vwrite (+ qnil 1) qnil)
  (vwrite (+ qnil 2) (vmake-pointer fsym:dtp-null qnil))
  (vwrite (+ qnil 3) qnil)
  (vwrite (+ qnil 4) qnil)
  (putprop 'fsym:nil qnil 'q-atom-head)
  (setq qtruth (vmake-pointer fsym:dtp-symbol
		   (allocate-block 'fsym:resident-symbol-area fsym:*symbol-size-in-qs*)))
  (vwrite qtruth (vmake-pointer fsym:dtp-symbol-header
				(store-string 'fsym:p-n-string "T")))
  (vwrite (+ qtruth 1) qtruth)
  (vwrite (+ qtruth 2) (vmake-pointer fsym:dtp-null qtruth))
  (vwrite (+ qtruth 3) qnil)
  (vwrite (+ qtruth 4) qnil)
  (putprop 'fsym:t qtruth 'q-atom-head))

;Fix the values of certain variables before they are sent over
(defun initialize-certain-variables ()
; These are no longer needed since si::defvar-1 of constants is specially recognized in coldld
;  (cold-load-time-set 'fsym:prin1 nil)
;  (cold-load-time-set 'fsym:*read-base* 10.)
;  (cold-load-time-set 'fsym:*print-base* 10.)
  (cold-load-time-set 'fsym:most-positive-fixnum big-fixnum)
  (cold-load-time-set 'fsym:most-negative-fixnum little-fixnum)
  )

;;; Initializations of all sorts of random variables.  Must follow the map
;;; over q-corresponding-variable-lists, because previous initializations are stored over.
(defun init-random-variables ()
  ;;set up array-types symbol (both value and function cells).
  ;;  the function cell is an array which gives maps numeric array type to symbolic name.
  ;;  the value cell is a list pointer into the above array, so is an ordered list
  ;;   of the array types.
  (init-q-array 'fsym:control-tables 'fsym:array-types 2 'fsym:art-q-list '(32.) nil nil)
  (store-list-of-atoms 'fsym:control-tables fsym:array-types)
  (store-nils 'fsym:control-tables (- 32. (length fsym:array-types)))
  (storein-q-value-cell 'fsym:array-types
    (vmake-pointer fsym:dtp-list (- (aref area-alloc-pointers
					 (get-area-number 'fsym:control-tables))
				   32.)))
  ;;set up the array-elements-per-q array.
  (init-q-array 'fsym:control-tables 'fsym:array-elements-per-q 2 ;fcn
		'fsym:art-q-list '(32.) nil nil)
  (store-list-of-atoms 'fsym:control-tables (make-ordered-array-list fsym:array-elements-per-q))
  (store-nils 'fsym:control-tables (- 32. (length fsym:array-types)))
  ;;value cell of array-elements-per-q has assq list, is not same as array.
  ;;set up the array-bits-per-element array, similar
  (init-q-array 'fsym:control-tables 'fsym:array-bits-per-element 2 ;fcn
		'fsym:art-q-list '(32.) nil nil)
  (store-list-of-atoms 'fsym:control-tables
		       (make-ordered-array-list fsym:array-bits-per-element))
  (store-nils 'fsym:control-tables (- 32. (length fsym:array-types)))
  ;; Set up ARRAY-BOXED-WORDS-PER-ELEMENT.
  (init-q-array 'fsym:control-tables 'fsym:array-boxed-words-per-element 2 ;fcn
		'fsym:art-q-list '(32.) nil nil)
  (store-list-of-atoms 'fsym:control-tables
		       (make-ordered-array-list fsym:array-boxed-words-per-element))
  (store-nils 'fsym:control-tables (- 32. (length fsym:array-types)))
  ;;set up q-data-types
;  (init-q-array 'fsym:control-tables 'fsym:q-data-types 2 'fsym:art-q-list '(32.) nil 
;		(list (make-q-list
;			'fsym:init-list-area
;			(length fsym:q-data-types))))
;  (store-list-of-atoms 'fsym:control-tables fsym:q-data-types)
;  (store-nils 'fsym:control-tables (- 32. (length fsym:q-data-types)))
;  (storein-q-value-cell 'fsym:q-data-types
;    (vmake-pointer fsym:dtp-list (- (aref area-alloc-pointers
;					 (get-area-number 'fsym:control-tables))
;				   32.)))
  )