(FILECREATED "18-SEP-77 19:31:34" <KRL1>MEMSTRUC.;63 26247  

     changes to:  MEMSTRUCCOMS

     previous date: "15-SEP-77 08:39:07" <KRL1>MEMSTRUC.;62)


(PRETTYCOMPRINT MEMSTRUCCOMS)

(RPAQQ MEMSTRUCCOMS ((* Defines stuff for memory level structures on a fiel)
	(FILEDOC)
	(F: (AllocateFileObject COPYFILE CreateSpace Doublet FileObjectName FindCurrentPage 
				GetFileObject HandleFor InitKrlMem KrlSysoutAdvice MYFAILEDMAPIN 
				MakeKCTemplate ReleaseHandle SetLispArray SpaceName))
	(MACROS: (CheckHandle ClearField ConstantHandle FetchMem HLOC HandleValue KrlCreate LispFor 
			      MYMAPIN NLoadField NSetField NewHandle PMAP SetHandleFlag SmashHandle 
			      StoreMem TestHandleFlag))
	(DMACROS: (KrlCreate FetchMem StoreMem))
	(PROP OPD LDV2@)
	(VARS (SYSSPACEDIRECTORY))))





(* Defines stuff for memory level structures on a fiel)


(DECLARE: DONTCOPY (*
Externally available functions:

   FileObjectName:  Gets name for handle, either atom or cons of two atoms
   GetFileObject:  Tries to find object with given name, either string, atom or cons of two. returns NIL if not there, smashing 
	oldHandle to 0 if there. If found, reuses oldHandle if there, sets type to type or guesses based on name, sets 
	Named and/or Primary if appropriate, returns handle
   HandleFor:  Returns a pseudo handle to an arbitrary S expression, reusing oldHandle if present. If it is a PseudoHandle, 
	will reuse its slot in the array, thus freeing the old contents

Externally available variables:

   None

Masterscope database on file MEMSTRUC.DATABASE

External functions called: 

   CLOSEHASHFILE: 
   OPENHASHFILE: 
   EVALNEXUS:  This is the defeval fn for nexuses
   GETHASHFILE: 
   KrlTypeName:  Converts a type code to a type ame for a memory structure
   GETPNAME:  Returns a temporary string pointer to the PNAME of ATOMPTR.
   GETPAGE:  Returns the page number of a virgin page in HASHFILE. Available to a user who wants non-hash pages in the file
   KrlTypeCode:  Looks up the type code for a memory structure
   PUTHASHFILE: 

External variables used freely: 

   SYSHASHFILE:  The KRL memory file
   OLDKRLMEMFILE:  address space file from previous sysout
   KRLMEMFILE:  Address space file for KRL memory structures
   MAXKRLMEMIO:  size of arrays of file-to-core pointers
   MAXKRLMEMLAI:  size of array of arrays for file-to-core pointers
   KRLMEMLISPARRAY:  array of arrays for file-to-core pointers
   KRLMEMCARFLG:  if T then last stored file-to-core poitner used SETA else SETD
   KRLMEMITEMOFFSET:  current slot in current array for file-to-core pointers
   KRLMEMLAINDEX:  Last used slot in the array of arrays for file-to-core pointers
   CURRENTMEMORYSPACE:  The space in which objects are allocated faut de mieux
))

(InitDoc MEMSTRUC (FileObjectName GetFileObject HandleFor)
		  NIL
		  (PUTHASHFILE GETHASHFILE OPENHASHFILE CLOSEHASHFILE))(PRETTYCOMPRINT (F: (AllocateFileObject COPYFILE CreateSpace Doublet FileObjectName FindCurrentPage 
GetFileObject HandleFor InitKrlMem KrlSysoutAdvice MYFAILEDMAPIN MakeKCTemplate ReleaseHandle 
SetLispArray SpaceName)))
(DEFINEQ

(AllocateFileObject
  [LAMBDA (#words name type space handle)              (* ht: "14-JUL-77 12:03" posted: " 7-JUN-77 15:59")
                                                       (* returns a handle to a new object)
    (if #words GT 509
	then (ERROR #words "exceeds max. object size (509)"))
    (if ~space
	then space←(OR CURRENTMEMORYSPACE 'NeutralSpace))
    (if ~handle
	then handle←(create FileHandle))
    (PROG ((dirEnt (FindCurrentPage space))
	   nfw curPagePtr oldPagePtr dirBlockPtr fw)
          (curPagePtr←dirEnt:spacePagePtr)
          (if nfw←(fw←dirEnt:spaceFreeWord)+#words GT 512
	      then (dirBlockPtr←dirEnt:spaceBlockPtr)
		   (if ~(AND (EQP dirBlockPtr:currentPagePtr (HandleValue curPagePtr))
			     (EQP dirBlockPtr:currentPageIndex dirEnt:spacePageIndex)
			     (EQP curPagePtr:firstFreeWord dirEnt:spaceFreeWord))
		       then (HELP "inconsistent directory entry"))
		   (oldPagePtr←curPagePtr)
		   [curPagePtr←(create FileHandle filePage# ←(GETPAGE)
				       hType ←(CONSTANT (KrlTypeCode 'FilePage]
		   (curPagePtr:firstFreeWord←3)
		   (StoreMem curPagePtr predecessorPagePtr oldPagePtr)
		   (StoreMem curPagePtr spaceIDPtr dirBlockPtr)
		   (dirEnt:spacePagePtr←curPagePtr)
		   (StoreMem dirBlockPtr currentPagePtr curPagePtr)
		   (dirEnt:spaceFreeWord←fw←3)
		   (dirBlockPtr:currentPageIndex←(dirEnt:spacePageIndex←dirEnt:spacePageIndex+1))
		   (nfw←fw+#words))
          (curPagePtr:firstFreeWord←nfw)
          (dirEnt:spaceFreeWord←nfw)
          (handle:filePage#←curPagePtr:filePage#)
          (handle:fileWord#←fw)
          (handle:hType←(OR type 0))
          (handle:hFlags←0)
          (if name
	      then (PUTHASHFILE (if (NLISTP name)
				    then name
				  else (Doublet name:1 name::1))
				handle))
          (RETURN handle])

(COPYFILE
  [LAMBDA (FROM TO)                                    (* ht: "15-JUN-77 12:57" posted: "14-JUN-77 17:47")
                                                       (* Uses SUBSYS to do it)
    (TENEX (CONCAT "COPY " FROM " " TO←(OUTFILEP TO)
		   " "))
    TO])

(CreateSpace
  [LAMBDA (name)                                       (* ht: "14-JUL-77 12:04" posted: "15-JUN-77 14:33")
                                                       (* creates a new space in the memory file, error if already 
						       there)
    (PROG (fp1 fp2 cp (fw 3))
          (if (FindCurrentPage name T)
	      then (ERROR name "is already a space name"))
          (cp←(GETPAGE))
          (if name='SpaceDirectory
	      then [fp1←(create FileHandle filePage# ← cp fileWord# ← 3 hType ←(CONSTANT
				  (KrlTypeCode 'SpaceAllocBlock]
		   (PUTHASHFILE (Doublet "KrlSysMemSpace" name)
				fp1)
		   (fw←6)
	    else fp1←(KrlCreate SpaceAllocBlock <"KrlSysMemSpace" ! name> 'SpaceDirectory))
          (fp1:currentPageIndex←1)
          [fp2←(create FileHandle filePage# ← cp hType ←(CONSTANT (KrlTypeCode 'FilePage]
          (StoreMem fp1 currentPagePtr fp2)
          (fp2:firstFreeWord←fw)
          (StoreMem fp2 spaceIDPtr fp1)
          (fp2:predecessorPagePtr←0)
          (push SYSSPACEDIRECTORY
		(<name
		   ! (create SpaceDirEntry spacePagePtr ← fp2 spacePageIndex ← 1 spaceFreeWord ← fw 
			     spaceBlockPtr ← fp1) >])

(Doublet
  [LAMBDA (s1 s2 scratchString scratchPtr)             (* ht: "15-JUN-77 23:33" posted: "15-JUN-77 17:20")
                                                       (* makes two strings into a single one for hashing uniquely 
						       (almost))
    (PROG ((nc ((NCHARS s1)+ 1)))
          (if ~scratchString
	      then scratchString←(CONSTANT (CONCAT 

"                                                                                                                               "
						   )))
          (if ~scratchPtr
	      then scratchPtr←(CONSTANT (CONCAT "")))
          (RPLSTRING scratchString 1 s1)
          (RPLSTRING scratchString nc (FCHARACTER 0))
          (RPLSTRING scratchString nc+1 s2)
          (RETURN (SUBSTRING scratchString 1 nc+(NCHARS s2)
			     scratchPtr])

(FileObjectName
  [LAMBDA (h noErrFlg)                                 (* ht: "15-SEP-77 08:38" posted: "14-JUL-77 13:11")
                                                       (* Gets name for handle, either atom or cons of two atoms)
    (PROG ((s (GETPNAME h))
	   n)
          (if s
	      then (if n←(STRPOS (FCHARACTER 0)
				 s)
		       then (RETURN <(MKATOM (SUBSTRING s 1 n-1)) ! (MKATOM (SUBSTRING s n+1))>)
		     else (RETURN (MKATOM s)))
	    else (if noErrFlg
		     then (RETURN)
		   else (ERROR "not a file object" h])

(FindCurrentPage
  [LAMBDA (space flg)                                  (* ht: "14-JUL-77 11:58" posted: "15-JUN-77 17:20")
                                                       (* returns the in core directory entry for a space if Flg is 
						       NIL, otherwise returns T if space exists, NIL otherwise)
    (OR (CDR (FASSOC space SYSSPACEDIRECTORY))
	(PROG (fp1 fp2 de)
	      (if fp1←(GetFileObject <"KrlSysMemSpace" ! space> NIL
				     (CONSTANT (KrlTypeCode 'SpaceAllocBlock)))
		  then (if flg
			   then (RETURN T))
		       (de←(create SpaceDirEntry (spacePagePtr←fp2←(FetchMem fp1 currentPagePtr))
				   spacePageIndex ← fp1:currentPageIndex))
		       (de:spaceFreeWord←fp2:firstFreeWord)
		       (push SYSSPACEDIRECTORY (<space ! de>))
		       (RETURN de)
		else (if flg
			 then (RETURN)
		       else (ERROR space "is not a valid space name"])

(GetFileObject
  [LAMBDA (name oldHandle type)                        (* ht: "19-AUG-77 09:07" posted: "14-JUL-77 13:12")

          (* Tries to find object with given name, either string, atom or cons of two. returns NIL if not there, smashing 
	  oldHandle to 0 if there. If found, reuses oldHandle if there, sets type to type or guesses based on name, sets Named
	  and/or Primary if appropriate, returns handle)


    (PROG [(v (GETHASHFILE (if (NLISTP name)
			       then name
			     else (Doublet name:1 name::1]
          (if v
	      then (if ~oldHandle
		       then oldHandle←(create FileHandle)
		     else (oldHandle:hFlags←0))
		   (oldHandle:fPtr←v)
		   [oldHandle:hType←(OR type (if (LISTP name)
						 then (CONSTANT (KrlTypeCode 'Anchor))
					       else (CONSTANT (KrlTypeCode 'MemUnit]
		   (SELECTQ (KrlTypeName oldHandle:hType)
			    (MemUnit oldHandle:Named←T)
			    (Anchor oldHandle:Named←T
				    oldHandle:Primary←T
                                                       (* this is really too simple. needs to check metaAnchor 
						       somehow)
				    )
			    NIL)
		   (RETURN oldHandle)
	    else (if oldHandle
		     then (oldHandle:fPtr←0))
		 (RETURN])

(HandleFor
  [LAMBDA (sExp oldHandle)                             (* ht: "13-SEP-77 11:39" posted: "28-JUN-77 17:28")

          (* Returns a pseudo handle to an arbitrary S expression, reusing oldHandle if present. If it is a PseudoHandle, will
	  reuse its slot in the array, thus freeing the old contents)


    (if (AND oldHandle oldHandle:hType=(CONSTANT (KrlTypeCode 'PseudoHandle)))
	then (SetLispArray oldHandle:array# oldHandle:itemOffset oldHandle:carFlg sExp)
      else [if KRLMEMCARFLG
	       then KRLMEMCARFLG←NIL
	     else (KRLMEMCARFLG←T)
		  (if (add KRLMEMITEMOFFSET 1) GT MAXKRLMEMIO
		      then (if (add KRLMEMLAINDEX 1) GT MAXKRLMEMLAI
			       then (HELP "Exceeded size of arrays for storing file-to-LISP pointers")
			     else (KRLMEMITEMOFFSET←1)
				  ((ELT KRLMEMLISPARRAY KRLMEMLAINDEX)←(ARRAY MAXKRLMEMIO]
	   (if oldHandle
	       then (oldHandle:hFlags←0)
	     else oldHandle←(create DFileHandle))
	   (oldHandle:hType←(CONSTANT (KrlTypeCode 'PseudoHandle)))
	   (SetLispArray oldHandle:array#←KRLMEMLAINDEX
			 oldHandle:itemOffset←KRLMEMITEMOFFSET
			 oldHandle:carFlg←KRLMEMCARFLG
			 sExp))
    oldHandle])

(InitKrlMem
  [LAMBDA NIL                                          (* ht: "13-SEP-77 17:19" posted: "14-JUN-77 18:53")
                                                       (* Figure what fiel to use for memory and open it properly)
    (DEFEVAL 'NEXUS (FUNCTION EVALNEXUS))
    (PROG ((flg ('SYMBOLTABLE))
	   (SYSBUFFERLISTSIZE 4))
          (if OLDKRLMEMFILE
	      then (printout NIL T "Old memory file is " OLDKRLMEMFILE "," T)
		   (GO OLDF))
          (SELECTQ [OLDKRLMEMFILE←(ASKUSER DWIMWAIT 'Y "Use a new (virgin) memory file? " '((Y "es
")
					    (N "o  old file name: " KEYLST (( NIL RETURN
										(CADR ANSWER]
		   (Y KRLMEMFILE←(OUTFILEP (PACKFILENAME 'DIRECTORY USERNAME 'NAME KRLMEMFILE 
							 'EXTENSION 'KRL))
		      (GO NEWF))
		   NIL)
      OLDF(KRLMEMFILE←(SELECTQ (ASKUSER DWIMWAIT 'C "use a Copy or Modify the original? " '((C "opy
")
					 (M "odify
")))
			       (M (INFILEP OLDKRLMEMFILE))
			       (C (COPYFILE (INFILEP OLDKRLMEMFILE)
					    (PACKFILENAME 'DIRECTORY USERNAME 'NAME KRLMEMFILE 
							  'EXTENSION 'KRL)))
			       (SHOULDNT)))
          (flg←T)
      NEWF(printout NIL T "Using " KRLMEMFILE " as memory file" T)
          (OLDKRLMEMFILE←NIL)
          (OPENHASHFILE KRLMEMFILE flg)
          (if flg='SYMBOLTABLE
	      then (CreateSpace 'SpaceDirectory)
		   (CreateSpace 'NeutralSpace])

(KrlSysoutAdvice
  [LAMBDA NIL                                          (* ht: "15-JUN-77 12:02" posted: "14-JUN-77 17:46")

          (* Checks to see if user wants memory saved and does so if wanted. WARNING!!! page pointers are not preserved across
	  calls to SYSOUT which do save memory!!!)


    (if SYSHASHFILE
	then (SELECTQ [OLDKRLMEMFILE←(ASKUSER DWIMWAIT 'N "Save state of KRL memory? " '([Y
						 "es  File name: " KEYLST (( NIL RETURN
									       (CADR ANSWER]
					       (N "o
"]
		      (N OLDKRLMEMFILE←KRLMEMFILE)
		      (PROGN (CLOSEHASHFILE)
			     OLDKRLMEMFILE←(COPYFILE KRLMEMFILE OLDKRLMEMFILE)
			     (OPENHASHFILE KRLMEMFILE T])

(MYFAILEDMAPIN
  [LAMBDA (PAGE#)
    [CLISP:(ARRAYBLOCK KHashFile ((HValueType BITS 22Q)
			(FileJfn BITS 22Q)
			(FullprintPage# BITS 22Q)
			(FullPrintMargin BITS 22Q)
			File Tag Write?)               (* must concur with defn in HASH)
		       )
      (ARRAYBLOCK KBufPage (Location (MappedFileJfn BITS 22Q)
				     (MappedPage BITS 22Q]
                                                       (* ht: "30-JUN-77 10:56" posted: "16-JUN-77 18:18")
                                                       (* picks up where the open coded version of mapin leaves off)
    (PROG (PGE BUFPAGE (PREV (SYSBUFFERLIST::1))
	       (TAIL (SYSBUFFERLIST::2)))
      LP  (BUFPAGE←TAIL:1)
          (if BUFPAGE:MappedPage=PAGE#
	      then                                     (* Do nothing; page is already in)
		   (PGE←BUFPAGE:Location)
	    elseif TAIL::1
	      then (PREV←TAIL)
		   (TAIL←TAIL::1)
		   (GO LP)
	    else (PMAP SYSHASHFILE:FileJfn PAGE# PGE←BUFPAGE:Location) 
                                                       (* Normal case: just map into this page)
		 (BUFPAGE:MappedPage←PAGE#))
          (PREV::1←TAIL::1)                            (* Splice this page into beginning)
          (TAIL::1←SYSBUFFERLIST::1)                   (* Smashing not really needed if PREV=SYSBUFFERLIST)
          (SYSBUFFERLIST::1←TAIL)
          (TAIL:1←(PROG1 SYSBUFFERLIST:1 SYSBUFFERLIST:1←TAIL:1))
          (RETURN PGE])

(MakeKCTemplate
  [LAMBDA (X)                                          (* ht: "13-JUL-77 16:26" posted: "23-JUN-77 16:21")
                                                       (* Kludge to build a structure with the right properties for 
						       masterscope to analyze KrlCreate forms)
    <!! <'PROG '(X)
	  <'create X:1> X:2 X:3 <'RPLACA X:4> <'fetch (PACK <X:1 'Length >)
						'of 'X >>
     ! (for f in X::4 collect (SUBST f 'f '(replace f of X with T))) >])

(ReleaseHandle
  [LAMBDA (handle)                                     (* ht: "29-JUN-77 10:42" posted: "28-JUN-77 17:27")
                                                       (* Stops a pseudo handle from pointing to what it was 
						       pointing to, by pointing it to NIL thereby possibly allowing 
						       garbage collection.)
    (SetLispArray handle:array# handle:itemOffset handle:carFlg)
    handle])

(SetLispArray
  [LAMBDA (array# itemOffset carFlg val)               (* ht: "13-SEP-77 10:57" posted: "29-JUN-77 11:03")
                                                       (* Sets an entry in a file-to-core array)
    (if carFlg
	then ((ELT (ELT KRLMEMLISPARRAY array#)
		   itemOffset)←val)
      else (SETD (ELT KRLMEMLISPARRAY array#)
		 itemOffset val])

(SpaceName
  [LAMBDA (handle oldHandle)                           (* ht: "14-JUL-77 12:13" posted: " 4-JUL-77 17:12")
                                                       (* Returns (as an atom) the name of the space in whihc the 
						       object for which handle is a handle resides)
    (if ~oldHandle
	then oldHandle←(create FileHandle))
    oldHandle:filePage#←handle:filePage#
    oldHandle:fileWord#←0
    (FetchMem oldHandle spaceIDPtr oldHandle)
    (FileObjectName oldHandle)::1])
)
(DECLARE: DOEVAL@COMPILE 
(DEFINEP

[CheckHandle
	MACRO [H (PROGN                                (* Takes a single arg. Gets a handle into AC1 and checks it 
						       if CHECKHANDLEFLG is non-NIL)
			(SUBST (CAR H)
			       (QUOTE H)
			       (COND
				 [CHECKHANDLEFLG (QUOTE (ASSEMBLE NIL
							          (CQ H)
							          (VAR (CKUDT DFileHandle%DATATYPE]
				 (T (QUOTE H] ]

[ClearField
	MACRO [(H N)
	       (PROGN                                  (* clears a field of an object for which H is a handle at 
						       offset N)
		      (ASSEMBLE NIL
			        (CQ (HLOC H))
			        (SETZM 0 , N (1] ]

[ConstantHandle
	MACRO (NIL (CONSTANT (create FileHandle))) ]

[FetchMem
	MACRO (X (PROGN 

          (* Args are (H F OH). Returns the handle found in field F of the object for which H is a handle.
	  If OH is present, smashes the value into it, otherwise builds a new handle Uses the record package to get the offset
	  for the field, see NFetchField.)


			(CONS (COND
				((CADDR X)
				  (QUOTE SmashHandle))
				(T (QUOTE NewHandle)))
			      X))) ]

[HLOC
	MACRO [(H)
	       (PROGN 

          (* Computes an in core pointer to the object which has H for a handle. Calls MAPIN, so result is only guaranteed 
	  until the next call to MAPIN.)


		      (ASSEMBLE NIL
			        (CQ (CheckHandle H))
			        (PUSHP)
			        (LDB 1 , = 111701000000Q)
			        [CQ (MYMAPIN (LOC (AC]
			        (POP PP , 3)
			        (HRRZ 2 , 0 (3))
			        (ANDI 2 , 777Q)
			        (ADDI 1 , 0 (2] ]

[HandleValue
	MACRO [(H)
	       (PROGN                                  (* Returns the (large number) contents of the handle itself, 
						       NOT where it points to. Used by StoreMem inside a VAG.)
		      (OPENR (LOC (CheckHandle H] ]

[KrlCreate
	MACRO [X (PROG ((rn (CAR X))
			(on (CADR X))
			(sp (CADDR X))
			(h (CADDDR X))
			(flgs (CDDDDR X))
			ty len form initFlg tfl)

          (* Args are (recordName objectName spaceName oldHandle . trueFlags) Allocates an object of the right size in the 
	  indicated space (or NeutralSpace), gives it its name if it has one, smashes a pointer into oldHandle or makes a new 
	  one, sets the type field appropriately, and turns on the indicated flags, if any. Initializes ends of multiword 
	  fields, if any, to empty extender pointers with lastEntry bit set)


		       (SETQ ty (OR (KrlTypeCode rn)
				    (ERROR rn "not a KRL structure")))
		       (SETQ len (RECORDACCESS (PACK (LIST (CAR X)
							   (QUOTE Length)))
					       X))
		       [SETQ initFlg (CAR (FMEMB (PACK (LIST (CAR X)
							     (QUOTE Init)))
						 (SETQ tfl (RECORDFIELDNAMES rn]
		       (SETQ form (LIST (QUOTE AllocateFileObject)
					len on ty sp h))
		       (RETURN (COND
				 [(OR flgs initFlg)
				   (APPEND [QUOTE (PROG ($$1)
						        (DECLARE (LOCALVARS $$1]
					   (CONS (LIST (QUOTE SETQ)
						       (QUOTE $$1)
						       form))
					   [COND
					     (flgs (for f in flgs
						      collect (COND
								[(OR (FMEMB f tfl)
								     (EQ f (QUOTE lastEntry)))
								  (SUBST f (QUOTE f)
									 (QUOTE (replace f of $$1
										   with T]
								(T (ERROR (LIST rn f)
									  "unknown flag"]
					   [COND
					     (initFlg (SUBST initFlg (QUOTE i)
							     (QUOTE ((replace i of $$1 with T]
					   (COPY (QUOTE ((RETURN $$1]
				 (T form] ]

[LispFor
	MACRO [X
		(DSUBST
		  (CAR X)
		  (QUOTE X)
		  ([LAMBDA (Y)
		      (if CHECKHANDLEFLG
			  then
			   (NCONC [COPY (QUOTE (AND (EQ (fetch hType of X)
							(CONSTANT (KrlTypeCode (QUOTE PseudoHandle]
				  (LIST Y))
			else Y]
		    (COPY (QUOTE (COND
				   ((fetch carFlg of X)
				     (ELT (ELT KRLMEMLISPARRAY (fetch array# of X))
					  (fetch itemOffset of X)))
				   (T (ELTD (ELT KRLMEMLISPARRAY (fetch array# of X))
					    (fetch itemOffset of X] ]

[MYMAPIN
	MACRO ((X)
	       (ASSEMBLE NIL
		         (CQ (VAG X))
		         (VAR (LDV2@ SYSBUFFERLIST))
		         (HLRZ 3 , 2 (2))              (* load MappedPage of CAR of SYSBUFFERLIST)
		         (CAMN 1 , 3)
		         (JRST GOTIT)
		         (HLRZ 2 , 2)                  (* CDR of SYSBUFFERLIST)
		         (MOVE 2 , 0 (2))              (* CADR of SYSBUFFERLIST)
		         (HLRZ 3 , 2 (2))              (* next MappedPage of CADR of SYSBUFFERLIST)
		         (CAME 1 , 3)
		         (JRST NOGOOD)
		     GOTIT
		         (HLRZ 1 , 3 (2))              (* location)
		         (JRST DONE)
		     NOGOOD
		         [CQ (MYFAILEDMAPIN (LOC (AC]
		     DONE)) ]

[NLoadField
	MACRO [(D N)
	       (PROGN 

          (* This is what field accesses compile into. Takes a handle and a numerical offset and loads the contents into AC1.
	  The boxing will normally be nullified by an enclosing VAG, see e.g. FetchMem.)


		      (LOC (ASSEMBLE NIL
				     (CQ (HLOC D))
				     (MOVE 1 , N (1] ]

[NSetField
	MACRO [(D N V)
	       (PROGN 

          (* Thsi is what field stores compile into. Takes a handle and an offset and a (large number) value and stores the 
	  value into the objectat the offset. The unboxing will normally be nullified by an enclosed LOC, see e.g. StoreMem.)


		      (ASSEMBLE NIL
			        (CQ (CheckHandle D))
			        (CQ2 (VAG V))
			        (PUSH PP , 2)
			        (PUSHP)
			        (LDB 1 , = 111701000000Q)
			        [CQ (MYMAPIN (LOC (AC]
			        (POP PP , 2)
			        (MOVE 2 , 0 (2))
			        (ANDI 2 , 777Q)
			        (ADDI 1 , 0 (2))
			        (POP PP , 2)
			        (MOVEM 2 , N (1] ]

[NewHandle
	MACRO [(H F)
	       (PROGN                                  (* Used by FetchMem (q.v.) when there is no old handle to 
						       reuse. Calls SmashHandle with a create.)
		      (SmashHandle H F (create FileHandle] ]

[PMAP
	MACRO ((FILEJFN PAGE# LOCATION)
	       (ASSEMBLE NIL
		         (CQ (VAG (LOGOR (LLSH FILEJFN 22Q)
					 PAGE#)))
		         (CQ2 LOCATION)
		         (LSH 2 , -11Q)
		         (HRLI 2 , 400000Q)
		         (HRLZI 3 , 140000Q)
		         (JSYS 56Q))) ]

[SetHandleFlag
	MACRO ((D M V)
	       (PROGN 

          (* M is an 18 bit mask with one bit set. Sets corresponding bit in high order half of D, which must be a file 
	  handle, to 1 or 0, depending on whether V is non-NIL or NIL. This is what foo:flag←x translates to.)


		      (ASSEMBLE NIL
			        (CQ (CheckHandle D))
			        (CQ2 V)
			        (HLRZ 3 , 0 (1))       (* load the high order half of the handle)
			        (TRZ 3 , M)            (* clear the bit)
			        (CAME 2 , KNIL)
			        (TRO 3 , M)            (* Set the bit if non-NIL)
			        (HRLM 3 , 0 (1))       (* store it back)
			    )
		      V)) ]

[SmashHandle
	MACRO [(H F OH)
	       (PROGN                                  (* Used by FetchMem (q.v.) when there is an old handle to 
						       reuse.)
		      (ASSEMBLE NIL
			        (CQ (VAG (fetch F of H)))
			        (PUSHP)
			        (E (PSTEP))
			        (CQ (CheckHandle OH))
			        (POP PP , 2)
			        (E (PSTEPN -1))
			        (MOVEM 2 , 0 (1] ]

[StoreMem
	MACRO [(H F VH)
	       (PROGN                                  (* Sets the F field of the object for which H is a handle to 
						       have in it the contents of handle VH)
		      (replace F of H with (HandleValue VH] ]

[TestHandleFlag
	MACRO [(D M)
	       (PROGN 

          (* M is an 18 bit mask with one bit set. Checks to see whether it is set in D, which must be a file handle This is 
	  what foo:flag translagtes to.)


		      (ASSEMBLE NIL
			        (CQ (CheckHandle D))
			        (HLRZ 2 , 0 (1))       (* load the high order half of the handle)
			        (HRRZ 1 , ' NIL)
			        (TRNE 2 , M)           (* skip if mask bit is 0)
			        (HRRZ 1 , ' T] ]
 )
)
(MacroDoc

[KrlCreate  (NIL (objectType objectName spaceName oldHandle trueFlag1 ... trueFlagN)) (! NIL CREATE 
EVAL EVAL SMASH .. REPLACE)]

[FetchMem  (NIL (handle field oldHandle)) (! NIL EVAL FETCH (IF (NOT (NULL EXPR)) SMASH) . PPE)]

[StoreMem  (handle field newValue) (! NIL EVAL REPLACE EVAL . PPE)]
)

(PUTPROPS LDV2@ OPD ((V)
		     (MOVE 2 , @ V)))

(RPAQ SYSSPACEDIRECTORY NIL)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (3335 17392 (AllocateFileObject 3347 . 5280) (COPYFILE 5284 . 5578) (CreateSpace 5582 . 
6823) (Doublet 6827 . 7674) (FileObjectName 7678 . 8279) (FindCurrentPage 8283 . 9231) (GetFileObject 
9235 . 10554) (HandleFor 10558 . 11829) (InitKrlMem 11833 . 13262) (KrlSysoutAdvice 13266 . 13973) (
MYFAILEDMAPIN 13977 . 15480) (MakeKCTemplate 15484 . 16001) (ReleaseHandle 16005 . 16453) (
SetLispArray 16457 . 16849) (SpaceName 16853 . 17389)))))
STOP