(FILECREATED "27-Aug-86 14:09:04" {QV}<NOTECARDS>1.3K>NEXT>FGHPATCH098.;8 15140
changes to: (MACROS NC.GetCardTypeField)
previous date: "26-Aug-86 16:44:17" {QV}<NOTECARDS>1.3K>NEXT>FGHPATCH098.;6)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FGHPATCH098COMS)
(RPAQQ FGHPATCH098COMS ((* * Fixes to Inheritance mechanism to fix various bugs)
(* * redefined from NCTYPESMECH)
(RECORDS NoteCardType)
(FNS NC.CardTypeLoader NC.InheritFieldsFromSuperType NC.AddCardTypeStub)
(MACROS NC.GetCardTypeField)
(* * new for NCTYPESMECH)
(FNS NC.GetCardTypeFieldOfSuper)))
(* * Fixes to Inheritance mechanism to fix various bugs)
(* * redefined from NCTYPESMECH)
[DECLARE: EVAL@COMPILE
(DATATYPE NoteCardType (TypeName SuperType StubFlg FullDefinitionFile MakeFn (MakeFnInheritedFlg
FLAG)
EditFn
(EditFnInheritedFlg FLAG)
QuitFn
(QuitFnInheritedFlg FLAG)
GetFn
(GetFnInheritedFlg FLAG)
PutFn
(PutFnInheritedFlg FLAG)
CopyFn
(CopyFnInheritedFlg FLAG)
MarkDirtyFn
(MarkDirtyFnInheritedFlg FLAG)
DirtyPFn
(DirtyPFnInheritedFlg FLAG)
CollectLinksFn
(CollectLinksFnInheritedFlg FLAG)
DeleteLinksFn
(DeleteLinksFnInheritedFlg FLAG)
UpdateLinkIconsFn
(UpdateLinkIconsFnInheritedFlg FLAG)
InsertLinkFn
(InsertLinkFnInheritedFlg FLAG)
TranslateWindowPositionFn
(TranslateWindowPositionFnInheritedFlg FLAG)
LinkDisplayMode
(LinkDisplayModeInheritedFlg FLAG)
DefaultWidth
(DefaultWidthInheritedFlg FLAG)
DefaultHeight
(DefaultHeightInheritedFlg FLAG)
LinkAnchorModesSupported
(LinkAnchorModesSupportedInheritedFlg FLAG)
DisplayedInMenuFlg
(DisplayedInMenuFlgInheritedFlg FLAG)
LinkIconAttachedBitMap
(LinkIconAttachedBitMapInheritedFlg FLAG)
LeftButtonMenuItems
(LeftButtonMenuItemsInheritedFlg FLAG)
MiddleButtonMenuItems
(MiddleButtonMenuItemsInheritedFlg FLAG))
MakeFnInheritedFlg ← T EditFnInheritedFlg ← T QuitFnInheritedFlg ← T
GetFnInheritedFlg ← T PutFnInheritedFlg ← T CopyFnInheritedFlg ← T
MarkDirtyFnInheritedFlg ← T DirtyPFnInheritedFlg ← T CollectLinksFnInheritedFlg ← T
DeleteLinksFnInheritedFlg ← T UpdateLinkIconsFnInheritedFlg ← T
InsertLinkFnInheritedFlg ← T TranslateWindowPositionFnInheritedFlg ← T
DefaultWidthInheritedFlg ← T DefaultWidthInheritedFlg ← T DefaultHeightInheritedFlg ←
T LinkAnchorModesSupportedInheritedFlg ← T LinkIconAttachedBitMapInheritedFlg ← T
LeftButtonMenuItemsInheritedFlg ← T MiddleButtonMenuItemsInheritedFlg ← T
DisplayedInMenuFlgInheritedFlg ← NIL MakeFn ← (QUOTE \\EMPTY//)
EditFn ← (QUOTE \\EMPTY//)
QuitFn ← (QUOTE \\EMPTY//)
GetFn ← (QUOTE \\EMPTY//)
PutFn ← (QUOTE \\EMPTY//)
CopyFn ← (QUOTE \\EMPTY//)
MarkDirtyFn ← (QUOTE \\EMPTY//)
DirtyPFn ← (QUOTE \\EMPTY//)
CollectLinksFn ← (QUOTE \\EMPTY//)
DeleteLinksFn ← (QUOTE \\EMPTY//)
UpdateLinkIconsFn ← (QUOTE \\EMPTY//)
InsertLinkFn ← (QUOTE \\EMPTY//)
TranslateWindowPositionFn ← (QUOTE \\EMPTY//)
LinkDisplayMode ← (QUOTE \\EMPTY//)
DefaultWidth ← (QUOTE \\EMPTY//)
DefaultHeight ← (QUOTE \\EMPTY//)
LinkAnchorModesSupported ← (QUOTE \\EMPTY//)
DisplayedInMenuFlg ← (QUOTE \\EMPTY//)
LinkIconAttachedBitMap ← (QUOTE \\EMPTY//)
LeftButtonMenuItems ← (QUOTE \\EMPTY//)
MiddleButtonMenuItems ← (QUOTE \\EMPTY//))
]
(/DECLAREDATATYPE (QUOTE NoteCardType)
(QUOTE (POINTER POINTER POINTER POINTER POINTER FLAG POINTER FLAG POINTER FLAG
POINTER FLAG POINTER FLAG POINTER FLAG POINTER FLAG POINTER FLAG
POINTER FLAG POINTER FLAG POINTER FLAG POINTER FLAG POINTER FLAG
POINTER FLAG POINTER FLAG POINTER FLAG POINTER FLAG POINTER FLAG
POINTER FLAG POINTER FLAG POINTER FLAG))
(QUOTE ((NoteCardType 0 POINTER)
(NoteCardType 2 POINTER)
(NoteCardType 4 POINTER)
(NoteCardType 6 POINTER)
(NoteCardType 8 POINTER)
(NoteCardType 8 (FLAGBITS . 0))
(NoteCardType 10 POINTER)
(NoteCardType 10 (FLAGBITS . 0))
(NoteCardType 12 POINTER)
(NoteCardType 12 (FLAGBITS . 0))
(NoteCardType 14 POINTER)
(NoteCardType 14 (FLAGBITS . 0))
(NoteCardType 16 POINTER)
(NoteCardType 16 (FLAGBITS . 0))
(NoteCardType 18 POINTER)
(NoteCardType 18 (FLAGBITS . 0))
(NoteCardType 20 POINTER)
(NoteCardType 20 (FLAGBITS . 0))
(NoteCardType 22 POINTER)
(NoteCardType 22 (FLAGBITS . 0))
(NoteCardType 24 POINTER)
(NoteCardType 24 (FLAGBITS . 0))
(NoteCardType 26 POINTER)
(NoteCardType 26 (FLAGBITS . 0))
(NoteCardType 28 POINTER)
(NoteCardType 28 (FLAGBITS . 0))
(NoteCardType 30 POINTER)
(NoteCardType 30 (FLAGBITS . 0))
(NoteCardType 32 POINTER)
(NoteCardType 32 (FLAGBITS . 0))
(NoteCardType 34 POINTER)
(NoteCardType 34 (FLAGBITS . 0))
(NoteCardType 36 POINTER)
(NoteCardType 36 (FLAGBITS . 0))
(NoteCardType 38 POINTER)
(NoteCardType 38 (FLAGBITS . 0))
(NoteCardType 40 POINTER)
(NoteCardType 40 (FLAGBITS . 0))
(NoteCardType 42 POINTER)
(NoteCardType 42 (FLAGBITS . 0))
(NoteCardType 44 POINTER)
(NoteCardType 44 (FLAGBITS . 0))
(NoteCardType 46 POINTER)
(NoteCardType 46 (FLAGBITS . 0))
(NoteCardType 48 POINTER)
(NoteCardType 48 (FLAGBITS . 0))))
(QUOTE 50))
(DEFINEQ
(NC.CardTypeLoader
(LAMBDA (TypeName FileSuggestion QuietFlg) (* fgh: "26-Aug-86 12:06")
(* * Load card type TypeName using FileSuggestion as the first place to look. Otherwise look in the directories
specified by NoteCardsDirectories.)
(* * fgh 2/3/86 First written.)
(* * kirk 1Jul86 Added new process.)
(* * kirk 15Jul86 Removed new process and added FGH's RESETLST to close stream.)
(* * fgh 7/16/86 Added PRINTOUT to inform user before find file begins.)
(* * kirk 8/7/86 Added QuietFlg. Will not stop LOAD messages though.)
(* * kirk 19/8/86 Added set QuietFlg T in OPENWP check)
(* * fgh 8/26/86 Changed LOAD? to a LOAD. If we are at this point there must bve some reason we need to reload the
file even if its alreadt been loaded.)
(RESETLST (RESETSAVE NIL (if (OPENWP (WFROMDS (TTYDISPLAYSTREAM)
T))
then (SETQ QuietFlg T)
(QUOTE (NILL))
else (BQUOTE (CLOSEW , (WFROMDS (TTYDISPLAYSTREAM))))))
(LET (FullFileName (Window (WFROMDS (TTYDISPLAYSTREAM))))
(if (NOT QuietFlg)
then (CLEARW Window)
(FLASHWINDOW Window)
(PRINTOUT Window "Card type " TypeName " not loaded." T
"Attempting to autoload."
T))
(SETQ FullFileName (NC.FindCardTypeFile TypeName FileSuggestion))
(AND FullFileName (LOAD FullFileName NC.LOADFLG))))))
(NC.InheritFieldsFromSuperType
(LAMBDA (TypeNameOrRecord SuperTypeRecord) (* fgh: "26-Aug-86 12:28")
(* * Inherit fields from super card type record if the supertype is not a stub.)
(* * fgh 2/3/86 First created.)
(* * fgh 8/26/86 Now uses SuperTypeRecord consistently if it is present.)
(LET ((TypeRecord (if (type? NoteCardType TypeNameOrRecord)
then TypeNameOrRecord
else (NC.CardTypeRecord TypeNameOrRecord)))
(InheritedFlgNames (CONSTANT (for FieldName in (RECORDFIELDNAMES (QUOTE
NoteCardType))
when (EQ (QUOTE InheritedFlg)
(SUBATOM FieldName -12 -1))
collect FieldName)))
FieldName)
(if (NULL (fetch (NoteCardType StubFlg) of (OR SuperTypeRecord
(NC.CardTypeRecord
(fetch (NoteCardType SuperType)
of TypeRecord)))))
then (for FlgName in InheritedFlgNames when (RECORDACCESS (BQUOTE
(NoteCardType
, FlgName))
TypeRecord NIL
(QUOTE fetch)
NIL)
do (SETQ FieldName (SUBATOM FlgName 1 -13))
(RECORDACCESS (BQUOTE (NoteCardType , FieldName))
TypeRecord NIL (QUOTE replace)
(RECORDACCESS (BQUOTE (NoteCardType , FieldName))
(OR SuperTypeRecord
(NC.CardTypeRecord
(fetch (NoteCardType SuperType)
of TypeRecord)))
NIL
(QUOTE fetch))))))))
(NC.AddCardTypeStub
(LAMBDA (TypeName SuperType FullDefinitionFileName FnsAssocList VarsAssocList)
(* fgh: "26-Aug-86 16:34")
(* * Create a card type stub to hold as a place holder until the actual card type is autoloaded.)
(* * If FullDefinitionFileName is not supplied, one is constructed from the type name.)
(* * kirk 18Jun86 Changed to use FullDefinitionFileName and deal with NIL or UnLoaded SuperType.
Now gets called recursively in that case. Hence, the above warning.)
(* * fgh 8/26/86 Revamped. Now attempts to load supertype stub or whole definition if not already loaded.
Must be called with valid SuperType arg.)
(LET (NewType AddTypeFn AddTypeForm (MainFieldNames (CONSTANT (for FieldName
in (RECORDFIELDNAMES
(QUOTE NoteCardType))
when (NEQ (QUOTE
InheritedFlg)
(SUBATOM
FieldName -12
-1))
collect FieldName))))
(if (NULL TypeName)
then (NC.ReportError NIL "Illegal type name: NIL"))
(if (NULL SuperType)
then (NC.ReportError NIL "Illegal super type name: NIL"))
(* * If the super type is not loaded, then try to load it.)
(if (NULL (NC.CardTypeRecord SuperType))
then (OR (NC.CardTypeStubLoader SuperType NIL T)
(NC.CardTypeLoader SuperType))
(if (NULL (NC.CardTypeRecord SuperType))
then (NC.ReportError NIL (CONCAT "Unable to load card type " SuperType))
))
(* * Create new NoteCardType)
(SETQ NewType (create NoteCardType
TypeName ← TypeName
SuperType ← SuperType
StubFlg ← T
FullDefinitionFile ← FullDefinitionFileName))
(for AssocPair in (APPEND FnsAssocList VarsAssocList) when (FMEMB (CAR AssocPair)
MainFieldNames)
do
(* * Set the proper field to the given value)
(RECORDACCESS (BQUOTE (NoteCardType , (CAR AssocPair)))
NewType NIL (QUOTE replace)
(CADR AssocPair)))
(* * Stash the new card type record, reset the menu and then return.)
(PUTHASH TypeName NewType NC.CardTypes)
(SETQ NC.NoteCardTypeMenu)
NewType)))
)
(DECLARE: EVAL@COMPILE
(DEFMACRO NC.GetCardTypeField (FieldName CardTypeNameForm)
(* * Fetch the card type datatype field passed directly for FieldName
(for the card type whose name is in a variable passed as the second parameter))
(* * rht 4/11/86: Was trying to autoload if field of card type was nil. Now only tries to
autoload if CardTypeRecord is nil or if StubFlg is non-nil.)
(* * fgh 4/25/86 Fix to above fix. Checks for CardTypeRecord before doing fetch's in 2
cluase of COND.)
(* * kirk&fgh 26Jun86 Added check for InheritedFlg to above fix. Changed to a DEFMACRO)
(* * fgh 8/26/86 Revamped completely to clean up and to account for case where one of
supertypes is a stub and must be autoloaded. Added ability to handle \\EMPTY// fields.)
(BQUOTE (LET ((CardTypeName , CardTypeNameForm)
CardTypeRecord)
(if (AND (SETQ CardTypeRecord (NC.CardTypeRecord CardTypeName))
(NEQ (fetch (NoteCardType , FieldName)
of CardTypeRecord)
(QUOTE \\EMPTY//)))
then
(* * card type record exists and specified field has a value -- return it.)
(fetch (NoteCardType , FieldName)
of CardTypeRecord)
elseif
(OR (NULL CardTypeRecord)
(fetch (NoteCardType StubFlg)
of CardTypeRecord))
then
(* * either the card type record doesn't exist or its just a stub --
either way it needs to be autoloaded.)
(if (NC.AutoLoadCardType CardTypeName (QUOTE , FieldName)
(AND CardTypeRecord (fetch (NoteCardType
FullDefinitionFile)
of CardTypeRecord)))
then
(fetch (NoteCardType , FieldName)
of
(NC.CardTypeRecord CardTypeName))
else
(NC.ReportError NIL (CONCAT "Unknown note card type: " CardTypeName
" or card type field name: "
(QUOTE , FieldName))))
elseif
(AND , (FMEMB (PACK* FieldName (QUOTE InheritedFlg))
(RECORDFIELDNAMES (QUOTE NoteCardType)))
(fetch (NoteCardType , (PACK* FieldName (QUOTE InheritedFlg)))
of CardTypeRecord))
then
(* * card type record exists and is not a stub, but specified field is
\\EMPTY//. And this field can be inherited. Must be that someone on the
supertypes chain is a stub. Rectify the situation by fetching the filed
from the supertype. Unfortunately direct recursion is not possible
because this is a DEFMACRO.)
(NC.GetCardTypeFieldOfSuper CardTypeName (QUOTE , FieldName))
else
(* * card type record exists and is not a stub, but specified field is
\\EMPTY//. And this field can NOT be inherited. Thus, this record is
underspecified. Signal the error.)
(NC.ReportError NIL (CONCAT
"Non-inheritable field not specified for card type "
CardTypeName))))))
)
(* * new for NCTYPESMECH)
(DEFINEQ
(NC.GetCardTypeFieldOfSuper
(LAMBDA (CardTypeName FieldName) (* fgh: "26-Aug-86 12:12")
(* * Get the specifdied field from the super of CardTypeName)
(* * fgh 8/26/86 First created as companion for MACRO NC.GetCardTypeField.)
(EVAL (BQUOTE (NC.GetCardTypeField , FieldName (fetch (NoteCardType SuperType)
of (NC.CardTypeRecord CardTypeName))))))
)
)
(PUTPROPS FGHPATCH098 COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5827 11649 (NC.CardTypeLoader 5837 . 7436) (NC.InheritFieldsFromSuperType 7438 . 9101)
(NC.AddCardTypeStub 9103 . 11647)) (14596 15058 (NC.GetCardTypeFieldOfSuper 14606 . 15056)))))
STOP