(FILECREATED " 1-Apr-87 11:11:41" {QV}<NOTECARDS>1.3K>NEXT>RGPATCH021.;3 7893
changes to: (VARS RGPATCH021COMS)
(MACROS NC.ProtectedNoteFileOperation NC.ProtectedCardOperation NC.WithLockedCards)
(FNS NC.OpenNoteFile NC.CloseNoteFile NC.CheckpointNoteFile NC.MakeCardTypesList
NC.AddCardType NC.RecomputeCardType NC.DeleteCardType NC.SaveDirtyCards
NC.EditNoteCard NC.QuitCard NC.CardSaveFn NC.AddGlobalLinksToCard
NC.LockListOfCards NC.AbortSession NC.DeleteNoteCards NCP.CloseCards)
previous date: "31-Mar-87 19:08:22" {QV}<NOTECARDS>1.3K>NEXT>RGPATCH021.;1)
(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT RGPATCH021COMS)
(RPAQQ RGPATCH021COMS ((* * RG 3/31/87 fixes race condition in types mechanism)
(* * new for NCTYPESMECH)
(INITVARS (NC.TypesLock (CREATE.MONITORLOCK "NoteCards Type Mechanism")))
(* * changes to NCTYPESMECH)
(FNS NC.MakeCardTypesList NC.AddCardType NC.RecomputeCardType
NC.DeleteCardType)))
(* * RG 3/31/87 fixes race condition in types mechanism)
(* * new for NCTYPESMECH)
(RPAQ? NC.TypesLock (CREATE.MONITORLOCK "NoteCards Type Mechanism"))
(* * changes to NCTYPESMECH)
(DEFINEQ
(NC.MakeCardTypesList
[LAMBDA NIL (* Randy.Gobbel "27-Mar-87 16:04")
(* * 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)
(DECLARE (GLOBALVARS NC.TypelessIcon NC.CardTypes NC.DefaultLeftButtonMenuItems
NC.DefaultMiddleButtonMenuItems 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
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])
CollectLinksFn ← (FUNCTION NILL)
LinkDisplayMode ← (create LINKDISPLAYMODE
ATTACHBITMAPFLG ← T)
DefaultWidth ← 100
DefaultHeight ← 100
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.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.DeleteCardType
[LAMBDA (TypeName DeleteSubTypesFlg) (* Randy.Gobbel "27-Mar-87 17:10")
(* * 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)
(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])
)
(PUTPROPS RGPATCH021 COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1235 7812 (NC.MakeCardTypesList 1245 . 2991) (NC.AddCardType 2993 . 5632) (
NC.RecomputeCardType 5634 . 6809) (NC.DeleteCardType 6811 . 7810)))))
STOP