(FILECREATED "18-Jan-88 17:11:41" {QV}<NOTECARDS>1.3KNEXT>NCTYPESMECH.;8 34134
changes to: (FNS NC.DeleteCardType)
previous date: "30-Nov-87 15:49:14" {QV}<NOTECARDS>1.3KNEXT>NCTYPESMECH.;7)
(* Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NCTYPESMECHCOMS)
(RPAQQ NCTYPESMECHCOMS [(* * Internal variables)
(GLOBALVARS NC.CardTypes NC.TypesLock)
(INITVARS (NC.CardTypes NIL)
(NC.TypesLock (CREATE.MONITORLOCK "NoteCards Type Mechanism")))
(* * Note Cards Type Mechanism)
(RECORDS NoteCardType)
(MACROS NC.GetCardTypeField NC.ApplyFn NC.ApplySupersFn)
(FNS NC.IsSubTypeOfP NC.CardTypeRecord NC.MakeCardTypesList NC.AddCardType NC.AddCardTypeStub
NC.ModifyCardType NC.RecomputeCardType NC.ListOfCardTypes NC.SubTypesOfCardType
NC.DeleteCardType NC.InheritFieldsFromSuperType NC.PropagateCardTypeFieldsDownward
NC.AutoLoadCardType NC.CardTypeLoader NC.CardTypeStubLoader NC.GetCardTypeFieldOfSuper)
(BITMAPS NC.TypelessIcon)
(DECLARE: DONTEVAL@LOAD (P (NC.MakeCardTypesList])
(* * Internal variables)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS NC.CardTypes NC.TypesLock)
)
(RPAQ? NC.CardTypes NIL)
(RPAQ? NC.TypesLock (CREATE.MONITORLOCK "NoteCards Type Mechanism"))
(* * Note Cards Type Mechanism)
[DECLARE: EVAL@COMPILE
(DATATYPE NoteCardType (TypeName SuperType StubFlg FullDefinitionFile MakeFn (MakeFnInheritedFlg
FLAG)
EditFn
(EditFnInheritedFlg FLAG)
QuitFn
(QuitFnInheritedFlg FLAG)
MakeReadOnlyFn
(MakeReadOnlyFnInheritedFlg FLAG)
MakeReadWriteFn
(MakeReadWriteFnInheritedFlg 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
MakeReadOnlyFnInheritedFlg ← T MakeReadWriteFnInheritedFlg ← T GetFnInheritedFlg ← T
PutFnInheritedFlg ← T CopyFnInheritedFlg ← T MarkDirtyFnInheritedFlg ← T
DirtyPFnInheritedFlg ← T CollectLinksFnInheritedFlg ← T DeleteLinksFnInheritedFlg ← T
UpdateLinkIconsFnInheritedFlg ← T InsertLinkFnInheritedFlg ← T
TranslateWindowPositionFnInheritedFlg ← T LinkDisplayModeInheritedFlg ← T
DefaultWidthInheritedFlg ← T DefaultWidthInheritedFlg ← T DefaultHeightInheritedFlg ← T
LinkAnchorModesSupportedInheritedFlg ← T LinkIconAttachedBitMapInheritedFlg ← T
LeftButtonMenuItemsInheritedFlg ← T MiddleButtonMenuItemsInheritedFlg ← T
DisplayedInMenuFlgInheritedFlg ← NIL MakeFn ← (QUOTE \\FILLME//)
EditFn ← (QUOTE \\FILLME//)
QuitFn ← (QUOTE \\FILLME//)
MakeReadOnlyFn ← (QUOTE \\FILLME//)
MakeReadWriteFn ← (QUOTE \\FILLME//)
GetFn ← (QUOTE \\FILLME//)
PutFn ← (QUOTE \\FILLME//)
CopyFn ← (QUOTE \\FILLME//)
MarkDirtyFn ← (QUOTE \\FILLME//)
DirtyPFn ← (QUOTE \\FILLME//)
CollectLinksFn ← (QUOTE \\FILLME//)
DeleteLinksFn ← (QUOTE \\FILLME//)
UpdateLinkIconsFn ← (QUOTE \\FILLME//)
InsertLinkFn ← (QUOTE \\FILLME//)
TranslateWindowPositionFn ← (QUOTE \\FILLME//)
LinkDisplayMode ← (QUOTE \\FILLME//)
DefaultWidth ← (QUOTE \\FILLME//)
DefaultHeight ← (QUOTE \\FILLME//)
LinkAnchorModesSupported ← (QUOTE \\FILLME//)
DisplayedInMenuFlg ← (QUOTE \\FILLME//)
LinkIconAttachedBitMap ← (QUOTE \\FILLME//)
LeftButtonMenuItems ← (QUOTE \\FILLME//)
MiddleButtonMenuItems ← (QUOTE \\FILLME//))
]
(/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 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))
(NoteCardType 50 POINTER)
(NoteCardType 50 (FLAGBITS . 0))
(NoteCardType 52 POINTER)
(NoteCardType 52 (FLAGBITS . 0]
(QUOTE 54))
(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.)
(* * kirk 8/26/86 Added check for FMEMB of FieldName in (RECORDFIELDNAMES (QUOTE
NoteCardTYpe))
before evaling fetch)
(* * rht 11/1/86: Added check for NIL CardTypeName. Also checks whether card is top level
NoteCard type before fetching from super type.)
(* * rht 11/9/86: Totally revamped to use \\FILLME// field. No longer cares about value of
StubFlg.)
(BQUOTE (LET ((CardTypeName , CardTypeNameForm)
CardTypeRecord FieldValue)
(if CardTypeName then
[if (OR (NULL (SETQ CardTypeRecord (NC.CardTypeRecord CardTypeName)))
(EQ (SETQ FieldValue (fetch (NoteCardType , FieldName)
of CardTypeRecord))
(QUOTE \\EMPTY//)))
then
(* * either the card type record doesn't exist or its just a stub --
either way it needs to be autoloaded.)
(if [OR [NULL (NC.CardTypeLoader CardTypeName
(AND CardTypeRecord
(fetch (NoteCardType
FullDefinitionFile)
of CardTypeRecord]
(NULL (SETQ CardTypeRecord (NC.CardTypeRecord CardTypeName]
then
(NC.ReportError NIL (CONCAT
"Cannot find full definition of card type: "
CardTypeName)))
(if (EQ (SETQ FieldValue (fetch (NoteCardType , FieldName)
of CardTypeRecord))
(QUOTE \\EMPTY//))
then
(* * still marked \\EMPTY//)
(NC.ReportError "NC.GetCardTypeField" (CONCAT "Field name "
(QUOTE , FieldName)
" of card type "
CardTypeName
" still \\EMPTY// after autoloading."]
(if (EQ FieldValue (QUOTE \\FILLME//))
then
(* * Fetch field from super type. Unfortunately direct recursion is
not possible because this is a DEFMACRO.)
(NC.GetCardTypeFieldOfSuper CardTypeName (QUOTE , FieldName))
else FieldValue]
[PUTPROPS NC.ApplyFn MACRO (Args (BQUOTE (APPLY* (fetch (Card , (CAR Args))
of , (CADR Args))
,@
(CDR Args]
[PUTPROPS NC.ApplySupersFn MACRO (Args (BQUOTE (LET [(SuperType (fetch (Card SuperType)
of , (CADR Args]
(APPLY* (NC.GetCardTypeField , (CAR Args)
SuperType)
,@
(CDR Args]
)
(DEFINEQ
(NC.IsSubTypeOfP
[LAMBDA (SubTypeName SupposedSuperTypeName) (* rht: "15-Jul-86 18:06")
(* * Is SubTypeName the name of a Card type that is a sub type of carrd type SupposedSuperTypeName.)
(LET (SuperType)
(OR (EQ SubTypeName SupposedSuperTypeName)
(AND (SETQ SuperType (NC.GetCardTypeField SuperType SubTypeName))
(NC.IsSubTypeOfP SuperType SupposedSuperTypeName])
(NC.CardTypeRecord
[LAMBDA (TypeName NewTypeRecord) (* kirk: "12-Feb-86 16:15")
(* * Retrieve the card type record for TypeName)
(* * fgh 1/31/86 Updated to handle hash table for card types. Also added code to allow modification of type record.
Does not do any consstency checking.)
(PROG1 (GETHASH TypeName NC.CardTypes)
(if NewTypeRecord
then (PUTHASH (fetch (NoteCardType TypeName) of NewTypeRecord)
NewTypeRecord NC.CardTypes])
(NC.MakeCardTypesList
[LAMBDA NIL (* Randy.Gobbel "24-Nov-87 15:32")
(* * Make initial set of card types.)
(* * fgh 1/31/86 Updated to handle hash table for card types.)
(* * fgh 2/17/86 Added typless attached bit map to NoteCards card type.)
(* * rht 4/7/86: Now sets up default left and middle button menu items.)
(* * rg 3/27/87 added WITH.MONITOR)
(* * rg 11/24/87 fn fields now initialized to NILL (instead of FILLME))
(DECLARE (GLOBALVARS NC.TypelessIcon NC.CardTypes NC.DefaultLeftButtonMenuItems
NC.DefaultMiddleButtonMenuItems NC.TypesLock NC.NoteCardTypeMenu))
(WITH.MONITOR NC.TypesLock (SETQ NC.CardTypes (OR (HARRAYP NC.CardTypes)
(HASHARRAY 50)))
(PUTHASH (QUOTE NoteCard)
(create NoteCardType
TypeName ← (QUOTE NoteCard)
SuperType ← NIL
StubFlg ← NIL
MakeFn ← (FUNCTION NILL)
EditFn ← (FUNCTION NILL)
QuitFn ← (FUNCTION NILL)
MakeReadOnlyFn ← (FUNCTION NILL)
MakeReadWriteFn ← (FUNCTION NILL)
GetFn ← (FUNCTION NILL)
PutFn ← (FUNCTION NILL)
CopyFn ← (FUNCTION [LAMBDA (Card ToStream FromStream Length)
(* Copy a card's substance using copybytes.)
(LET* ((FromStartPtr (GETFILEPTR FromStream))
(FromEndPtr (PLUS Length FromStartPtr)))
(COPYBYTES FromStream ToStream FromStartPtr
FromEndPtr)
T])
MarkDirtyFn ← (FUNCTION NILL)
DirtyPFn ← (FUNCTION NILL)
CollectLinksFn ← (FUNCTION NILL)
DeleteLinksFn ← (FUNCTION NILL)
UpdateLinkIconsFn ← (FUNCTION NILL)
InsertLinkFn ← (FUNCTION NILL)
TranslateWindowPositionFn ← (FUNCTION NILL)
LinkDisplayMode ← (create LINKDISPLAYMODE
ATTACHBITMAPFLG ← T)
DefaultWidth ← 100
DefaultHeight ← 100
LinkAnchorModesSupported ← NIL
DisplayedInMenuFlg ← NIL
LinkIconAttachedBitMap ← NC.TypelessIcon
LeftButtonMenuItems ← NC.DefaultLeftButtonMenuItems
MiddleButtonMenuItems ← NC.DefaultMiddleButtonMenuItems)
NC.CardTypes)
(SETQ NC.NoteCardTypeMenu])
(NC.AddCardType
[LAMBDA (TypeName SuperType FnsAssocList VarsAssocList FullDefinitionFile ListOfFILLMEFields
StubFlg) (* Randy.Gobbel "27-Mar-87 16:05")
(* * Create a new note card type and link it into the card type heirarchy.)
(* * fgh 1/31/86 Updated to handle card type hash table.)
(* * fgh 2/3/86 Updated to do inheritance at definition time rather than at access time.)
(* * rht 7/15/86: Innards replaced by call to NC.ModifyCardType.)
(* * rht 11/7/86: Now accepts ListOfFILLMEFields arg. Any such fields get the \\FILLME// atom as value.
No longer forces load of super. Takes three extra optional args StubFlg, FullDefinitionFile, and
ListOfFILLMEFields.)
(* * RG 3/27/87 added WITH.MONITOR)
(WITH.MONITOR NC.TypesLock
(LET [NewType (MainFieldNames (CONSTANT (for FieldName
in (RECORDFIELDNAMES (QUOTE
NoteCardType))
when (NEQ (QUOTE InheritedFlg)
(SUBATOM FieldName -12
-1))
collect FieldName]
(COND
((NULL TypeName)
(NC.ReportError "NC.AddCardType" "Illegal type name: NIL"))
((NULL SuperType)
(NC.ReportError "NC.AddCardType" "Illegal super type name: NIL")))
(* * Create new NoteCardType)
(SETQ NewType
(create NoteCardType
TypeName ← TypeName
SuperType ← SuperType
StubFlg ← StubFlg
FullDefinitionFile ← FullDefinitionFile))
(* * If it's a stub, then change the default values for fields from \\FILLME// to \\EMPTY// except for those in
ListOfFILLMEFields.)
[if StubFlg
then (for FieldName in MainFieldNames unless (FMEMB FieldName
ListOfFILLMEFields)
when (EQ (RECORDACCESS (BQUOTE (NoteCardType , FieldName)
)
NewType NIL (QUOTE fetch))
(QUOTE \\FILLME//))
do (RECORDACCESS (BQUOTE (NoteCardType , FieldName))
NewType NIL (QUOTE replace)
(QUOTE \\EMPTY//]
(* * Compute fields, inheriting from above and propagating downward.)
(NC.ModifyCardType NewType FnsAssocList VarsAssocList)
(* * Stash the new card type record, reset the menu and then return.)
(PUTHASH TypeName NewType NC.CardTypes)
(SETQ NC.NoteCardTypeMenu)
NewType])
(NC.AddCardTypeStub
[LAMBDA (TypeName SuperType FullDefinitionFileName FnsAssocList VarsAssocList ListOfFILLMEFields)
(* rht: " 7-Nov-86 14:55")
(* * 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.)
(* * rht 11/7/86: Now just calls NC.AddCardType with StubFlg = T.)
(NC.AddCardType TypeName SuperType FnsAssocList VarsAssocList FullDefinitionFileName
ListOfFILLMEFields T])
(NC.ModifyCardType
[LAMBDA (TypeRecord FnsAssocList VarsAssocList) (* rht: "15-Jul-86 13:13")
(* * Changes the fields of the given type, inheriting other fields from the super and propagating changes downward.
This used to be the innards of NC.AddCardType.)
(if (type? NoteCardType TypeRecord)
then (LET [(MainFieldNames (CONSTANT (for FieldName in (RECORDFIELDNAMES
(QUOTE NoteCardType))
when (NEQ (QUOTE InheritedFlg)
(SUBATOM FieldName -12 -1))
collect FieldName]
(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)))
TypeRecord NIL (QUOTE replace)
(CADR AssocPair))
(* * Set the corresponding InheritedFlg to indicate that this field is not inherited.)
(RECORDACCESS [BQUOTE (NoteCardType , (PACK* (CAR AssocPair)
(QUOTE InheritedFlg]
TypeRecord NIL (QUOTE replace)
NIL)))
(* * Inherit any NIL fields from super type record.)
(AND (fetch (NoteCardType SuperType) of TypeRecord)
(NC.InheritFieldsFromSuperType TypeRecord))
(* * Propagate any changes downward to the subtypes of this type.)
(NC.PropagateCardTypeFieldsDownward TypeRecord])
(NC.RecomputeCardType
[LAMBDA (TypeName FnsAssocList VarsAssocList) (* Randy.Gobbel "27-Mar-87 17:05")
(* * Recomputes an existing card type, changing those fields present on FnsAssocList and VarsAssocList.)
(* * rg 3/27/87 added WITH.MONITOR)
(WITH.MONITOR NC.TypesLock (LET ((TypeRecord (NC.CardTypeRecord TypeName))
SuperType)
[COND
((NULL TypeRecord)
(NC.ReportError "NC.RecomputeCardType" (CONCAT
"Unknown type: "
TypeName)))
([AND (NEQ TypeName (QUOTE NoteCard))
(NULL (NC.CardTypeRecord (SETQ SuperType
(fetch (NoteCardType
SuperType)
of TypeRecord]
(NC.ReportError "NC.RecomputeCardType"
(CONCAT TypeName
" has unknown super type: "
SuperType]
(* * Compute fields, inheriting from above and propagating downward.)
(NC.ModifyCardType TypeRecord FnsAssocList VarsAssocList)
(* * reset the menu)
(SETQ NC.NoteCardTypeMenu)
TypeName])
(NC.ListOfCardTypes
[LAMBDA (ForMenuFlg) (* fgh: " 2-Sep-86 00:30")
(* * Return a list of the note card types)
(* * Special processing for older types to make them not all caps.)
(* * fgh 1/31/86 Updated to handle card type Hash array.)
(* * fgh 9/1/86 Updated to handle \\EMPTY// slots in CardType defns.)
(SORT (LET (CollectLst)
[MAPHASH NC.CardTypes (FUNCTION (LAMBDA (TypeRecord TypeName)
(if (OR (NULL ForMenuFlg)
(EQ (fetch (NoteCardType DisplayedInMenuFlg)
of TypeRecord)
T))
then (push CollectLst (fetch (NoteCardType TypeName)
of TypeRecord]
CollectLst])
(NC.SubTypesOfCardType
[LAMBDA (TypeName) (* fgh: "31-Jan-86 21:49")
(* * Returns a list of the types names of all the sub-types of TypeName)
(* * fgh 1/31/86 First created.)
(LET (CollectLst)
[MAPHASH NC.CardTypes (FUNCTION (LAMBDA (TypeRecord Key)
(if (EQ TypeName (fetch (NoteCardType SuperType) of TypeRecord))
then (push CollectLst (fetch (NoteCardType TypeName) of
TypeRecord]
CollectLst])
(NC.DeleteCardType
[LAMBDA (TypeName DeleteSubTypesFlg) (* pmi: "10-Dec-87 11:23")
(* * Deletes a card type. If DeleteSubTypesFlg is non-NIL recursively deletes all sub-types.
If DeleteSubTypesFlg is NIL, then attempting to delete a type with sub-types is an error.)
(* * fgh 1/31/86 First created.)
(* * rg 3/27/87 added WITH.MONITOR)
(* * dsj 9/27/87: now clears NC.NoteCardTypeMenu so that the type no longer appears on the menu of card types.)
(* * pmi 12/10/87: Added dsj's change; see above comment.)
(DECLARE (GLOBALVARS NC.NoteCardTypeMenu))
(WITH.MONITOR NC.TypesLock (LET ((SubTypes (NC.SubTypesOfCardType TypeName)))
[if SubTypes
then (if DeleteSubTypesFlg
then (for SubType in SubTypes
do (NC.DeleteCardType SubType
DeleteSubTypesFlg))
else (NC.ReportError NIL (CONCAT
"Cannot delete a card type with existing sub-types."
(CHARACTER
13)
"This type has sub-types: "
SubTypes]
(PUTHASH TypeName NIL NC.CardTypes)
(SETQ NC.NoteCardTypeMenu])
(NC.InheritFieldsFromSuperType
[LAMBDA (TypeNameOrRecord SuperTypeRecord) (* rht: " 8-Nov-86 18:10")
(* * 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.)
(* * rht 11/7/86: Changed procedure for deciding when to inherit a field from upstairs.)
(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]
(if [OR SuperTypeRecord (SETQ SuperTypeRecord (NC.CardTypeRecord
(fetch (NoteCardType SuperType) of TypeRecord]
then (for FlgName in InheritedFlgNames
do (LET ((FieldName (SUBATOM FlgName 1 -13))
FieldValue SuperFieldValue)
(SETQ FieldValue (RECORDACCESS (BQUOTE (NoteCardType ,
FieldName))
TypeRecord NIL (QUOTE fetch)))
(SETQ SuperFieldValue (RECORDACCESS (BQUOTE (NoteCardType
, FieldName))
SuperTypeRecord NIL
(QUOTE fetch)))
(* * Only inherit from the super field if it's got a real value, and if either the subfield has value \\FILLME// or
the InheritedFlg field says to inherit. Don't inherit if the subfield is \\EMPTY//, cause that indicates a field
for a stub that shouldn't inherit.)
(if [AND [NOT (FMEMB SuperFieldValue (QUOTE (\\FILLME//
\\EMPTY//]
(NOT (EQ FieldValue (QUOTE \\EMPTY//)))
(OR (EQ FieldValue (QUOTE \\FILLME//))
(RECORDACCESS (BQUOTE (NoteCardType , FlgName)
)
TypeRecord NIL (QUOTE fetch]
then (RECORDACCESS (BQUOTE (NoteCardType , FieldName))
TypeRecord NIL (QUOTE replace)
SuperFieldValue])
(NC.PropagateCardTypeFieldsDownward
[LAMBDA (TypeNameOrRecord) (* rht: " 7-Nov-86 14:54")
(* * For all subtypes of TypeNameOrRecord, inherit fields from TypeNameOrRecord.)
(* * fgh 2/3/86 First created.)
(* * rht 11/7/86: Fixed minor typo.)
(for SubType in (NC.SubTypesOfCardType (if (type? NoteCardType TypeNameOrRecord)
then (fetch (NoteCardType TypeName)
of TypeNameOrRecord)
else TypeNameOrRecord))
do (NC.InheritFieldsFromSuperType SubType (if (type? NoteCardType TypeNameOrRecord)
then TypeNameOrRecord
else NIL))
(NC.PropagateCardTypeFieldsDownward SubType])
(NC.AutoLoadCardType
[LAMBDA (TypeName FieldName FileSuggestion) (* kirk: "22-Aug-86 15:48")
(* * AutoLoad card type TypeName using FileSuggestion as the first place to look. Otherwise look in the directories
specified by NoteCardsDirectories. Works by starting at the give Type and moving up the inheritance heirarchy
loading all types that are currently defined only by stubs until it reaches a card type for which FieldName is
defined. This works because full inheritance is done whereever possible during type definition in NC.AddCardType.)
(* * fgh 2/3/86 First created.)
(* * fgh 7/16/86 Added ALLOW.BUTTON.EVENTS call)
(* * kirk 8/22/86 Added check for NIL card type)
(ALLOW.BUTTON.EVENTS)
(LET ((CardTypeRecord (NC.CardTypeRecord TypeName))
(OriginalTypeName TypeName)
FieldValue)
(* * If there's no stub for this card type, load the type definition file.)
(if (NULL TypeName)
then (NC.ReportError NIL "NIL card type"))
[if (NULL CardTypeRecord)
then (NC.CardTypeLoader TypeName FileSuggestion)
(* * Still no definition then we're sunk.)
(if (NULL (SETQ CardTypeRecord (NC.CardTypeRecord TypeName)))
then (NC.ReportError NIL (CONCAT
"Cannot find definition of card type: "
TypeName]
(* * We have at least a stub for this card type. Move up the inheritance hierarchy loading the real files instead
of the stubs until we have a value of the field we are looking for.)
(until (EQ TypeName (QUOTE NoteCard))
do
(* * If this is a stub, load the real thing. Break if it can't be found.)
(if (fetch (NoteCardType StubFlg) of CardTypeRecord)
then (OR (NC.CardTypeLoader TypeName FileSuggestion)
(NC.ReportError NIL (CONCAT
"Cannot find full definition of card type: "
TypeName)))
(SETQ CardTypeRecord (NC.CardTypeRecord TypeName)))
(* * If the field was defined in the real thing, then return it. Else keep moving up load ing all the stubs.)
(if (SETQ FieldValue (RECORDACCESS (BQUOTE (NoteCardType , FieldName))
CardTypeRecord NIL (QUOTE fetch)))
then (RETURN FieldValue)
else (SETQ TypeName (fetch (NoteCardType SuperType) of CardTypeRecord))
(SETQ CardTypeRecord (NC.CardTypeRecord TypeName)))
finally (NC.ReportError NIL (CONCAT "Cannot find definition of card type: "
OriginalTypeName " Field name needed: "
FieldName])
(NC.CardTypeLoader
[LAMBDA (TypeName FileSuggestion QuietFlg) (* rht: "17-Apr-87 19:53")
(* * 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.)
(* * rht&rg&pmi 10/21/86: Changed LOAD to FILESLOAD.)
(* * rht 4/17/87: Now smashes PAGEFULLFN of tty window so that it'll scroll automatically.)
(RESETLST [RESETSAVE NIL (if (OPENWP (WFROMDS (TTYDISPLAYSTREAM)
T))
then (SETQ QuietFlg T)
(QUOTE (NILL))
else (BQUOTE (CLOSEW , (WFROMDS (TTYDISPLAYSTREAM]
[RESETSAVE NIL (if QuietFlg
then (QUOTE (NILL))
else (BQUOTE (WINDOWPROP , (WFROMDS (TTYDISPLAYSTREAM))
(QUOTE PAGEFULLFN)
,
(WINDOWPROP (WFROMDS (
TTYDISPLAYSTREAM))
(QUOTE PAGEFULLFN)
(QUOTE NILL]
(LET ((Window (WFROMDS (TTYDISPLAYSTREAM)))
(FileName (NC.FindFile FileSuggestion TypeName T)))
(if (NOT QuietFlg)
then (CLEARW Window)
(FLASHWINDOW Window)
(PRINTOUT Window "Card type " TypeName " not loaded." T
"Attempting to autoload."
T))
(if FileName
then (PROG1 (APPLY (QUOTE FILESLOAD)
(if NC.LOADFLG
then (BQUOTE ((, NC.LOADFLG)
, FileName))
else (LIST FileName)))
(NC.FixFileDates FileName])
(NC.CardTypeStubLoader
[LAMBDA (TypeName FileSuggestion) (* pmi: " 8-Sep-87 13:44")
(* * 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 6/20/86 Added NCP.Add...CardStub fn load and call)
(* * kirk 9/9/86 Changed the name of the FN to search for to NCAddStub...Card)
(* * kirk 9/21/86 added RESETLST)
(* * rg 10/21/86: Changed to use simpler scheme for finding files)
(* * rht&rg 11/7/86: Now passes (QUOTE VARS) arg to LOADFNS so that interesting vars like link icon bitmap will be
loaded. There ought to be a better way.)
(* * rg 5/18/87 checks, via disgusting kludge, to see if file can be opened random access, if not, loads whole
file)
(* * rht 6/12/87: Changed call to OPENSTREAM to open for INPUT rather than BOTH.)
(* * rg 6/18/87 now checks for files on NS servers by looking for a colon in the file name)
(* * rg 6/19/87 check for AddTypeFn already defined before attempting to load it)
(* * rg&pmi 9/8/87: fixes stub loading for NS servers.)
(LET* ((FileName (NC.FindFile FileSuggestion TypeName T))
(oldFILEDATES (GETPROP FileName (QUOTE FILEDATES)))
(NSServerFlg (STRPOS ":" FileName))
AddTypeFn)
(if FileName
then [RESETLST [RESETSAVE NIL (BQUOTE (COND
(oldFILEDATES
(PUTPROP , (LIST (QUOTE QUOTE)
FileName)
(QUOTE FILEDATES)
oldFILEDATES))
(T (REMPROP , (LIST (QUOTE QUOTE)
FileName)
(QUOTE FILEDATES]
(* * Load and eval the NC.Add...CardStub fn)
(SETQ AddTypeFn (PACK* (QUOTE NCAddStub.)
TypeName
(QUOTE Card)))
(OR (FNTYP AddTypeFn)
(PROGN (if NSServerFlg
then (NC.LoadFileFromDirectories FileName)
else (LOADFNS AddTypeFn FileName NIL
(QUOTE VARS)))
(NC.FixFileDates FileName]
(if (NOT (FNTYP AddTypeFn))
then (NC.ReportError "NC.CardTypeStubLoader"
(CONCAT
"NoteCards: Can't find card type stub init procedure: "
AddTypeFn " in " FileName ".")))
(* * this should call NC.AddCardTypeStub)
(APPLY AddTypeFn])
(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])
)
(RPAQ NC.TypelessIcon (READBITMAP))
(7 18
"ON@@"
"ON@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"LF@@"
"ON@@")
(DECLARE: DONTEVAL@LOAD
(NC.MakeCardTypesList)
)
(PUTPROPS NCTYPESMECH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988))
(DECLARE: DONTCOPY
(FILEMAP (NIL (9808 33812 (NC.IsSubTypeOfP 9818 . 10274) (NC.CardTypeRecord 10276 . 10832) (
NC.MakeCardTypesList 10834 . 13370) (NC.AddCardType 13372 . 16011) (NC.AddCardTypeStub 16013 . 17019)
(NC.ModifyCardType 17021 . 18639) (NC.RecomputeCardType 18641 . 19816) (NC.ListOfCardTypes 19818 .
20618) (NC.SubTypesOfCardType 20620 . 21185) (NC.DeleteCardType 21187 . 22477) (
NC.InheritFieldsFromSuperType 22479 . 24790) (NC.PropagateCardTypeFieldsDownward 24792 . 25585) (
NC.AutoLoadCardType 25587 . 28408) (NC.CardTypeLoader 28410 . 30688) (NC.CardTypeStubLoader 30690 .
33364) (NC.GetCardTypeFieldOfSuper 33366 . 33810)))))
STOP