(FILECREATED "26-SEP-77 22:47:11" <KRL1>MEMSTRUC.;71 25628
changes to: KrlSysoutAdvice InitKrlMem
previous date: "26-SEP-77 21:25:40" <KRL1>MEMSTRUC.;70)
(PRETTYCOMPRINT MEMSTRUCCOMS)
(RPAQQ MEMSTRUCCOMS ((* Defines stuff for memory level structures on a fiel)
(FILEDOC)
(F: MEMFNS)
(MACROS: MEMMACS)
(DMACROS: MEMDMACS)
(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: MEMFNS))
(RPAQQ MEMFNS (AllocateFileObject COPYFILE CreateSpace Doublet FileObjectName FindCurrentPage
GetFileObject GetStringFromFile HandleFor InitKrlMem KrlSysoutAdvice MYFAILEDMAPIN MakeKCTemplate
PutStringOnFile 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: "26-SEP-77 17:36" 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 (CONSTANT (CONCAT ""]
! [MKATOM (SUBSTRING s n+1 NIL (CONSTANT (CONCAT ""]>)
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])
(GetStringFromFile
[LAMBDA (handle)
[CLISP:(BLOCKRECORD STRINGDEST ((LENGTH BITS 14] (* ht: "21-SEP-77 11:32" posted: "21-SEP-77 12:34")
(* Returns a temporary string pointer to the string designated by handle, which was created by PutStringOnFile.
Note that the 14 above is the number of bits that we can store in 2 bytes, not the max number of bytes in a LISP
string.)
(PROG ((COREADR (HLOC handle)))
(RETURN (ASSEMBLE NIL
(CQ (CONSTANT (CONCAT)))
[CQ2 (VAG (LOGOR (LLSH (fetch LENGTH of COREADR)
25Q)
(IPLUS 2 (ITIMES 5 (LOC COREADR]
(MOVEM 2 , 0 (1])
(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: "26-SEP-77 22:46" 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 'MEMORY
'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: "26-SEP-77 22:45" 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
(PACKFILENAME 'DIRECTORY USERNAME 'NAME
OLDKRLMEMFILE 'EXTENSION 'KRL))
(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))) >])
(PutStringOnFile
[LAMBDA (ptr oldHandle)
[CLISP:(BLOCKRECORD INTEGER ((I INTEGER)))
(BLOCKRECORD STRINGDEST ((LENGTH BITS 14] (* ht: "21-SEP-77 11:35" posted: "21-SEP-77 12:33")
(* Note that 14 is the number of length bits we can store in 2 bytes, not the length field of a LISP string pointer,
which is 15)
(if ~oldHandle
then oldHandle←(create FileHandle))
(PROG [COREADR (STRINGLENGTH (CONSTANT (IPLUS 10000000)))
(BYTEPTR (CONSTANT (IPLUS 10000000]
(ASSEMBLE NIL
(CQ (SELECTQ (NTYP ptr)
(30Q ptr)
[14Q (CDR (VAG (IPLUS 2 (LOC ptr]
(ERROR ptr "not atom or string")))
(PUSHJ CP , UPATM) (* Now 4 has #bytes, 3 has bytepointer to firstbyte-1)
(CQ STRINGLENGTH) (* Length might be large, so use box)
(MOVEM 4 , 0 (1))
(CQ BYTEPTR)
(MOVEM 3 , 0 (1)))
(COREADR←(HLOC (AllocateFileObject (6+STRINGLENGTH:I)/5 NIL
(CONSTANT (KrlTypeCode 'CharacterString))
NIL oldHandle)))
(* Now copy characters from BYTEPTR to a "string" beginning at COREADR. STRINGLENGTH will be stored in the first 2
bytes of COREADR, so the string is actually STRINGLENGTH+2 bytes long, hence the constant 6 instead of 4 above.)
(COREADR:LENGTH←STRINGLENGTH:I) (* Store the length in the first two bytes.)
(ASSEMBLE NIL
(CQ (VAG (fetch I of STRINGLENGTH)))
(MOVE 5 , 1)
(CQ COREADR)
(HRLI 1 , 260700Q) (* The destination byte pointer)
(CQ2 BYTEPTR)
(MOVE 2 , 0 (2))
LP (ILDB 3 , 2)
(IDPB 3 , 1)
(SOJG 5 , LP))
(RETURN oldHandle])
(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
(RPAQQ MEMMACS (CheckHandle ClearField ConstantHandle FetchMem HLOC HandleValue KrlCreate LispFor
MYMAPIN NLoadField NSetField NewHandle PMAP SetHandleFlag SmashHandle StoreMem TestHandleFlag))
(DEFINEP
[CheckHandle
MACRO [H (PROGN (SUBST (CAR H)
(QUOTE H)
(COND
[CHECKHANDLEFLG (QUOTE (ASSEMBLE NIL
(CQ H)
(VAR (CKUDT DFileHandle% DATATYPE]
(T (QUOTE H] ]
[ClearField
MACRO [(H N)
(PROGN (ASSEMBLE NIL
(CQ (HLOC H))
(SETZM 0 , N (1] ]
[ConstantHandle
MACRO (NIL (CONSTANT (create FileHandle))) ]
[FetchMem
MACRO (X (PROGN (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)
(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)
(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 (LOC (ASSEMBLE NIL
(CQ (HLOC D))
(MOVE 1 , N (1] ]
[NSetField
MACRO [(D N V)
(PROGN (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 (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 (ASSEMBLE NIL
(CQ (CheckHandle D))
(CQ2 V)
(HLRZ 3 , 0 (1))
(TRZ 3 , M)
(CAME 2 , KNIL)
(TRO 3 , M)
(HRLM 3 , 0 (1)))
V)) ]
[SmashHandle
MACRO [(H F OH)
(PROGN (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 (replace F of H with (HandleValue VH] ]
[TestHandleFlag
MACRO [(D M)
(PROGN (ASSEMBLE NIL
(CQ (CheckHandle D))
(HLRZ 2 , 0 (1))
(HRRZ 1 , ' NIL)
(TRNE 2 , M)
(HRRZ 1 , ' T] ]
)
)
(RPAQQ MEMDMACS (MEMDMACS))
(MacroDoc
[MEMDMACS NIL NIL]
)
(PUTPROPS LDV2@ OPD ((V)
(MOVE 2 , @ V)))
(RPAQ SYSSPACEDIRECTORY NIL)
(DECLARE: DONTCOPY
(FILEMAP (NIL (3026 19711 (AllocateFileObject 3038 . 4971) (COPYFILE 4975 . 5269) (CreateSpace 5273 .
6514) (Doublet 6518 . 7365) (FileObjectName 7369 . 8025) (FindCurrentPage 8029 . 8977) (GetFileObject
8981 . 10300) (GetStringFromFile 10304 . 10983) (HandleFor 10987 . 12258) (InitKrlMem 12262 . 13688) (
KrlSysoutAdvice 13692 . 14481) (MYFAILEDMAPIN 14485 . 15988) (MakeKCTemplate 15992 . 16509) (
PutStringOnFile 16513 . 18320) (ReleaseHandle 18324 . 18772) (SetLispArray 18776 . 19168) (SpaceName
19172 . 19708)))))
STOP