(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