;;; PHONEY -*-LISP-*- MACHINE MICROCODE

;LISP MACHINE Q'S ARE REPRESENTED AS MACLISP FIXNUMS, CONTAINING
;THE SAME FIELDS.  EXCEPT, -1 MEANS PAGE INACCESSIBLE, AND AT SOME
;LEVELS -2 MEANS IN PDL BUFFER.

(DECLARE (FIXNUM ADR VADR PADR HASH LEN HASH1 DATA I J K M N Q MUM PHT-ADR SIZE-OF-PAGE-TABLE))


(INCLUDE |LMDOC;.COMPL PRELUD|);DEFINE DEFMACRO, `, LET, ETC.
(IF-FOR-MACLISP (INCLUDE |LMCONS;QFMAC >|))

;IN THIS FILE, ONLY FIXNUM VERSIONS OF LOGLDB, LOGDPB USED.
(IF-FOR-MACLISP
(DEFUN LOGLDB MACRO (X)
  (RPLACA X 'LOGLDB-FROM-FIXNUM))
)

(IF-FOR-MACLISP
(DEFUN LOGDPB MACRO (X)
  (RPLACA X 'LOGDPB-INTO-FIXNUM))
)

;ROUTINES FROM CC FOR HACKING MICRO MACHINE

;(DECLARE (FIXNUM (CC-REGISTER-EXAMINE FIXNUM))	;NOT DECLARED FIXNUM WHEN COMPILED
;	 (FIXNUM (CC-REGISTER-DEPOSIT FIXNUM FIXNUM))
;	 (FIXNUM (CC-SYMBOLIC-EXAMINE-REGISTER NOTYPE)))

;;; MEMORY INTERFACE AND PAGING STUFF

(DECLARE (FIXNUM (CNSPMR FIXNUM))	;PHYSICAL MEMORY READ
	 (FIXNUM (CNSPMW FIXNUM FIXNUM)) ;PHYSICAL MEMORY WRITE
	 (FIXNUM (QF-VIRTUAL-MEM-READ FIXNUM))
	 (FIXNUM (QF-VIRTUAL-MEM-WRITE FIXNUM FIXNUM))
	 (FIXNUM (QF-VIRTUAL-MEM-MAP FIXNUM NOTYPE)) ;GIVEN VMA RETURNS PMA 
						;OR -1 FOR INACCESSIBLE 
						;OR -2 FOR IN PDL BUFFER.
						;SECOND ARG IS T IF WRITE CYCLE IS INTENDED
	 (FIXNUM (QF-PAGE-HASH-TABLE-LOOKUP FIXNUM))  ;GIVEN VMA, RETURNS PHYS ADR OF PHT1
						      ; ENTRY OR -1 FOR NOT FOUND.
	 (NOTYPE (QF-PAGE-HASH-TABLE-DELETE FIXNUM FIXNUM))  ;GIVEN VMA, DELETE IT FROM HASH
						;TABLE, READJUSTING THINGS AS NECC.
						;RETURN T IF DELETED, NIL IF NOT FOUND
	 (FIXNUM (QF-COMPUTE-PAGE-HASH FIXNUM)) ;GIVEN VMA, RETURN INITIAL HASH ADR RELATIVE
						;TO HASH TABLE ORIGIN.
	 (FIXNUM (QF-FINDCORE))			;CALL TO OBTAIN A FREE CORE PAGE IN CONS.
						; SWAPS ONE OUT IF NECC, ADJUSTING HASH
						; TBL, REAL MACHINE'S MAP, ETC.  RETURNS
						; PHYSICAL PAGE NUMBER.
	 (NOTYPE (QF-SWAP-IN FIXNUM))		;DO EVERYTHING NEEDED TO BE SWAPPED IN
	 (FIXNUM (QF-VIRTUAL-MEM-PDL-BUF-ADR FIXNUM))
	 (FIXNUM (QF-MEM-READ FIXNUM))		;BARF IF INACCESSIBLE
	 (FIXNUM (QF-MEM-WRITE FIXNUM FIXNUM)))	;..

(DECLARE (SPECIAL 
;		  QF-VIRTUAL-ADDR-KNOWN-ADDR QF-VIRTUAL-ADDR-KNOWN-MAP
;		  QF-VIRTUAL-ADDR-KNOWN-PHT1 QF-VIRTUAL-ADDR-KNOWN-PHT2 
		  QF-AREA-ORIGIN-CACHE 
		  QF-SWAP-IN-LOOP-CHECK QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG))
(SETQ QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG NIL)

(DEFUN QF-CLEAR-CACHE (EVERYTHINGP)	;CALL ON START UP AND WHENEVER MACHINE HAS BEEN RUN
					;ARG IS T ON START UP AND AFTER COLD LOAD
  (COND (EVERYTHINGP
	 (SETQ QF-AREA-ORIGIN-CACHE NIL)
	 (REMPROP 'QF-HASH-RELOAD-POINTER 'QF-HASH-RELOAD-POINTER)
	 (ALLREMPROP 'REAL-MACHINE-ATOM-HEADER-POINTER)
	 (ALLREMPROP 'REAL-MACHINE-PACKAGE-POINTER)
	 ))
;  (SETQ QF-VIRTUAL-ADDR-KNOWN-ADDR -1) ;CAN'T USE NIL, IS TESTED WITH =
)

(DECLARE (SPECIAL PHT-ADDR SIZE-OF-PAGE-TABLE))
(SETQ PHT-ADDR 1600)

(DEFUN QF-VIRTUAL-MEM-READ (VADR)
  ((LAMBDA (PADR)
	(COND ((= PADR -1) PADR)	;INACCESSIBLE
	      ((= PADR -2)		;IN PDL BUFFER
	       (CC-REGISTER-EXAMINE (QF-VIRTUAL-MEM-PDL-BUF-ADR VADR)))
	      ((CNSPMR PADR))))
   (QF-VIRTUAL-MEM-MAP VADR NIL)))

(DEFUN QF-VIRTUAL-MEM-WRITE (VADR DATA)		;NOTE DOESN'T RESPECT READ ONLY, RWF
  ((LAMBDA (PADR)
	(COND ((= PADR -1) PADR)	;INACCESSIBLE
	      ((= PADR -2)		;IN PDL BUFFER
	       (CC-REGISTER-DEPOSIT (QF-VIRTUAL-MEM-PDL-BUF-ADR VADR) DATA))
	      ((CNSPMW PADR DATA))))
   (QF-VIRTUAL-MEM-MAP VADR T)))

(DEFUN QF-VIRTUAL-MEM-PDL-BUF-ADR (ADR)
  (+ RAPBO
     (LOGAND 1777
	     (+ (- ADR (CC-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-VIRTUAL-ADDRESS))
	        (CC-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-HEAD)))))

(DEFUN QF-PAGE-HASH-TABLE-LOOKUP (ADR)	;RETURNS -1 OR PHYSICAL MEM ADR OF PHT1 WD
 (SETQ ADR (QF-POINTER ADR))		; OF HASH-TBL ENTRY FOR ADR
 (COND ((NOT (= 0 (LOGAND ADR 40000000)))
	(ERROR ADR 'VIRTUAL-ADDRESS-HAS-HIGH-BIT-SET 'FAIL-ACT)))
 (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2))
      (HASH (LOGXOR (LSH ADR -13.) (LOGAND 777774 (LSH ADR -5))) (+ HASH 2))
      (PHT1)
      (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)))
     ((= COUNT 0) -1)     ;INACESSIBLE (SHOULD NEVER HAPPEN, BUT AT LEAST DONT GET
			  ; INTO INFINITE LOOP IF HASH TABLE GETS OVER-FULL)
   (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT))
   (SETQ HASH (LOGAND HASH PHT-MASK))
   (SETQ PHT1 (CNSPMR (+ PHT-ADDR HASH)))
   (COND ((= 0 (LOGAND 100 PHT1))	;NO VALID BIT
	    (RETURN -1))		;NOT FOUND
         ((= 0 (LOGAND 77777600 (LOGXOR ADR PHT1)))  ;ADDRESS MATCH
	    (RETURN (+ PHT-ADDR HASH))))))	;FOUND IT

(DEFUN QF-PAGE-HASH-TABLE-DELETE (ADR HOLE-POINTER)
  (PROG (LEAD-POINTER LEAD-POINTER-HASH-ADR LEAD-POINTER-VIRT-ADR
	 LIM PHT1 MOVED-POINTER)
	(DECLARE (FIXNUM LEAD-POINTER LEAD-POINTER-HASH-ADR LEAD-POINTER-VIRT-ADR 
			 LIM PHT1 MOVED-POINTER))
	(SETQ LIM (+ PHT-ADDR SIZE-OF-PAGE-TABLE -2))		;POINTS TO LAST VALID ENTRY
   L1	(CNSPMW HOLE-POINTER (QF-MAKE-Q 0 DTP-FIX))		;FLUSH GUY FROM TABLE
	(SETQ LEAD-POINTER HOLE-POINTER)
   L2	(SETQ LEAD-POINTER (COND ((< LEAD-POINTER LIM) (+ LEAD-POINTER 2))
	 			 (T PHT-ADDR)))
	(SETQ PHT1 (CNSPMR LEAD-POINTER))
	(COND ((= 0 (LOGAND 100 PHT1))
	       (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T))
	       (AND (= 0 (CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T))
	       (PRINT (LIST 'QF-PAGE-HASH-TABLE-DELETE-SCREW ADR LEAD-POINTER HOLE-POINTER
			    MOVED-POINTER))
	       (BREAK 'QF-PAGE-HASH-TABLE-DELETE-SCREW T)
	       (RETURN T)))				;BLANK ENTRY, THROUGH
	(SETQ LEAD-POINTER-VIRT-ADR (LOGAND PHT1 77777600))
	(SETQ LEAD-POINTER-HASH-ADR
	      (COND ((NOT (= LEAD-POINTER-VIRT-ADR 77777600))
		     (+ PHT-ADDR (QF-COMPUTE-PAGE-HASH LEAD-POINTER-VIRT-ADR)))
		    (T HOLE-POINTER)))			;DUMMY ALWAYS HASHES TO HOLE ADDR
	(COND ((< LEAD-POINTER LEAD-POINTER-HASH-ADR) (GO L4))) ;WRAPAROUND CASE
	(COND ((OR (> LEAD-POINTER-HASH-ADR HOLE-POINTER)
		   (< LEAD-POINTER HOLE-POINTER))
	       (GO L2)))				;JUMP IF SHOULDN'T BE WHERE HOLE IS
   L6	(CNSPMW HOLE-POINTER PHT1)			;SHOULD BE WHERE HOLE IS, MOVE IT 
	(CNSPMW (1+ HOLE-POINTER) (CNSPMR (1+ LEAD-POINTER)))
	(SETQ MOVED-POINTER HOLE-POINTER)		;FOR DEBUGGING, WHERE THING MOVED TO
	(SETQ HOLE-POINTER LEAD-POINTER)
	(GO L1)
   L4	(COND ((OR (<= LEAD-POINTER-HASH-ADR HOLE-POINTER)
		   (>= LEAD-POINTER HOLE-POINTER))
	       (GO L6)))				;JUMP IF SHOULD BE WHERE HOLE IS
	(GO L2)
))

(DEFUN QF-COMPUTE-PAGE-HASH (ADR)	;***LOOK AT THIS WHEN ADR S CAN REALLY BE 24. BITS
    (LOGAND (- SIZE-OF-PAGE-TABLE 2)
	    (LOGXOR (LSH ADR -13.) (LOGAND 777774 (LSH ADR -5)))))

(DEFUN QF-VIRTUAL-MEM-MAP (ADR WRITE-CYCLE)
 (SETQ ADR (QF-POINTER ADR))		;FLUSH DATA TYPE ETC.
 (COND ((NOT (= 0 (LOGAND ADR 40000000)))
	(ERROR ADR 'VIRTUAL-ADDRESS-HAS-HIGH-BIT-SET 'FAIL-ACT)))
; (COND ((AND (= ADR QF-VIRTUAL-ADDR-KNOWN-ADDR)
;	     (OR (NULL WRITE-CYCLE)
;		 (NOT (< (LOGLDB %%PHT2-MAP-STATUS-CODE QF-VIRTUAL-ADDR-KNOWN-PHT2) 4))))
;	  QF-VIRTUAL-ADDR-KNOWN-MAP) ;IN CACHE
;       (T
;	(SETQ QF-VIRTUAL-ADDR-KNOWN-MAP    )))
	 (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2))
	      (HASH (LOGXOR (LSH ADR -13.) (LOGAND 777774 (LSH ADR -5))) (+ HASH 2))
	      (PHT1)
	      (PHT2)
	      (TEM)
	      (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)))
	     ((= COUNT 0) -1)	;INACCESSIBLE
	  (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT TEM))
	  (SETQ HASH (LOGAND HASH PHT-MASK))
	  (SETQ PHT1 (CNSPMR (+ PHT-ADDR HASH)))
	  (COND ((= 0 (LOGAND 100 PHT1))	;NO VALID BIT
		 (RETURN -1))			;INACCESSIBLE
	        ((= 0 (LOGAND 77777600 (LOGXOR ADR PHT1))) ;ADDRESS MATCH
		 (SETQ PHT1 (LOGAND 7 PHT1)) ;ISOLATE SWAP STATUS CODE
		 (COND ((OR (= PHT1 0)	  ;UNUSED ENTRY
			    (= PHT1 3)	  ;UNUSED CODES
			    (= PHT1 6)
			    (= PHT1 7))
			(ERROR 'BAD-PAGE-HASH-ENTRY-AT-ADR HASH 'FAIL-ACT)))
		 (SETQ PHT2 (CNSPMR (+ PHT-ADDR HASH 1)))	;IN CORE, GET ADDRESS
		 (COND ((AND (= 5 (LOGLDB %%PHT2-MAP-STATUS-CODE PHT2))  ;MAY BE IN PDL-BUFFER
			     (NOT (< ADR (SETQ TEM (QF-POINTER
				(CC-SYMBOLIC-EXAMINE-REGISTER 
					'A-PDL-BUFFER-VIRTUAL-ADDRESS)))))
			    (< ADR (+ TEM (CC-SYMBOLIC-EXAMINE-REGISTER 'PP))))
			(RETURN -2)))	;IN PDL-BUFFER
;IF DOING A WRITE-CYCLE INTO A PAGE W/O WRITE-ACCESS, CHANGE ACCESS TO R/W.
;THIS HOPEFULLY ASSURES PAGE WILL GET WRITTEN ON DISK IF IT GETS SWAPPED OUT.
		 (COND ((AND WRITE-CYCLE (< (LOGLDB %%PHT2-MAP-STATUS-CODE PHT2) 4))
			(CNSPMW (+ PHT-ADDR HASH 1) 
				(LOGDPB 4 %%PHT2-MAP-STATUS-CODE PHT2))))
		 (RETURN (+ (LOGAND 77777600 PHT2)
			    (LOGAND 177 ADR))))))  ;()
;	(SETQ QF-VIRTUAL-ADDR-KNOWN-ADDR ADR)
;	QF-VIRTUAL-ADDR-KNOWN-MAP  (())
)

(DEFUN QF-FINDCORE NIL	;CALL TO OBTAIN FREE PAGE OF CONS MEMORY. SWAP ONE OUT IF NECC, ETC.
  (DECLARE (FIXNUM PTR LIM PHT1 PHT2 TEM))
  (PROG (PTR LIM PHT1 PHT2 TEM FLAG)
	(SETQ LIM (+ PHT-ADDR SIZE-OF-PAGE-TABLE -2))	;POINTS AT HIGHEST ENTRY
	(SETQ PTR PHT-ADDR)		;LOOK FOR FLUSHABLE FROB FIRST
   L1	(SETQ PHT1 (CNSPMR PTR))
	(SETQ TEM (LOGLDB %%PHT1-SWAP-STATUS-CODE PHT1))	;SWAP STATUS
	(COND ((= TEM %PHT-SWAP-STATUS-FLUSHABLE) (GO CF)))	;FLUSHABLE
	(COND ((NOT (= PTR LIM)) (SETQ PTR (+ 2 PTR)) (GO L1)))
	(SETQ PTR (COND ((GET 'QF-HASH-RELOAD-POINTER 'QF-HASH-RELOAD-POINTER))
		        (T PHT-ADDR)))	;FLUSH SOMETHING RANDOM
   L2	(SETQ PHT1 (CNSPMR PTR))
	(SETQ TEM (LOGLDB %%PHT1-SWAP-STATUS-CODE PHT1))
	(COND ((OR (= TEM %PHT-SWAP-STATUS-NORMAL)
		   (= TEM %PHT-SWAP-STATUS-AGE-TRAP))
	       (GO CF)))
	(COND ((= PTR LIM)
	       (COND (FLAG (ERROR 'QF-FINDCORE 'NOTHING-TO-SWAP-OUT 'FAIL-ACT))
		     (T (SETQ FLAG T)
			(SETQ PTR PHT-ADDR))))
	      (T (SETQ PTR (+ 2 PTR))))
	(GO L2)
   CF	(PUTPROP 'QF-HASH-RELOAD-POINTER PTR 'QF-HASH-RELOAD-POINTER)
	(SETQ PHT2 (CNSPMR (1+ PTR)))
	(SETQ TEM (LOGLDB %%PHT2-MAP-STATUS-CODE PHT2))
	(COND ((= TEM %PHT-MAP-STATUS-READ-WRITE)
	       (CC-DISK-WRITE (LOGLDB %%PHT1-VIRTUAL-PAGE-NUMBER PHT1) 
			      (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2)
			      1)))	;NUMBER PAGES
	(COND ((NULL (QF-PAGE-HASH-TABLE-DELETE (LOGAND 77777600 PHT1) PTR))
	       (ERROR 'QF-FINDCORE 'HASH-SCREWUP 'FAIL-ACT)))	
	;DELETE FROM REAL MACHINE'S MAP
	(COND ((= (SETQ TEM (CC-REGISTER-EXAMINE (+ RAM1O (LOGLDB 1413 PHT1))))
		   37)
		(GO X)))	;LVL 1 MAP NOT SET, OK
	(SETQ TEM (+ (LSH TEM 5)
		     (LOGLDB 0705 PHT1)
		     RAM2O))
;	(SETQ TEM (+ (LSH (CC-REGISTER-EXAMINE (+ RAM1O (LOGLDB 1413 PHT1))) 5)	;LEVEL 1 MAP
;		     (LOGLDB 0705 PHT1)			;GET LEVEL 2 MAP ADDRESS
;		     RAM2O))
	(OR (> 1 (LOGLDB 2003 (CC-REGISTER-EXAMINE TEM)))	;IF LEVEL 2 MAP SET UP,
	    (CC-REGISTER-DEPOSIT TEM 1_16.))		; CHANGE TO LEVEL 2 MAP NOT SET UP
    X	(RETURN (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2))
))

(SETQ QF-SWAP-IN-LOOP-CHECK NIL)

;SWAP IN PAGE AT ADR
(DEFUN QF-SWAP-IN (ADR)
  (SETQ ADR (QF-POINTER ADR))				;FLUSH DATA TYPE ETC.
  (COND ((NOT (= 0 (LOGAND ADR 40000000)))
	 (ERROR ADR 'VIRTUAL-ADDRESS-HAS-HIGH-BIT-SET 'FAIL-ACT)))
  (AND QF-SWAP-IN-LOOP-CHECK
       (ERROR ADR '|QF-SWAP-IN INVOKED RECURSIVELY| 'FAIL-ACT))
  (OR (< (QF-PAGE-HASH-TABLE-LOOKUP ADR) 0)
      (ERROR ADR '|ALREADY SWAPPED IN - QF-SWAP-IN| 'FAIL-ACT))
  (PROG (PHYS-PAGE AREA-NUMBER ACCESS-STATUS-AND-META-BITS QF-SWAP-IN-LOOP-CHECK)
    (DECLARE (FIXNUM PHYS-PAGE AREA-NUMBER ACCESS-STATUS-AND-META-BITS))
    (SETQ QF-SWAP-IN-LOOP-CHECK T)
    (SETQ AREA-NUMBER (QF-AREA-NUMBER-OF-POINTER ADR))
    (SETQ ACCESS-STATUS-AND-META-BITS (LOGLDB %%AREA-MODE-ACCESS-STATUS-AND-META-BITS
					      (CNSPMR (+ AREA-NUMBER
							 (QF-INITIAL-AREA-ORIGIN 
								'AREA-MODE-BITS)))))
    (SETQ PHYS-PAGE (QF-FINDCORE))
    (CC-DISK-READ (LOGLDB %%PHT1-VIRTUAL-PAGE-NUMBER ADR)
		  PHYS-PAGE
		  1)
    (QF-MEM-WRITE (+ PHYS-PAGE (QF-INITIAL-AREA-ORIGIN 'PHYSICAL-PAGE-AREA-NUMBER))
		  (QF-MAKE-Q AREA-NUMBER DTP-FIX))
    (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2))
	 (HASH (LOGXOR (LSH ADR -13.) (LOGAND 777774 (LSH ADR -5))) (+ HASH 2))
	 (PHT1)
	 (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)))
	((= COUNT 0)
	 (ERROR 'QF-SWAP-IN 'PAGE-HASH-TABLE-FULL 'FAIL-ACT)) ;UGH FINDCORE SHOULD HAVE DELETED
      (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT))
      (SETQ HASH (LOGAND HASH PHT-MASK))
      (SETQ PHT1 (CNSPMR (+ PHT-ADDR HASH)))
      (COND ((= 0 (LOGAND 100 PHT1))			;FOUND HOLE TO PUT NEW PHTE IN
	     (CNSPMW (+ PHT-ADDR HASH)
		     (QF-MAKE-Q (+ 101 (LOGAND ADR 77777600)) DTP-FIX))
	     (CNSPMW (+ PHT-ADDR HASH 1)
		     (QF-MAKE-Q (LOGDPB PHYS-PAGE %%PHT2-PHYSICAL-PAGE-NUMBER
					ACCESS-STATUS-AND-META-BITS)
				DTP-FIX))
	     (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T))
	     (AND (= 0 (CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T))
	     (PRINT (LIST 'QF-SWAP-IN-SCREW ADR HASH COUNT))
	     (BREAK 'QF-SWAP-IN-SCREW T)
	     (RETURN T)))))
;  (SETQ QF-VIRTUAL-ADDR-KNOWN-ADDR -1)			;FORGET OUR COPY OF THE MAP
)

;THIS READS ANY KIND OF MEMORY WHETHER OR NOT IT IS SWAPPED OUT
(DEFUN QF-MEM-READ (ADR)
  (PROG (DATA)
    (DECLARE (FIXNUM DATA))
    (SETQ DATA (QF-VIRTUAL-MEM-READ ADR))
    (COND ((< DATA 0)
	   (QF-SWAP-IN ADR)
	   (SETQ DATA (QF-VIRTUAL-MEM-READ ADR))))
    (AND (< DATA 0)
	 (ERROR 'QF-MEM-READ-INACCESSIBLE ADR 'FAIL-ACT))
    (RETURN DATA)))

(DEFUN QF-MEM-WRITE (ADR DATA)
  (COND ((< (QF-VIRTUAL-MEM-WRITE ADR DATA) 0)
	 (QF-SWAP-IN ADR)
	 (AND (< (QF-VIRTUAL-MEM-WRITE ADR DATA) 0)
	      (ERROR 'QF-MEM-WRITE-INACCESSIBLE ADR 'FAIL-ACT)))))

;GIVEN A POINTER RETURN THE NUMBER OF THE AREA IT IS IN
;LIKE %AREA-NUMBER ON THE REAL MACHINE

(DEFUN QF-AREA-NUMBER-OF-POINTER (PNTR)
  (SETQ PNTR (QF-POINTER PNTR))
  (PROG (BOTLIM TOPLIM NAREAS LBOUND HRANGE LOC LEN AREA AREA-ORIGIN TEM)
    (DECLARE (FIXNUM BOTLIM TOPLIM NAREAS LBOUND HRANGE LOC LEN AREA AREA-ORIGIN TEM))
    (SETQ BOTLIM (QF-INITIAL-AREA-ORIGIN 'AREA-SORTED-BY-ORIGIN)
	  NAREAS (QF-POINTER (CNSPMR (+ 200 %SYS-COM-/#-AREAS)))
	  TOPLIM (+ BOTLIM NAREAS)
	  LBOUND BOTLIM
	  HRANGE NAREAS
	  AREA-ORIGIN (QF-INITIAL-AREA-ORIGIN 'AREA-ORIGIN))
 T0 (AND (= HRANGE 1) (GO T2))				;MOVING DOWN AND RANGE = 1 => DONE
 T1 (SETQ HRANGE (// (1+ HRANGE) 2))			;HALVE THE RANGE
    (SETQ TEM (+ LBOUND HRANGE))			;ADDRESS TO PROBE
    (OR (< TEM TOPLIM) (GO T0))				;RUNNING OFF TOP MOVE DOWN
    (SETQ LOC (QF-POINTER (CNSPMR (+ AREA-ORIGIN (QF-POINTER (CNSPMR TEM)))))) ;ORIGIN OF POSSIBLE AREA
    (AND (< PNTR LOC) (GO T0))				;MOVE DOWN
    (SETQ LBOUND TEM)
    (GO T1)						;MOVE UP

 T2 (SETQ AREA (QF-POINTER (CNSPMR LBOUND)))		;GET PROPER AREA NUMBER
    (SETQ LOC (QF-POINTER (CNSPMR (+ AREA-ORIGIN AREA))))	;GET ITS ORIGIN
    (AND (> LOC PNTR) (GO LOS))
    (SETQ LEN (QF-POINTER (CNSPMR (+ (QF-INITIAL-AREA-ORIGIN 'AREA-LENGTH) AREA))))
    (AND (< PNTR (+ LOC LEN))
	 (RETURN AREA))
    (OR (= LEN 0) (GO LOS))
    (SETQ LBOUND (1+ LBOUND))				;ZERO LENGTH AREA TRY NEXT
    (GO T1)

LOS (ERROR PNTR '|NOT IN ANY AREA - QF-AREA-NUMBER-OF-POINTER| 'FAIL-ACT) ))

;;; OBARRAY STUFF

;MACLISP SYMBOL IN, LISP MACHINE SYMBOL (Q AS FIXNUM) OUT
;RETURNS -1 IF SYMBOL NOT ON OBARRAY
(DEFUN QF-SYMBOL (MACLISP-SYMBOL)
  (LET ((TEM NIL) (EXP NIL))
    (COND ((GET MACLISP-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER))
	  ((SETQ TEM (MEMQ '/: (SETQ EXP (EXPLODE MACLISP-SYMBOL))))
	   (QF-SYMBOL-INTERNAL (IMPLODE (CDR TEM))
			       (QF-FIND-PACKAGE (IMPLODE (LDIFF EXP TEM)))
			       MACLISP-SYMBOL))
	  (T (QF-SYMBOL-INTERNAL MACLISP-SYMBOL
				 (CNSPMR (+ 200 %SYS-COM-OBARRAY-PNTR))
				 MACLISP-SYMBOL)))))

(DEFUN LDIFF (A B)
    (DO ((A A (CDR A))
	 (ANS))
	((EQ A B) (NREVERSE ANS))
      (SETQ ANS (CONS (CAR A) ANS))))

(DEFUN QF-SYMBOL1 (MACLISP-SYMBOL PACKAGE)
    (COND ((GET MACLISP-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER))
	  (T (QF-SYMBOL-INTERNAL MACLISP-SYMBOL PACKAGE MACLISP-SYMBOL))))

(DEFUN QF-SYMBOL-INTERNAL (PNAME PACKAGE MACLISP-SYMBOL)
  (DECLARE (FIXNUM PACKAGE))
  (COND ((= (QF-DATA-TYPE PACKAGE) DTP-SYMBOL)
	 (SETQ PACKAGE (QF-VALUE-CELL-CONTENTS PACKAGE))))
  (COND ((QF-OBARRAY-NEW-P PACKAGE)
	 (QF-SYMBOL-SEARCH PNAME PACKAGE MACLISP-SYMBOL))
	(T (QF-SYMBOL-OLD PNAME PACKAGE))))

(DEFUN QF-OBARRAY-NEW-P (PACKAGE)
  (QF-ARRAY-SETUP PACKAGE)
  (= QF-ARRAY-NUMBER-DIMS 2))

(DEFMACRO QF-PKG-SUPER-PACKAGE (PACKAGE)
    `(QF-ARRAY-LEADER ,PACKAGE 4))

(DEFMACRO QF-PKG-REFNAME-ALIST (PACKAGE)
    `(QF-ARRAY-LEADER ,PACKAGE 0))

;SEARCH A SPECIFIED PACKAGE AND ITS SUPERIORS FOR A SYMBOL.
(DEFUN QF-SYMBOL-SEARCH (SYM PACKAGE MACLISP-SYMBOL)
    (DO ((PKG PACKAGE (QF-PKG-SUPER-PACKAGE PKG))
	 (TEM))
	((QF-NULL PKG) -1)
       (SETQ TEM (QF-SYMBOL-PKG SYM PKG MACLISP-SYMBOL))
       (OR (= TEM -1) (RETURN TEM))))

;LOOK A SYMBOL UP IN A NEW-STYLE OBARRAY.
(DEFUN QF-SYMBOL-PKG (SYM PACKAGE MACLISP-SYMBOL)
    (DECLARE (FIXNUM PACKAGE))
    (LET ((HASH (QF-PKG-HASH-STRING SYM))
	  (LEN (// (QF-ARRAY-LENGTH PACKAGE)
		   (QF-ARRAY-DIMENSION-N 1 PACKAGE)))
	  (HASH1 0))
	 (DO I (\ HASH LEN) (\ (1+ I) LEN) NIL
	     (SETQ HASH1 (QF-AR-2 PACKAGE 0 I))
	     (AND (QF-NULL HASH1) (RETURN -1))
	     (AND (= HASH (QF-POINTER HASH1))
		  (QF-SAMEPNAMEP SYM (QF-AR-2 PACKAGE 1 I))
		  (RETURN
		   (PUTPROP
		    MACLISP-SYMBOL
		    (QF-AR-2 PACKAGE 1 I)
		    'REAL-MACHINE-ATOM-HEADER-POINTER))))))

(DEFUN QF-FIND-PACKAGE (MSYMBOL)
    (COND ((GET MSYMBOL 'REAL-MACHINE-PACKAGE-POINTER))
	  (T
	   (LET ((PACKAGE (CNSPMR (+ 200 %SYS-COM-OBARRAY-PNTR))))
	     (COND ((= (QF-DATA-TYPE PACKAGE) DTP-SYMBOL)
		    (SETQ PACKAGE (QF-VALUE-CELL-CONTENTS PACKAGE))))
	     (DO ((P (QF-PKG-SUPER-PACKAGE PACKAGE) (QF-PKG-SUPER-PACKAGE P)))
		 ((NOT (= (QF-DATA-TYPE P) DTP-ARRAY-POINTER)))
	       (SETQ PACKAGE P))
	     (DO ((R-ALIST (QF-PKG-REFNAME-ALIST PACKAGE) (QF-CDR R-ALIST))
		  (THIS-CONS))
		 ((QF-NULL R-ALIST) -1)
	       (SETQ THIS-CONS (QF-CAR R-ALIST))
	       (COND ((QF-LMSTRING-MSYMBOL-EQUAL (QF-CAR THIS-CONS) MSYMBOL)
		      (LET ((ANSWER (QF-CAR (QF-CDR THIS-CONS))))
			(PUTPROP MSYMBOL ANSWER 'REAL-MACHINE-PACKAGE-POINTER)
			(RETURN ANSWER)))))))))

;TAKE A MACLISP SYMBOL AND FIGURE OUT WHAT PKG-HASH-STRING WOULD DO
;WITH A SYMBOL OF THAT NAME.
(DEFUN QF-PKG-HASH-STRING (SYM)
    (DECLARE (FIXNUM CHAR HASH I))
    (QF-POINTER (DO ((I 1 (1+ I))
		     (HASH 0)
		     (CHAR 0))
		    ((= 0 (SETQ CHAR (GETCHARN SYM I)))
		     (COND ((BIT-TEST 40000000 HASH)
			    (LOGXOR HASH 40000001))	;-37777777 = 40000001
			   (T HASH)))
		  (SETQ HASH (QF-ROT-24-BIT (LOGXOR HASH CHAR) 7)))))

;24-BIT ROTATE FUNCTION
(DEFUN QF-ROT-24-BIT (WORD AMT)
  (LOGIOR (LOGLDB (+ AMT (LSH (- 24. AMT) 6)) WORD)
	  (LSH (LOGLDB (- 24. AMT) WORD) AMT)))

;SEARCH OLD-STYLE BUCKET-LIST OBARRAY
(DEFUN QF-SYMBOL-OLD (TEM OBARRAYP)
    (DECLARE (FIXNUM OBARRAYP HASH))
    (LET ((HASH (QF-SXHASH TEM))
	  (OBSCURE NIL))
       (SETQ OBSCURE (LOGLDB %%ARRAY-INDEX-LENGTH-IF-SHORT (QF-MEM-READ OBARRAYP)))
       (SETQ OBARRAYP (+ 1 (\ HASH OBSCURE) OBARRAYP))	 ;ASSUME 1 DIMENSIONAL, SHORT, ETC.
       (DO ((BUCKET (QF-MEM-READ OBARRAYP) (QF-CDR BUCKET)))
	   ((NOT (= (QF-DATA-TYPE BUCKET) DTP-LIST))
	    (RETURN -1))
	 (DECLARE (FIXNUM BUCKET))
	 (AND (QF-SAMEPNAMEP TEM
		   (SETQ OBSCURE (QF-MEM-READ BUCKET))) ;CAR
	      (RETURN (PUTPROP TEM 
			      (QF-TYPED-POINTER OBSCURE) 
			      'REAL-MACHINE-ATOM-HEADER-POINTER))) ) ))

;TAKES A STRING ALREADY IN LISP MACHINE AND INTERNS SYMBOL WITH THAT PNAME.
;IF YOU WANT TO KNOW WHETHER A NEW SYMBOL WAS MADE, CHECK EQ-NESS OF PNAME CELL.
;DOESN'T WIN FOR FUNNY CHARACTERS IN STRING.
;IF SYM IS PROVIDED, IT SHOULD BE A MACLISP SYMBOL;
;WE WILL SAVE TIME BY HASHING IT INSTEAD OF THE LM STRING.
(DEFUN QF-LM-STRING-INTERN (STRING OBARRAYP SYM)
 (DECLARE (FIXNUM STRING STRINGLEN OBARRAYP HASH BUCKET TEM))
 (LET ((STRINGLEN (QF-ARRAY-ACTIVE-LENGTH STRING)))
  (COND ((= (QF-DATA-TYPE OBARRAYP) DTP-SYMBOL)
	 (SETQ OBARRAYP (QF-VALUE-CELL-CONTENTS OBARRAYP))))
  (COND ((QF-OBARRAY-NEW-P OBARRAYP)
	 (LET ((HASH (COND (SYM (QF-PKG-HASH-STRING SYM))
			   (T (QF-PKG-HASH-LM-STRING STRING))))
	       (HASH1 0)
	       (LEN (// (QF-ARRAY-LENGTH OBARRAYP)
			(QF-ARRAY-DIMENSION-N 1 OBARRAYP))))
	      (DO I (\ HASH LEN) (\ (1+ I) LEN) NIL
		  (SETQ HASH1 (QF-AR-2 OBARRAYP 0 I))
		  (AND (QF-NULL HASH1)
		       (SETQ STRING (QF-LM-STRING-INTO-SYMBOL STRING))
		       (QF-AS-2 (QF-MAKE-Q HASH DTP-FIX) OBARRAYP 0 I)
		       (QF-AS-2 STRING OBARRAYP 1 I)
		       (RETURN STRING))
		  (AND (= HASH (QF-POINTER HASH1))
		       (QF-LM-STRING-EQUAL
			  (QF-MEM-READ (+ 3 (QF-AR-2 OBARRAYP 1 I)))
			  STRING STRINGLEN)
		       (RETURN (QF-AR-2 OBARRAYP 1 I))))))
	(T
	 (LET ((HASH (QF-LM-STRING-SXHASH STRING))
	       (BUCKET-HEAD-ADDR 0))
	      (SETQ BUCKET-HEAD-ADDR
		    (+ OBARRAYP 1
		       (\ HASH (LOGLDB %%ARRAY-INDEX-LENGTH-IF-SHORT
				       (QF-MEM-READ OBARRAYP)))))
	      (DO ((BUCKET (QF-MEM-READ BUCKET-HEAD-ADDR) (QF-CDR BUCKET))
		   (TEM))
		  ((NOT (= (QF-DATA-TYPE BUCKET) DTP-LIST))
		   (SETQ STRING (QF-LM-STRING-INTO-SYMBOL STRING))
		   (QF-MEM-WRITE BUCKET-HEAD-ADDR
				 (QF-CONS STRING (QF-P-CONTENTS BUCKET-HEAD-ADDR)))
		   STRING)
		  (AND (QF-LM-STRING-EQUAL (QF-MEM-READ (SETQ TEM (QF-MEM-READ BUCKET))) STRING STRINGLEN)
		       (RETURN (QF-TYPED-POINTER TEM)))))))))

;TAKE A STRING IN THE MACHINE AND FIGURE OUT WHAT PKG-HASH-STRING WOULD DO WITH IT.
(DEFUN QF-PKG-HASH-LM-STRING (STRING)
    (DECLARE (FIXNUM LEN STRING HASH I))
    (QF-POINTER (DO ((I 0 (1+ I))
		     (LEN (QF-ARRAY-ACTIVE-LENGTH STRING))
		     (HASH 0))
		    ((= I LEN)
		     (COND ((BIT-TEST 40000000 HASH)
			    (LOGXOR HASH 40000001))	;-37777777 = 40000001
			   (T HASH)))
		  (SETQ HASH (QF-ROT-24-BIT (LOGXOR HASH (QF-AR-1 STRING I)) 7)))))

(DEFUN QF-LM-STRING-INTO-SYMBOL (STRING)
  (DECLARE (FIXNUM STRING SYMBOL))
  (LET ((SYMBOL (QF-ALLOCATE-BLOCK (QF-AREA-NUMBER 'NR-SYM) 5)))
       (QF-MEM-WRITE SYMBOL (QF-MAKE-Q STRING DTP-SYMBOL-HEADER 3))
       (QF-MEM-WRITE (1+ SYMBOL) (QF-MAKE-Q SYMBOL DTP-NULL 3))
       (QF-MEM-WRITE (+ 2 SYMBOL) (QF-MAKE-Q SYMBOL DTP-NULL 3))
       (QF-MEM-WRITE (+ 3 SYMBOL) (QF-SMASH-CDR-CODE QF-NIL 3))
       (QF-MEM-WRITE (+ 4 SYMBOL) (QF-SMASH-CDR-CODE QF-NIL 2))
       (QF-MAKE-Q SYMBOL DTP-SYMBOL)))

;FULL INTERN OF A MACLISP SYMBOL.
(DEFUN QF-MACLISP-SYM-INTERN (SYM OBARRAYP AREA)
  (DECLARE (FIXNUM TEM LEN C0 C1 C2 WD-IDX))
  (PROG (TEM STRING LST LEN C0 C1 C2 WD-IDX)
	;; FIND ONE THAT ALREADY EXISTS WITH THAT NAME.
	(COND ((NOT (= -1 (SETQ TEM (QF-SYMBOL1 SYM OBARRAYP))))
	       (RETURN TEM)))
	;; ELSE CONSTRUCT A PNAME STRING AND INTERN THAT.
	(SETQ LST (EXPLODEN SYM))
	(SETQ LEN (LENGTH LST))
	(SETQ STRING (QF-MAKE-ARRAY AREA 'ART-STRING (LIST LEN) NIL NIL NIL))
	(SETQ WD-IDX 1)
    LP	(COND ((NULL LST) (GO X)))
	(SETQ C0 (CAR LST) C1 0 C2 0)
	(COND ((NULL (SETQ LST (CDR LST))) (GO X1)))
	(SETQ C1 (CAR LST))
	(COND ((NULL (SETQ LST (CDR LST))) (GO X1)))
	(SETQ C2 (CAR LST))
	(COND ((NULL (SETQ LST (CDR LST))) (GO X1)))
	(QF-MEM-WRITE (+ STRING WD-IDX) (+ (LSH (CAR LST) 24.) (LSH C2 16.) (LSH C1 8) C0))
	(SETQ WD-IDX (1+ WD-IDX))
	(SETQ LST (CDR LST))
	(GO LP)
   X1	(QF-MEM-WRITE (+ STRING WD-IDX) (+ (LSH C2 16.) (LSH C1 8) C0))
   X	(RETURN (PUTPROP SYM 
	         (QF-LM-STRING-INTERN STRING OBARRAYP SYM)
		 'REAL-MACHINE-ATOM-HEADER-POINTER)) ))


;DOESN'T TRY TO WIN FOR HAIRY FONT CHANGES ETC.
(DEFUN QF-LM-STRING-EQUAL (STRING1 STRING2 LEN2)
  (DECLARE (FIXNUM STRING1 LEN1 STRING2 LEN2 WD1 WD2 IDX CHNUM))
  ((LAMBDA (LEN1)
    (COND ((NOT (= LEN1 LEN2))
	   NIL)
	  ((DO ((IDX 0 (1+ IDX))
		(CHNUM)
		(WD1)
		(WD2))
	       ((NOT (< IDX LEN1))
		T)
	     (COND ((= 0 (SETQ CHNUM (LOGAND 3 IDX)))
		    (SETQ WD1 (QF-MEM-READ (SETQ STRING1 (1+ STRING1))))
		    (SETQ WD2 (QF-MEM-READ (SETQ STRING2 (1+ STRING2))))))
	     (OR (= (LOGAND 377 (LSH WD1 (SETQ CHNUM (* -8 CHNUM))))
		    (LOGAND 377 (LSH WD2 CHNUM)))
		 (RETURN NIL)) ))))
   (QF-ARRAY-ACTIVE-LENGTH STRING1)))

(DEFUN QF-SXHASH (SYMB)
  (DO ((COUNT 1 (1+ COUNT)) ;GETCHARN USES 1-ORIGIN INDEXING
       (HASH 0)
       (CH))
      ((= 0 (SETQ CH (GETCHARN SYMB COUNT)))
       (OR (ZEROP (LOGAND 40000000 HASH))
	   (SETQ HASH (LOGXOR 40000001 HASH)))
       HASH)
   (DECLARE (FIXNUM HASH COUNT CH))
   (SETQ HASH (QF-ROT-24-BIT (LOGXOR HASH CH) 7)) ))

(DEFUN QF-LM-STRING-SXHASH (STRING)
  (DECLARE (FIXNUM HASH IDX CHNUM WD CH STRING LEN))
  (DO ((HASH 0)
       (LEN (QF-ARRAY-ACTIVE-LENGTH STRING))
       (IDX 0 (1+ IDX))
       (CHNUM)
       (WD))
      ((NOT (< IDX LEN))
       (OR (ZEROP (LOGAND 40000000 HASH))
	   (SETQ HASH (LOGXOR 40000001 HASH)))
       HASH)
    (SETQ HASH (QF-ROT-24-BIT
		 (LOGXOR HASH
			 (LOGAND 377 (COND ((= 0 (SETQ CHNUM (LOGAND 3 IDX)))
					    (SETQ WD (QF-MEM-READ (SETQ STRING (1+ STRING)))))
					   ((LSH WD (* -8 CHNUM))))))
		 7))))

(DEFUN QF-SAMEPNAMEP (LISPSYMB QSYMBPTR)
 (DECLARE (FIXNUM QSYMBPTR))
 (QF-LMSTRING-MSYMBOL-EQUAL (QF-MEM-READ QSYMBPTR) LISPSYMB))

(DEFUN QF-LMSTRING-MSYMBOL-EQUAL (CONS-PNAME-PNTR LISPSYMB)
 (DECLARE (FIXNUM CONS-PNAME-PNTR))
 (PROG (LEN ARRAY-HEAD)
  (DECLARE (FIXNUM LEN ARRAY-HEAD))
  (SETQ ARRAY-HEAD (QF-MEM-READ CONS-PNAME-PNTR))
  (COND ((NOT (= 0 (LOGLDB %%ARRAY-LEADER-BIT ARRAY-HEAD)))
	 (SETQ LEN (QF-POINTER (QF-MEM-READ (- CONS-PNAME-PNTR 2)))))
	((= 0 (LOGLDB %%ARRAY-LONG-LENGTH-FLAG ARRAY-HEAD))
	 (SETQ LEN (LOGLDB %%ARRAY-INDEX-LENGTH-IF-SHORT ARRAY-HEAD)))
	((SETQ LEN (QF-POINTER (QF-MEM-READ (SETQ CONS-PNAME-PNTR (1+ CONS-PNAME-PNTR)))))))
  (RETURN
   (COND ((OR (= 0 (GETCHARN LISPSYMB LEN))
	      (NOT (= 0 (GETCHARN LISPSYMB (1+ LEN)))))
	   NIL)  ;WRONG LENGTH
	(T 
   (DO ((COUNT 1 (1+ COUNT)) ;BECAUSE GETCHARN USES 1-ORIGIN INDEXING
	(WD-NUM 0)
	(WD)
	(CH)
	(LCH)
	(PORTION 0 (1+ PORTION)))
       ((> COUNT LEN) T)
    (DECLARE (FIXNUM COUNT WD-NUM WD CH PORTION))
    (AND (= 0 PORTION)
	 (SETQ WD (QF-MEM-READ (+ (SETQ WD-NUM (1+ WD-NUM))
				  CONS-PNAME-PNTR))))
    (SETQ CH (LOGAND 377 WD))
    (SETQ WD (LSH WD -8))
    (AND (= 0 (SETQ LCH (GETCHARN LISPSYMB COUNT)))
	 (RETURN NIL))
    (COND ((NOT (= LCH CH))
	   (RETURN NIL))
	  ((= 3 PORTION)
	   (SETQ PORTION -1))) ) )) )))

;CONS!
;ONLY WORKS FOR LINEARLY-ADVANCING TYPE AREAS
;CAN'T GC.  DOESN'T INITIALIZE THE ALLOCATED BLOCK TO ANYTHING.
;DOESN'T SET DATA TYPE IN THE RETURNED POINTER.
(DEFUN QF-ALLOCATE-BLOCK (AREA NQS)
  (DECLARE (FIXNUM AREA NQS MODE LEN FREE NEWFREE FSP-ADR))
  (PROG (MODE LEN FREE NEWFREE FSP-ADR)
    (SETQ AREA (QF-POINTER AREA))
    (OR (< AREA 200) (ERROR '|RIDICULOUS AREA NUMBER - QF-ALLOCATE-BLOCK| AREA 'FAIL-ACT))
    (AND (> NQS 20000)  ;NQS=1 REALLY OK IF MAKING 1 ELEMENT LIST
	 (ERROR '|RIDICULOUS NUMBER OF QS - QF-ALLOCATE-BLOCK| NQS 'FAIL-ACT))
    (SETQ MODE (LOGLDB %%AREA-MODE-FREE-STORAGE
		       (QF-MEM-READ (+ AREA (QF-INITIAL-AREA-ORIGIN 'AREA-MODE-BITS)))))
    (OR (= MODE 1)	;LINEARLY ADVANCING
	(ERROR '|UNKNOWN AREA FREE STORAGE MODE - QF-ALLOCATE-BLOCK| AREA 'FAIL-ACT))
    (SETQ LEN (QF-POINTER (QF-MEM-READ (+ AREA (QF-INITIAL-AREA-ORIGIN 'AREA-LENGTH)))))
    (SETQ FREE (QF-POINTER (QF-MEM-READ 
			     (SETQ FSP-ADR (+ AREA 
					      (QF-INITIAL-AREA-ORIGIN 'AREA-FREE-POINTER))))))
    (SETQ NEWFREE (+ FREE NQS))
    (AND (> NEWFREE LEN)
	 (ERROR '|AREA FULL - QF-ALLOCATE-BLOCK| AREA 'FAIL-ACT))
    (QF-P-STORE-CONTENTS FSP-ADR (QF-MAKE-Q NEWFREE DTP-FIX))
    (RETURN (+ FREE (QF-P-POINTER (+ AREA (QF-INITIAL-AREA-ORIGIN 'AREA-ORIGIN)))))))

;;;BASIC OPERATIONS

(DEFUN QF-CONS (X Y)   
   (DECLARE (FIXNUM NEWCELL))
   (LET ((NEWCELL (QF-ALLOCATE-BLOCK (QF-AREA-NUMBER 'WORKING-STORAGE-AREA) 2)))
	(QF-MEM-WRITE NEWCELL (QF-SMASH-CDR-CODE X 0))
	(QF-MEM-WRITE (1+ NEWCELL) (QF-SMASH-CDR-CODE Y 1))
	(QF-MAKE-Q NEWCELL DTP-LIST)))

(DEFUN QF-CONS-IN-AREA (X Y AREA-NUM) 
   (DECLARE (FIXNUM NEWCELL AREA-NUM))
   (LET ((NEWCELL (QF-ALLOCATE-BLOCK AREA-NUM 2)))
	(QF-MEM-WRITE NEWCELL (QF-SMASH-CDR-CODE X 0))
	(QF-MEM-WRITE (1+ NEWCELL) (QF-SMASH-CDR-CODE Y 1))
	(QF-MAKE-Q NEWCELL DTP-LIST)))

(DEFUN QF-CAR (LMOB)
    (LET ((TYPE (QF-DATA-TYPE LMOB)))
      (OR (= TYPE DTP-LIST)
	  (= TYPE DTP-LOCATIVE)
	  (ERROR '|Neither a cons nor a locative -- QF-CAR| LMOB)))
    (DO ((X (QF-MEM-READ LMOB) (QF-MEM-READ X)))
	(NIL)
      (SELECTN (QF-DATA-TYPE X)
	 ((DTP-FORWARD DTP-ONE-Q-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER) NIL)
	 (OTHERWISE (RETURN (QF-TYPED-POINTER X))))))

(DEFUN QF-CDR (LMOB)
   (LET ((TYPE (QF-DATA-TYPE LMOB))(L LMOB))
     (SELECTN TYPE
	(DTP-LOCATIVE
	 (QF-CAR LMOB))
	(DTP-LIST
	 (LET ((CDRC (QF-CDR-CODE
		      (DO ((X (QF-MEM-READ LMOB) (QF-MEM-READ L)))
			  (NIL)
			(SELECTN (QF-DATA-TYPE X)
			   (DTP-FORWARD (SETQ L X))
			   (OTHERWISE (RETURN X)))))))
	   (LET ((X (SELECTN CDRC
		       (0 (QF-MEM-READ (1+ L)))	;FULL CONS
		       (1 (ERROR '|CDR-ERROR encountered - QF-CDR| LMOB 'FAIL-ACT))
		       (2 QF-NIL)			;CDR NIL
		       (3 (1+ L))
		       (OTHERWISE (ERROR '|Lose big -- QF-CDR|)))))
	     (DO ((X X (QF-MEM-READ X)))
		 (NIL)
	       (SELECTN (QF-DATA-TYPE X)
		  ((DTP-FORWARD DTP-ONE-Q-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER) NIL)
		  (OTHERWISE (RETURN (QF-TYPED-POINTER X))))))))
	(OTHERWISE
	 (ERROR '|Neither a cons nor a locative -- QF-CDR| LMOB)))))


;; Internal routine to write through a pointer, using TRANSPORT-WRITE.
;; Writes only the TYPED-POINTER, leaving the CDR-CODE and FLAG-BIT alone.
(DEFUN QF-RPLAC (LMOB DATUM)
    (LET ((L LMOB))
      (LET ((OLD-CONTENTS
	     (DO ((X (QF-MEM-READ L) (QF-MEM-READ L)))
		 (NIL)
	       (SELECTN (QF-DATA-TYPE X)
	          ((DTP-FORWARD DTP-ONE-Q-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER)
		   (SETQ L X))
		  (OTHERWISE
		   (RETURN X))))))
	   (QF-MEM-WRITE L (QF-SMASH-TYPED-POINTER OLD-CONTENTS DATUM)))))

(DEFUN QF-RPLACA (LMOB DATUM)
    (SELECTN (QF-DATA-TYPE LMOB)
       ((DTP-LIST DTP-LOCATIVE)
	(QF-RPLAC LMOB DATUM)
	LMOB)
       (OTHERWISE (ERROR '|Neither a cons nor a locative -- QF-RPLACA| LMOB))))

(DEFUN QF-RPLACD (LMOB DATUM)
    (SELECTN (QF-DATA-TYPE LMOB)
       ((DTP-LIST DTP-LOCATIVE)
	(LET ((L LMOB))
	  ;; L will be the effective pointer for getting the CDR code.
	  (LET ((OLD-CAR
		 (DO ((X (QF-MEM-READ L) (QF-MEM-READ L)))
		     (NIL)
		   (SELECTN (QF-DATA-TYPE X)
		       (DTP-FORWARD
			(SETQ L X))
		       (OTHERWISE
			(RETURN X))))))
	    (SELECTN (QF-CDR-CODE OLD-CAR)
	       (0 (QF-RPLAC (1+ L) DATUM))		;FULL NODE
	       (1 (ERROR '|CDR-ERROR encountered - QF-RPLACD| LMOB 'FAIL-ACT))
	       ((2 3)
		(QF-MEM-WRITE
		 L
		 (QF-MAKE-Q
		  (QF-CONS-IN-AREA OLD-CAR DATUM (QF-AREA-NUMBER-OF-POINTER L))
		  DTP-FORWARD)))
	       (OTHERWISE '|Lose big -- QF-RPLACD|))))
	LMOB)
       (OTHERWISE (ERROR '|Neither a cons nor a locative -- QF-RPLACD| LMOB))))

(DEFUN QF-VALUE-CELL-LOCATION (Q)
  (OR (= (QF-DATA-TYPE Q) DTP-SYMBOL) (ERROR '|NOT SYMBOL - QF-VALUE-CELL-LOCATION| Q 'FAIL-ACT))
  (QF-MAKE-Q (1+ Q) DTP-LOCATIVE))

(DEFUN QF-FUNCTION-CELL-LOCATION (Q)
  (OR (= (QF-DATA-TYPE Q) DTP-SYMBOL) (ERROR '|NOT SYMBOL - QF-FUNCTION-CELL-LOCATION| Q 'FAIL-ACT))
  (QF-MAKE-Q (+ 2 Q) DTP-LOCATIVE))

(DEFUN QF-PROPERTY-CELL-LOCATION (Q)
  (OR (= (QF-DATA-TYPE Q) DTP-SYMBOL) (ERROR '|NOT SYMBOL - QF-PROPERTY-CELL-LOCATION| Q 'FAIL-ACT))
  (QF-MAKE-Q (+ 3 Q) DTP-LOCATIVE))

;SPECIAL RANDOM ONES FOR FASLOAD
(DEFUN QF-FUNCTION-CELL-CONTENTS (QQ)
  (AND (EQ (TYPEP QQ) 'SYMBOL) (SETQ QQ (QF-SYMBOL QQ)))
  (OR (= (QF-DATA-TYPE QQ) DTP-SYMBOL) (ERROR 'WTA-QF-FUNCTION-CELL-CONTENTS QQ 'FAIL-ACT))
  (QF-CAR (QF-FUNCTION-CELL-LOCATION QQ)))

(DEFUN QF-VALUE-CELL-CONTENTS (QQ)
  (AND (EQ (TYPEP QQ) 'SYMBOL) (SETQ QQ (QF-SYMBOL QQ)))
  (OR (= (QF-DATA-TYPE QQ) DTP-SYMBOL) (ERROR 'WTA-QF-VALUE-CELL-CONTENTS QQ 'FAIL-ACT))
  (QF-CAR (QF-VALUE-CELL-LOCATION QQ)))

;RETURN BASE ADDRESS OF AREA.  TRIES TO USE CACHE.
(COMMENT ;THIS IS NEVER CALLED AND IS GROSSLY KLUDGEY.  IF IT'S EVER NEEDED
         ;IT SHOULD WORK BY STRING SEARCHING THE AREA TABLE OR SOMETHING
(DEFUN QF-AREA-ORIGIN (NAME)
  ((LAMBDA (TEM)
    (COND ((SETQ TEM (ASSQ NAME QF-AREA-ORIGIN-CACHE))
	   (CDR TEM))
	  ((MEMQ NAME AREA-LIST) (QF-INITIAL-AREA-ORIGIN NAME))
	  (T
	   (QF-ARRAY-SETUP (QF-FUNCTION-CELL-CONTENTS NAME))
	   (QF-ARRAY-DISPLACE 0)
	   (SETQ QF-ARRAY-DATA-ORIGIN (QF-POINTER QF-ARRAY-DATA-ORIGIN))
	   (SETQ QF-AREA-ORIGIN-CACHE (CONS (CONS NAME QF-ARRAY-DATA-ORIGIN)
					    QF-AREA-ORIGIN-CACHE))
	   QF-ARRAY-DATA-ORIGIN)))
    NIL))
);END COMMENT

;RETURN BASE ADDRSS OF AREA WHICH WAS PRESENT IN COLD-LOAD.  FASTER THAN QF-AREA-ORIGIN,
; AND MORE IMPORTANTLY, GUARENTEED NOT TO CAUSE ANY SWAPPING ACTIVITY.
(DEFUN QF-INITIAL-AREA-ORIGIN (NAME)
  (PROG (TEM)
	(COND ((SETQ TEM (ASSQ NAME QF-AREA-ORIGIN-CACHE))
		(RETURN (CDR TEM)))
	      ((SETQ TEM (FIND-POSITION-IN-LIST NAME AREA-LIST))
		(SETQ TEM 
		     (QF-POINTER (CNSPMR (+ TEM (CNSPMR (+ 200 %SYS-COM-AREA-ORIGIN-PNTR))))))
		(SETQ QF-AREA-ORIGIN-CACHE 
			(CONS (CONS NAME TEM) QF-AREA-ORIGIN-CACHE))
		(RETURN TEM))
	      (T (ERROR NAME 'QF-INITIAL-AREA-ORIGIN 'FAIL-ACT)))))

;RETURN AREA NUMBER OF AREA - BETTER BE AN INITIAL AREA
(DEFUN QF-AREA-NUMBER (NAME)
  (OR (FIND-POSITION-IN-LIST NAME AREA-LIST)
      (ERROR NAME '|NOT KNOWN - QF-AREA-NUMBER|)))

;;; ARRAYS.  ONLY 1-DIMENSIONAL FOR NOW.

;FUNCTION TO SET UP FOR AN ARRAY REFERENCE
;CORRESPONDS TO GAHDR IN MICRO CODE.
;ARGUMENT IS ARRAY-POINTER-Q
;SETS THE FOLLOWING SPECIAL VARIABLES:
;  QF-ARRAY-HEADER
;  QF-ARRAY-DISPLACED-P
;  QF-ARRAY-HAS-LEADER-P
;  QF-ARRAY-NUMBER-DIMS
;  QF-ARRAY-HEADER-ADDRESS
;  QF-ARRAY-DATA-ORIGIN
;  QF-ARRAY-LENGTH

(DEFUN QF-ARRAY-SETUP (Q)
  (PROG (N)
    (OR (= (QF-DATA-TYPE Q) DTP-ARRAY-POINTER) (ERROR '|NOT AN ARRAY-POINTER - QF-ARRAY-SETUP|
						  Q 'FAIL-ACT))
A   (SETQ QF-ARRAY-HEADER-ADDRESS (QF-POINTER Q))
    (SETQ QF-ARRAY-HEADER (QF-MEM-READ QF-ARRAY-HEADER-ADDRESS))
    (SETQ N (QF-DATA-TYPE QF-ARRAY-HEADER))
    (COND ((= N DTP-ARRAY-HEADER))
	  ((= N DTP-FORWARD)
	   (SETQ Q QF-ARRAY-HEADER)
	   (GO A))
;	  ((OR (= N DTP-IV-GC) (= N DTP-IV-EFF-AD))
;	   (SETQ Q QF-ARRAY-HEADER)
;	   (GO A))
	  ((ERROR '|ARRAY HEADER NOT DTP-ARRAY-HEADER - QF-ARRAY-SETUP| Q 'FAIL-ACT)))
    (SETQ QF-ARRAY-DISPLACED-P (= 1 (LOGLDB %%ARRAY-DISPLACED-BIT QF-ARRAY-HEADER)))
    (SETQ QF-ARRAY-HAS-LEADER-P (= 1 (LOGLDB %%ARRAY-LEADER-BIT QF-ARRAY-HEADER)))
    (SETQ QF-ARRAY-NUMBER-DIMS (LOGLDB %%ARRAY-NUMBER-DIMENSIONS QF-ARRAY-HEADER))
    (SETQ QF-ARRAY-DATA-ORIGIN (+ QF-ARRAY-NUMBER-DIMS QF-ARRAY-HEADER-ADDRESS))
    (COND ((= 0 (LOGLDB %%ARRAY-LONG-LENGTH-FLAG QF-ARRAY-HEADER))
	   (SETQ QF-ARRAY-LENGTH (LOGLDB %%ARRAY-INDEX-LENGTH-IF-SHORT QF-ARRAY-HEADER)))
	  (T
	   (SETQ QF-ARRAY-DATA-ORIGIN (1+ QF-ARRAY-DATA-ORIGIN))
	   (SETQ QF-ARRAY-LENGTH (QF-POINTER (QF-MEM-READ (1+ QF-ARRAY-HEADER-ADDRESS))))))
  ))

;FUNCTION THAT CORRESPONDS TO DSP-ARRAY-SETUP IN MICRO CODE.
;ARGUMENT IS COMPUTED INDEX, RESULT IS NEW, POSSIBLY-OFFSET INDEX.
;HANDLES DISPLACED AND INDIRECT ARRAYS.  BARFS IF INDEX OUT OF BOUNDS.
;MAY MODIFY SPECIAL VARIABLE QF-ARRAY-DATA-ORIGIN.
(DEFUN QF-ARRAY-DISPLACE (I)
 (COND (QF-ARRAY-DISPLACED-P
	(SETQ QF-ARRAY-LENGTH (QF-POINTER (QF-MEM-READ (1+ QF-ARRAY-DATA-ORIGIN))))
	(PROG (K)
	  (SETQ K (QF-MEM-READ QF-ARRAY-DATA-ORIGIN))
	  (OR (= (QF-DATA-TYPE K) DTP-ARRAY-POINTER) (RETURN (SETQ QF-ARRAY-DATA-ORIGIN K)))
	  ;INDIRECT ARRAY
	  (ERROR '|I REALLY DON'T FEEL LIKE HACKING INDIRECT ARRAYS, SORRY - QF-ARRAY-DISPLACE|
		 NIL 'FAIL-ACT))))
 (OR (< I QF-ARRAY-LENGTH)
     (ERROR '|ARRAY INDEX OUT OF BOUNDS - QF-ARRAY-DISPLACE| I 'FAIL-ACT))
 I)

;FUNCTION TO READ OUT CONTENTS OF THE SET UP ARRAY.  ARG IS INDEX.
(DEFUN QF-ARRAY-READ (I)
  (PROG (N TYPE K M Q J)
    (SETQ TYPE (NTH (LOGLDB %%ARRAY-TYPE-FIELD QF-ARRAY-HEADER) ARRAY-TYPES))
    (SETQ K (CDR (ASSQ TYPE ARRAY-ELEMENTS-PER-Q)))	;K ELEMENTS PER Q
;**KNOWS ABOUT LENGTH OF POINTER**
    (SETQ N (CDR (OR (ASSQ TYPE '((ART-1B . 1) (ART-2B . 2) (ART-4B . 4) (ART-8B . 8.)
				  (ART-16B . 16.) (ART-32B . 32.) (ART-Q . 32.)
				  (ART-Q-LIST . 29.) (ART-STRING . 8)
				  (ART-STACK-GROUP-HEAD . 32.) (ART-SPECIAL-PDL . 32.)
				  (ART-TVB . 20) (ART-REG-PDL . 32.)
				  ))			;N BITS PER ELEMENT
		     (ERROR '|ARRAY TYPE NOT KNOWN ABOUT - QF-ARRAY-READ| TYPE 'FAIL-ACT))))
    (SETQ M (1- (LSH 1 N)))				;M MASK FOR 1 ELEMENT
    (SETQ Q (// I K) J (* (\ I K) N))			;Q WD INDEX, J BIT INDEX
    (SETQ Q (QF-MEM-READ (+ Q QF-ARRAY-DATA-ORIGIN)))
    (RETURN (LOGAND M (LSH Q (- J))))))

;SIMILAR FUNCTION TO WRITE INTO SET UP ARRAY.
(DEFUN QF-ARRAY-WRITE (I DATA)
  (PROG (N TYPE K M Q J ADR)
    (SETQ TYPE (NTH (LOGLDB %%ARRAY-TYPE-FIELD QF-ARRAY-HEADER) ARRAY-TYPES))
    (SETQ K (CDR (ASSQ TYPE ARRAY-ELEMENTS-PER-Q)))
;**KNOWS ABOUT NUMBER OF BITS IN POINTER**
    (SETQ N (CDR (OR (ASSQ TYPE '((ART-1B . 1) (ART-2B . 2) (ART-4B . 4) (ART-8B . 8.)
				  (ART-16B . 16.) (ART-32B . 32.) (ART-Q . 32.)
				  (ART-Q-LIST . 29.) (ART-STRING . 8)
				  (ART-STACK-GROUP-HEAD . 32.) (ART-SPECIAL-PDL . 32.)
				  (ART-TVB . 20.) (ART-REG-PDL . 32.)
				  ))			;N BITS PER ELEMENT
		     (ERROR '|ARRAY TYPE NOT KNOWN ABOUT - QF-ARRAY-WRITE| TYPE 'FAIL-ACT))))
    (SETQ M (1- (LSH 1 N)))
    (SETQ Q (// I K) J (* (\ I K) N))
    (SETQ Q (QF-MEM-READ (SETQ ADR (+ Q QF-ARRAY-DATA-ORIGIN))))
    (RETURN (QF-MEM-WRITE ADR
			  (LOGIOR (LSH (LOGAND M DATA) J)
				  (LOGAND (LOGXOR -1 (LSH M J))
					  Q))))))

(DEFUN QF-ARRAY-DIMENSION-N (I Q)
 (QF-ARRAY-SETUP Q)
 (COND ((= I QF-ARRAY-NUMBER-DIMS)
	(ERROR '|QF-ARRAY-DIMENSION-N ON LAST DIMENSION|)))
 (QF-POINTER (QF-MEM-READ (+ I (- QF-ARRAY-DATA-ORIGIN QF-ARRAY-NUMBER-DIMS)))))

(DEFUN QF-AR-1 (Q I)
  (QF-ARRAY-SETUP Q)
  (QF-TYPED-POINTER (QF-ARRAY-READ (QF-ARRAY-DISPLACE I))))

(DEFUN QF-AS-1 (DATA Q I)
  (QF-ARRAY-SETUP Q)
  (QF-TYPED-POINTER (QF-ARRAY-WRITE (QF-ARRAY-DISPLACE I) DATA)))

(DEFUN QF-AR-2 (Q I J)
  (QF-ARRAY-SETUP Q)
  (QF-TYPED-POINTER (QF-ARRAY-READ 
     (QF-ARRAY-DISPLACE
        (+ (* J (QF-P-POINTER (1+ (- QF-ARRAY-DATA-ORIGIN QF-ARRAY-NUMBER-DIMS))))
	   I)))))

(DEFUN QF-AS-2 (DATA Q I J)
  (QF-ARRAY-SETUP Q)
  (QF-TYPED-POINTER (QF-ARRAY-WRITE
     (QF-ARRAY-DISPLACE
        (+ (* J (QF-P-POINTER (1+ (- QF-ARRAY-DATA-ORIGIN QF-ARRAY-NUMBER-DIMS))))
	   I))
     DATA)))

(DEFUN QF-ARRAY-LEADER (Q I)
  (QF-ARRAY-SETUP Q)
  (OR QF-ARRAY-HAS-LEADER-P (ERROR '|NO ARRAY LEADER - QF-ARRAY-LEADER| Q 'FAIL-ACT))
  (OR (< I (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 1))))
      (ERROR '|ARRAY LEADER INDEX OUT OF BOUNDS - QF-ARRAY-LEADER| Q 'FAIL-ACT))
  (QF-TYPED-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS I 2))))

(DEFUN QF-STORE-ARRAY-LEADER (DATA Q I)
  (QF-ARRAY-SETUP Q)
  (OR QF-ARRAY-HAS-LEADER-P (ERROR '|NO ARRAY LEADER - QF-STORE-ARRAY-LEADER| Q 'FAIL-ACT))
  (OR (< I (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 1))))
      (ERROR '|ARRAY LEADER INDEX OUT OF BOUNDS - QF-STORE-ARRAY-LEADER| Q 'FAIL-ACT))
  (QF-TYPED-POINTER (QF-MEM-WRITE (- QF-ARRAY-HEADER-ADDRESS I 2) DATA)))

(DEFUN QF-ARRAY-PUSH (Q DATA)
  (PROG (FILLPOINTER)
    (DECLARE (FIXNUM FILLPOINTER))
    (SETQ FILLPOINTER (QF-ARRAY-LEADER Q 0))
    (QF-AS-1 DATA Q (QF-POINTER FILLPOINTER))
    (QF-STORE-ARRAY-LEADER (SETQ FILLPOINTER (1+ FILLPOINTER)) Q 0)
    (RETURN (QF-POINTER FILLPOINTER))))

(DEFUN QF-ARRAY-LENGTH (Q)
  (QF-ARRAY-SETUP Q)
  QF-ARRAY-LENGTH)

(DEFUN QF-ARRAY-ACTIVE-LENGTH (Q)
  (QF-ARRAY-SETUP Q)
  (COND ((NOT QF-ARRAY-HAS-LEADER-P)
	 QF-ARRAY-LENGTH)
	((QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2))))))

;LEADER = NIL -> NO LEADER
;LEADER = FIXNUM -> LEADER N LONG,  INITIALIZED TO NIL S
;LEADER = LIST -> LEADER LENGTH OF LIST LONG, INITIALIZED TO ELEMENTS OF LIST.
;		NOTE LIST IS IN STORAGE ORDER, WHICH IS REVERSED FROM INDEX ORDER.
(DEFUN QF-MAKE-ARRAY (AREA TYPE DIMLIST DISPLACED-P LEADER INDEX-OFFSET)
  (PROG (TEM TEM1 TEM2 NDIMS INDEX-LENGTH DATA-LENGTH ENTRIES-PER-Q LEADER-LENGTH 
	 HEADER-Q LONG-ARRAY-FLAG)
	(DECLARE (FIXNUM TEM TEM1 TEM2 NDIMS INDEX-LENGTH DATA-LENGTH LEADER-LENGTH
			 HEADER-Q))
	(SETQ NDIMS (LENGTH DIMLIST))
	;(SETQ INDEX-LENGTH (LIST-PRODUCT DIMLIST))
	(SETQ INDEX-LENGTH 1)
	(DO L DIMLIST (CDR L) (NULL L)
	    (SETQ INDEX-LENGTH (* INDEX-LENGTH (CAR L))))
	(COND ((AND (> INDEX-LENGTH %ARRAY-MAX-SHORT-INDEX-LENGTH)
		    (NULL DISPLACED-P))
		(SETQ LONG-ARRAY-FLAG T)))
	(SETQ LEADER-LENGTH (COND ((NULL LEADER) 0)
				  ((NUMBERP LEADER) (+ 2 LEADER))
				  (T (+ 2 (LENGTH LEADER)))))
	(COND ((NULL (SETQ ENTRIES-PER-Q (ASSQ TYPE ARRAY-ELEMENTS-PER-Q)))
	       (ERROR '|BAD ARRAY TYPE - QF-MAKE-ARRAY| TYPE 'FAIL-ACT)))
	(SETQ ENTRIES-PER-Q (CDR ENTRIES-PER-Q))
	(SETQ DATA-LENGTH (// (+ INDEX-LENGTH (1- ENTRIES-PER-Q))
			      ENTRIES-PER-Q))
	(SETQ TEM (QF-ALLOCATE-BLOCK (COND ((NUMBERP AREA) AREA) ((SYMEVAL AREA))) 
				     (+ NDIMS 
					(+ LEADER-LENGTH 
					   (COND (DISPLACED-P 
						  (COND (INDEX-OFFSET 3)
							(T 2)))
						 (T (COND (LONG-ARRAY-FLAG (1+ DATA-LENGTH))
							  (T DATA-LENGTH))))))))
	(COND ((NULL LEADER) (GO A)))
	(SETQ TEM2 (1+ TEM))
	(QF-MEM-WRITE TEM (QF-MAKE-Q (+ HEADER-TYPE-ARRAY-LEADER LEADER-LENGTH)
				     DTP-HEADER))
	(SETQ TEM1 LEADER)
	(SETQ TEM TEM2)
	(COND ((NOT (NUMBERP LEADER)) (GO LD-1)))
	(SETQ TEM2 (QF-SYMBOL NIL))
LDN1	(COND ((= 0 TEM1) (GO LD-2)))		;STORE LEADER OF LENGTH N
	(QF-MEM-WRITE TEM TEM2)
	(SETQ TEM (1+ TEM))
	(SETQ TEM1 (1- TEM1))
	(GO LDN1)
LD-1	(ERROR '|CANNOT INITIALIZE LEADER TO LIST - QF-MAKE-ARRAY| LEADER 'FAIL-ACT)
	;(COND ((ATOM TEM1) (GO LD-2)))		;STORE LEADER INITIALIZED TO LIST
	;(RPLACA TEM (CAR TEM1))
	;(SETQ TEM (CDR TEM))
	;(SETQ TEM1 (CDR TEM1))
	;(GO LD-1)
LD-2	(QF-MEM-WRITE TEM (QF-MAKE-Q (- LEADER-LENGTH 2) DTP-FIX))
	(SETQ TEM (1+ TEM))
  A	(SETQ TEM1 (1+ TEM))
	(SETQ HEADER-Q (LOGDPB NDIMS %%ARRAY-NUMBER-DIMENSIONS (SYMEVAL TYPE)))
	(AND LEADER (SETQ HEADER-Q (LOGDPB 1 %%ARRAY-LEADER-BIT HEADER-Q)))
	(COND (DISPLACED-P 
		(QF-MEM-WRITE TEM (QF-MAKE-Q (LOGDPB 1 %%ARRAY-DISPLACED-BIT HEADER-Q)
					     DTP-ARRAY-HEADER)))
	      ((NULL LONG-ARRAY-FLAG)
		(QF-MEM-WRITE TEM (QF-MAKE-Q (+ INDEX-LENGTH HEADER-Q)
					     DTP-ARRAY-HEADER)))
	      (T (QF-MEM-WRITE TEM (QF-MAKE-Q
				         (LOGDPB 1 %%ARRAY-LONG-LENGTH-FLAG HEADER-Q)
					 DTP-ARRAY-HEADER))
		 (QF-RPLACA TEM1 (QF-MAKE-Q INDEX-LENGTH DTP-FIX))
		 (SETQ TEM1 (1+ TEM1))))
  L	(COND ((= (LENGTH DIMLIST) 1) (GO X1)))	;DONT STORE LAST DIM SINCE INFO IS IN
	(QF-MEM-WRITE TEM1 (QF-MAKE-Q (CAR DIMLIST) DTP-FIX))	;TOTAL LENGTH   
	(SETQ DIMLIST (CDR DIMLIST))
	(SETQ TEM1 (1+ TEM1))
	(GO L)
  X1	(COND (DISPLACED-P (QF-MEM-WRITE TEM1 (COND ((NOT INDEX-OFFSET)
						     DISPLACED-P)
						    ((QF-SMASH-FLAG-BIT DISPLACED-P 1))))
			   (SETQ TEM1 (1+ TEM1))
			   (QF-MEM-WRITE TEM1 (QF-MAKE-Q INDEX-LENGTH DTP-FIX))
			   (SETQ TEM1 (1+ TEM1))
			   (COND (INDEX-OFFSET 
				   (QF-MEM-WRITE TEM1 (QF-MAKE-Q INDEX-OFFSET DTP-FIX))
				   (SETQ TEM1 (1+ TEM1))))))
	(RETURN (QF-MAKE-Q TEM DTP-ARRAY-POINTER)) ))


;IF ARRAY DISPLACED, ADJUST REQUEST REFERS TO THE DISPLACED HEADER, NOT
; POINTED TO DATA.

(DEFUN QF-ADJUST-ARRAY-SIZE (ARRAY NEW-INDEX-LENGTH AREA)	;AREA NIL IF NOT KNOWN 
   (PROG (CURRENT-DATA-LENGTH ARRAY-TYPE ARRAY-HEADER
	  ARRAY-HEADER-POINTER NDIMS TEM ENTRIES-PER-Q NEW-DATA-LENGTH 
	  FREED-ARRAY-LOCN DISPLACED-P ARRAY-DATA-BASE LONG-ARRAY-FLAG 
	  CURRENT-INDEX-LENGTH)
	(DECLARE (FIXNUM CURRENT-DATA-LENGTH ARRAY-HEADER ARRAY-HEADER-POINTER
			 NDIMS TEM NEW-DATA-LENGTH FREED-ARRAY-LOCN ARRAY-DATA-BASE
			 CURRENT-INDEX-LENGTH))
	(COND ((NOT (= (QF-DATA-TYPE ARRAY) DTP-ARRAY-POINTER))
		(RETURN NIL)))
	(SETQ AREA (QF-AREA-NUMBER-OF-POINTER ARRAY))
	(COND ((= 0 NEW-INDEX-LENGTH)
		(RETURN (QF-RETURN-ARRAY AREA ARRAY))))
	(SETQ ARRAY-HEADER-POINTER (QF-POINTER ARRAY))
GAHD	(SETQ ARRAY-HEADER (QF-MEM-READ ARRAY-HEADER-POINTER))
	(SETQ ARRAY-TYPE (QF-DATA-TYPE ARRAY-HEADER))
	(COND ((= ARRAY-TYPE DTP-ARRAY-HEADER))
;	      ((OR (= ARRAY-TYPE DTP-IV-GC) (= ARRAY-TYPE DTP-IV-EFF-AD))
;	       (SETQ ARRAY-HEADER-POINTER (QF-POINTER ARRAY-HEADER))
;	       (GO GAHD))
	      ((ERROR '|RANDOM ARRAY HEADER - QF-ADJUST-ARRAY-SIZE| ARRAY 'FAIL-ACT)))
	(SETQ ARRAY-TYPE (NTH (LOGLDB %%ARRAY-TYPE-FIELD ARRAY-HEADER)
			      ARRAY-TYPES))
	(SETQ NDIMS (LOGLDB %%ARRAY-NUMBER-DIMENSIONS ARRAY-HEADER))
	(COND ((NOT (= 0 (LOGLDB %%ARRAY-LONG-LENGTH-FLAG ARRAY-HEADER)))
		(SETQ LONG-ARRAY-FLAG T)))
	(SETQ CURRENT-INDEX-LENGTH 
		(COND ((NULL LONG-ARRAY-FLAG) 
			(LOGLDB %%ARRAY-INDEX-LENGTH-IF-SHORT ARRAY-HEADER))
		      (T (QF-POINTER (QF-MEM-READ (1+ ARRAY-HEADER-POINTER))))))
	(COND ((NULL (SETQ ENTRIES-PER-Q 
			(ASSQ ARRAY-TYPE ARRAY-ELEMENTS-PER-Q)))
		(RETURN NIL)))
	(SETQ ENTRIES-PER-Q (CDR ENTRIES-PER-Q))
	(SETQ NEW-DATA-LENGTH 
		(// (+ NEW-INDEX-LENGTH (1- ENTRIES-PER-Q))
		    ENTRIES-PER-Q))
	(SETQ ARRAY-DATA-BASE (+ ARRAY-HEADER-POINTER
				 NDIMS))
	(COND (LONG-ARRAY-FLAG (SETQ ARRAY-DATA-BASE (1+ ARRAY-DATA-BASE))))
	(SETQ DISPLACED-P (NOT (= 0 (LOGLDB %%ARRAY-DISPLACED-BIT ARRAY-HEADER))))
	(COND (DISPLACED-P (GO DISPLACED)))
	(SETQ CURRENT-DATA-LENGTH (// (+ CURRENT-INDEX-LENGTH (1- ENTRIES-PER-Q))
					 ENTRIES-PER-Q))
	(COND ((> NEW-DATA-LENGTH CURRENT-DATA-LENGTH)
		(GO MAKE-BIGGER)))
	(COND ((NULL LONG-ARRAY-FLAG)
	       (QF-MEM-WRITE ARRAY-HEADER-POINTER
			     (LOGDPB NEW-INDEX-LENGTH %%ARRAY-INDEX-LENGTH-IF-SHORT
				     (QF-MEM-READ ARRAY-HEADER-POINTER))))
	      (T
	       (QF-MEM-WRITE (1+ ARRAY-HEADER-POINTER)
			     (QF-MAKE-Q NEW-INDEX-LENGTH DTP-FIX))))
	(COND ((= NEW-DATA-LENGTH CURRENT-DATA-LENGTH)
		(RETURN T)))
	(SETQ FREED-ARRAY-LOCN (+ ARRAY-DATA-BASE NEW-DATA-LENGTH))
	(QF-MEM-WRITE FREED-ARRAY-LOCN (QF-MAKE-Q	;HOPE IT'S SHORT!
					  (+ ARRAY-DIM-MULT (+ ART-32B
							       (1- (- CURRENT-DATA-LENGTH 
								      NEW-DATA-LENGTH))))
					  DTP-ARRAY-HEADER))
	(RETURN (QF-RETURN-ARRAY AREA FREED-ARRAY-LOCN))
MAKE-BIGGER 
DISPLACED-MAKE-BIGGER 
	(ERROR '|CAN'T MAKE BIGGER - QF-ADJUST-ARRAY-SIZE| ARRAY 'FAIL-ACT)
DISPLACED 
	(SETQ TEM (+ ARRAY NDIMS 1))
	(SETQ CURRENT-INDEX-LENGTH (QF-MEM-READ TEM)) 
	(COND ((= CURRENT-INDEX-LENGTH NEW-INDEX-LENGTH)
		(RETURN T))
	      ((> NEW-INDEX-LENGTH CURRENT-INDEX-LENGTH)
		(GO DISPLACED-MAKE-BIGGER)))
	(QF-MEM-WRITE TEM (QF-MAKE-Q NEW-INDEX-LENGTH DTP-FIX))
	(RETURN T)
))

;IF ARRAY IS DISPLACED, THE DISPLACED-ARRAY HEADER IS BEING RETURNNED,
;  NOT ANYTHING HAVING TO DO WITH THE POINTED AT DATA.

(DEFUN QF-RETURN-ARRAY (AREA ARRAY) 
  (PROG (ARRAY-HEADER ARRAY-HEADER-POINTER LEADER-P ARRAY-ORIGIN)
	(DECLARE (FIXNUM ARRAY-HEADER ARRAY-HEADER-POINTER ARRAY-ORIGIN))
	(SETQ ARRAY-HEADER-POINTER (QF-POINTER ARRAY))
	(SETQ ARRAY-HEADER (QF-MEM-READ ARRAY-HEADER-POINTER))
	(SETQ LEADER-P (NOT (= 0 (LOGLDB %%ARRAY-LEADER-BIT ARRAY-HEADER))))
	(SETQ ARRAY-ORIGIN (QF-POINTER ARRAY))
	(COND (LEADER-P 
		(SETQ ARRAY-ORIGIN 
		      (- ARRAY-ORIGIN 
			(+ 2 
			   (QF-POINTER (QF-MEM-READ (1- ARRAY-ORIGIN))) ))) ))
	(COND ((QF-ARRAY-AT-END-OF-AREA-P AREA ARRAY)
	       (QF-MEM-WRITE (+ (QF-INITIAL-AREA-ORIGIN 'AREA-FREE-POINTER) AREA)
			     (QF-MAKE-Q
			        (- ARRAY-ORIGIN
				   (QF-POINTER (QF-MEM-READ 
					     (+ (QF-INITIAL-AREA-ORIGIN 'AREA-ORIGIN)
						AREA))))
				DTP-FIX))
	       (RETURN T))
	      (T
	       (RETURN (QF-RETURN-ARRAY1 AREA ARRAY)))) ))

(DEFUN QF-RETURN-ARRAY1 (AREA ARRAY)
	(PROGN AREA ARRAY NIL))  ;NOT WRITTEN

(DEFUN QF-ARRAY-AT-END-OF-AREA-P (AREA ARRAY)
  (PROG (ARRAY-HEADER ARRAY-HEADER-POINTER CURRENT-STORAGE-LENGTH NEXT-ARRAY 
	 ARRAY-TYPE NDIMS LONG-ARRAY-FLAG CURRENT-INDEX-LENGTH ENTRIES-PER-Q 
	 DISPLACED-P)
	(DECLARE (FIXNUM ARRAY-HEADER ARRAY-HEADER-POINTER CURRENT-STORAGE-LENGTH
		         NEXT-ARRAY NDIMS CURRENT-INDEX-LENGTH))
	(COND ((NOT (= (QF-DATA-TYPE ARRAY) DTP-ARRAY-POINTER))
		(RETURN NIL)))
	(SETQ ARRAY-HEADER-POINTER (QF-POINTER ARRAY))
	(SETQ ARRAY-HEADER (QF-MEM-READ ARRAY-HEADER-POINTER))
	(SETQ ARRAY-TYPE (NTH (LOGLDB %%ARRAY-TYPE-FIELD ARRAY-HEADER)
			      ARRAY-TYPES))
	(SETQ NDIMS (LOGLDB %%ARRAY-NUMBER-DIMENSIONS ARRAY-HEADER))
	(COND ((NOT (= 0 (LOGLDB %%ARRAY-LONG-LENGTH-FLAG ARRAY-HEADER)))
		(SETQ LONG-ARRAY-FLAG T)))
	(SETQ CURRENT-INDEX-LENGTH 
		(COND ((NULL LONG-ARRAY-FLAG) 
			(LOGLDB %%ARRAY-INDEX-LENGTH-IF-SHORT ARRAY-HEADER))
		      (T (QF-POINTER (QF-MEM-READ (1+ ARRAY-HEADER-POINTER))))))
	(COND ((NULL (SETQ ENTRIES-PER-Q 
			(ASSQ ARRAY-TYPE ARRAY-ELEMENTS-PER-Q)))
		(RETURN NIL)))
	(SETQ ENTRIES-PER-Q (CDR ENTRIES-PER-Q))
	(SETQ DISPLACED-P (NOT (= 0 (LOGLDB %%ARRAY-DISPLACED-BIT ARRAY-HEADER))))
	(SETQ CURRENT-STORAGE-LENGTH 
		(+ NDIMS (COND (DISPLACED-P 2)
		  	       (T (// (+ CURRENT-INDEX-LENGTH (1- ENTRIES-PER-Q))
				      ENTRIES-PER-Q)))))
	(COND (LONG-ARRAY-FLAG (SETQ CURRENT-STORAGE-LENGTH (1+ CURRENT-STORAGE-LENGTH))))
	(SETQ NEXT-ARRAY (+ ARRAY-HEADER-POINTER
			    CURRENT-STORAGE-LENGTH))
	(COND ((AND (= NEXT-ARRAY 
		       (QF-POINTER (+ (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'AREA-FREE-POINTER)
						      AREA))
				      (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'AREA-ORIGIN) 
						      AREA)))))
		    (= (LOGLDB %%AREA-MODE-FREE-STORAGE
			       (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'AREA-MODE-BITS) AREA)))
		       FSM-LINEAR-ADVANCING))
		(RETURN T)))
))

;INITIALIZE ON FIRST LOADING
(OR (BOUNDP 'QF-AREA-ORIGIN-CACHE)
    (QF-CLEAR-CACHE T))