(FILECREATED "21-SEP-83 11:39:10" {INDIGO}<LOOPS>SOURCES>LTKER.;2 116646
changes to: (CLASSES LOOPSTestEnvironment LOOPSTestMethod LOOPSTestPrimitive)
(FNS AskPreTest AskSubTest AskSyntaxTest AskTestCases BeginLoopsTest
CheckClassTest CheckPreTest DescribePreviousTry DescribeTestLink DoLoopsTest
DoTestSelf EditPreTest EvaluateTest ExecTestFields LOOPSTestObject.DefineTEST
LOOPSTestObject.Describe LOOPSTestObject.EditTEST LOOPSTestObject.TEST
LOOPSTestObject.TEST! LOOPSTestObject.TestSelf LOOPSTestPrimitive.XTEST
LOOPSTestMeta.BeginLOOPSTest LOOPSTestKernel.TEST LOOPSTestObject.ReTest
LOOPSTestObject.ResetSelf MakeBackLink PerformAltTest PerformSetup
PerformTest PreTestsSatisfied? PrintFailedExp PrintTestCode PrintTestHeader)
previous date: "20-SEP-83 16:42:59" {IVY}<MITTAL>LISP>LTKER.;125)
(PRETTYCOMPRINT LTKERCOMS)
(RPAQQ LTKERCOMS ((E (ResetLTKERVARS))
(CLASSES * LTKERCLASSES)
(FNS * LTKERFNS)
(INSTANCES * LTKERINSTANCES)
(MACROS * LTKERMACROS)
(VARS * LTKERVARS)
(P (ResetLTKERCLASSES))))
(RPAQQ LTKERCLASSES (LOOPSClassSuper LOOPSTestBasic LOOPSTestBraidObject LOOPSTestEnvironment
LOOPSTestKernel LOOPSTestLispFunc LOOPSTestMeta LOOPSTestMethod
LOOPSTestObject LOOPSTestPrimitive LOOPSTestSyntax))
(DEFCLASSES LOOPSClassSuper LOOPSTestBasic LOOPSTestBraidObject LOOPSTestEnvironment LOOPSTestKernel
LOOPSTestLispFunc LOOPSTestMeta LOOPSTestMethod LOOPSTestObject LOOPSTestPrimitive
LOOPSTestSyntax)
[DEFCLASS LOOPSClassSuper
(MetaClass LOOPSTestMeta Edited: (* sm: "19-OCT-82 12:12"))
(Supers NamedObject)
(ClassVariables (InstanceComsVar LTKERINSTANCES))
(InstanceVariables)
(Methods (Destroy LOOPSClassSuper.Destroy args ? doc (* destroys an instance; updates Instancecoms var and CV
Instances))
(GetTestCode LOOPSClassSuper.GetTestCode args NIL doc
(* returns NIL, as there is currently no Test Code here)
))]
[DEFCLASS LOOPSTestBasic
(MetaClass LOOPSTestMeta Edited: (* sm: " 8-OCT-82 10:15")
doc (* class for Test objects which are by themselves and
not share PreTest dependencies)
)
(Supers LOOPSTestObject)
(ClassVariables (InstancePrefix LT)
(Instances (LTTemplate LTDumpInstance LTLoadInstance LTMethod LTObject
LTActiveValue)
doc (* list of NAMES of objects which are instances of this
class)
))
(InstanceVariables)
(Methods)]
[DEFCLASS LOOPSTestBraidObject
(MetaClass LOOPSTestMeta Edited: (* sm: " 5-OCT-82 12:46")
doc (* instances are objects for testing LOOPS's built-in
classes)
)
(Supers LOOPSTestObject)
(ClassVariables (InstancePrefix LTB)
(Instances NIL doc (* list of objects which are instances of this class)
))
(InstanceVariables)
(Methods)]
[DEFCLASS LOOPSTestEnvironment
(MetaClass LOOPSTestMeta Edited: (* sm: "29-MAR-83 15:24")
doc (* used for testing KB and environments)
)
(Supers LOOPSTestObject)
(ClassVariables (InstancePrefix LTE)
(ClassPreTest #((LTMethod)
NIL AllowRemove))
(ClassTested? U)
(UnnamedInstanceCount 0)
(Instances (LTEMapObjectNames LTECancel LTEMakeCurrent LTEThawKB LTEFreezeKB
LTEAssocKB LTEDumpToKB LTESummarize LTEDelete
LTECommunity LTEOld LTENew)))
(InstanceVariables (AfterTest NIL))
(Methods)]
[DEFCLASS LOOPSTestKernel
(MetaClass LOOPSTestMeta Edited: (* sm: "11-OCT-82 15:47")
doc (* instances are for testing Kernel features.
currently only LTKernel is needed)
)
(Supers LOOPSTestObject)
(ClassVariables (Instances (LTKernel))
(KernelFeatures (LTFSend LTFGetValue LTFPutValue)
doc (* list of features which are part of Kernel Test)
)
(ClassPreTest #(NIL NIL AllowRemove)))
(InstanceVariables)
(Methods (TEST LOOPSTestKernel.TEST args NIL doc (* TESTS THE KERNEL FEATURES OF LOOPS)))]
[DEFCLASS LOOPSTestLispFunc
(MetaClass LOOPSTestMeta Edited: (* sm: " 5-OCT-82 16:36")
doc (* instances are Test objects for LOOPS's Lisp
functions)
)
(Supers LOOPSTestObject)
(ClassVariables (InstancePrefix LTF)
(Instances (LTFSendSuper LTFGetInitialValue LTFPutNthValue LTFGetNthValue
LTFGetObjectNames LTFtype? LTFClass LTFGetObjectRec
LTFReplaceActiveValue LTFPutLocalState LTFGetLocalState
LTFRenameMethodFunction LTFMoveMethod LTFMoveVariable
LTFMoveClassVariable LTFRenameVariable LTFCalledFns
LTFRenameMethod LTFTryMethod LTFDoMethod LTFPutItOnly
LTFGetItOnly LTFPutIt LTFGetIt LTFPutMethodOnly
LTFGetMethodOnly LTFPutMethod LTFGetMethod
LTFPutClassOnly LTFGetClassOnly LTFPutClass LTFGetClass
LTFPutClassValueOnly LTFPutValueOnly LTFPushClassValue
LTFPutClassValue LTFAddValue LTFPushValue
LTFGetClassValueOnly LTFGetValueOnly LTFGetClassValue
LTFDM LTFDC LTFPutValue LTFGetValue LTFSend)
doc (* list of objects which are instances of this class)
))
(InstanceVariables (LispName ? doc (* Lisp function name corresp to this object)
))
(Methods)]
[DEFCLASS LOOPSTestMeta
(MetaClass MetaClass Edited: (* sm: "13-OCT-82 16:14"))
(Supers Class)
(ClassVariables (Instances NIL doc (* list of all instances of a LOOPSTest class)
)
(InstanceComsVar LTKERINSTANCES doc (* variable used for saving instances on file.
should be changed if file is changed))
(UnnamedInstanceCount 0 doc (* the counter used to generate new names of instances,
if one is not given to NEW))
(InstancePrefix LTU doc (* prefix attached to names of instances for convenient
identification)))
(InstanceVariables)
(Methods (BeginLOOPSTest LOOPSTestMeta.BeginLOOPSTest args NIL doc
(* TESTS THE KERNEL FEATURES OF LOOPS))
(GetTestCode LOOPSTestMeta.GetTestCode args NIL doc
(* returns NIL, as no TestCode yet))
(New LOOPSTestMeta.New args (name)
doc (* inherits its Super's New and then adds the instance's
name to filecoms and CV Instances)
))]
[DEFCLASS LOOPSTestMethod
(MetaClass LOOPSTestMeta Edited: (* sm: "29-MAR-83 15:25")
doc (* instances are for testing LOOPS's built-in methods)
)
(Supers LOOPSTestObject)
(ClassVariables (ClassPreTest #((LTMethod)
NIL AllowRemove))
(ClassTested? U)
(InstancePrefix LTM)
(UnnamedInstanceCount 0)
(Instances (LTMTitleCommandInObj LTMSetNameInObj LTMRenameInObj LTMPutInObj
LTMPPV!InObj LTMPP!InObj LTMPPInObj LTMList!InObj
LTMListInObj LTMInspectValueCommandInObj
LTMInspectTitleMenuInObj LTMInspectTitleInObj
LTMInspectStoreInObj LTMInspectPropertiesInObj
LTMInspectPropCommandInObj LTMInspectFetchInObj
LTMHasIVInObj LTMEditInObj LTMDumpFactsInObj
LTMDestroy!InObj LTMDestroyInObj
LTMTitleCommandInClass LTMSetNameInClass
LTMRenameInClass LTMPutInClass LTMPPV!InClass
LTMPP!InClass LTMPPInClass LTMList!InClass
LTMInspectValueCommandInClass
LTMInspectTitleMenuInClass LTMInspectTitleInClass
LTMInspectStoreInClass
LTMInspectPropertiesInClass
LTMInspectPropCommandInClass
LTMInspectFetchInClass LTMHasIVInClass
LTMEditInClass LTMDumpFactsInClass
LTMDestroy!InClass LTMDestroyInClass LTMWhereIs
LTMUnderstands LTMUnSetName LTMTraceIt
LTMReturnDefaultValue LTMPutIVProp LTMPrintOn
LTMNoObjectForMsg LTMMessageNotUnderstood
LTMInstantiate LTMInstOf! LTMInstOf LTMInspect
LTMIVMissing LTMDoMethod LTMDeleteIV
LTMCopyShallow LTMCopyDeep LTMClassName LTMClass
LTMBreakIt LTMAt LTMAssocKB LTMAddIV
LTMSubClasses LTMReplaceSupers LTMPPMethod LTMPPM
LTMOnFile LTMNewWithValues LTMNewTemp LTMNew
LTMMoveMethod LTMMethodDoc LTMInitialize LTMHasCV
LTMFetchMethod LTMEditMethod LTMDisplaySubClasses
LTMDefMethod LTMCopyMethod LTMCommentMethods
LTMDeleteInClass LTMAdd LTMListInClass)
doc (* list of objects which are instances of this class)
))
(InstanceVariables)
(Methods)]
[DEFCLASS LOOPSTestObject
(MetaClass LOOPSTestMeta Edited: (* sm: "29-MAR-83 14:13")
doc (* all testobjects which contain code for some test have
this on their supers chain)
)
(Supers LOOPSClassSuper)
(ClassVariables (ClassPreTest #(NIL NIL AllowRemove) Failed ? doc
(* list of objects that need to be tested for a class of
test objects and are tried before an objects own
PreTest))
(Instances NIL)
(InstancePrefix LTO)
(UnnamedInstanceCount 0)
(InstanceComsVar LTDBINSTANCES)
(ClassTested? ? doc (* set to T/NIL depending on ClassPreTest results)
)
(ResetList ((IV Tested? CompletelyTested? (PreTest Tested?)
(Tested? DoneOnce)
(SetUp Tested?)
(SyntaxTest Tested?)
(SubTest Tested?)
(AltTest Tested?)
(SetUp FailedExp)
(TestExpr FailedExpr)
(TestExpr HowFailed)
(PreTest Failed)
(SyntaxTest Failed)
(SubTest Failed)
(AltTest Failed))
(CV ClassTested? (ClassPreTest Failed)))
doc (* list of iv/cvs or their props which must be set to ?
to begin a new test sequence)
))
(InstanceVariables (CasesUsed #(NIL NIL MakeBackLink) doc
(* list of TestCases objects used)
BackLink UsedBy)
(PreTest #(NIL NIL MakeBackLink) BackLink PreTestOf doc
(* list of objects that need to be tested before this
one)
Tested? U Failed NIL)
(PreTestOf #(NIL NIL MakeBackLink) BackLink PreTest doc
(* list of TestObjects which use this as PreTest)
)
(ResetExp NIL doc (* a lisp like expression used for undoing any state
change introduced by a test))
(SetUp NIL Tested? #(U NIL FlashTestBrowser) FailedExp NIL doc
(* a Lisp-like exp for setting up the test environment)
)
(TestExpr NIL FailedExp NIL HowFailed NIL doc
(* this is the actual test expression))
(SyntaxTest #(NIL NIL MakeBackLink) BackLink SyntaxTestOf doc
(* list of objects of type LOOPSTestSyntax for testing
any special syntactic form associated with this object)
Tested? U Failed NIL)
(AltTest #(NIL NIL MakeBackLink) BackLink AltTestOf Tested? U Failed NIL doc
(* list of TestObj which specify alternate ways of
testing this concept))
(AltTestOf #(NIL NIL MakeBackLink) BackLink AltTest doc
(* list of TestObj which use this for alternate ways of
testing their concept))
(TestDesc "the feature indicated by the name" doc
(* A brief description of what is being tested)
)
(UsesObj #(NIL NIL AllowRemove) doc (* list of objects used by this;
for ease of editing only -
no back links are kept))
(Tested? #(U NIL InformTestBrowser) DoneOnce NIL doc
(* result of running the TestExpr))
(CompletelyTested? U Result NIL doc (* result of all tests))
(StandBy #(NIL NIL AllowRemove) doc (* list of objects which were once used but may not be
in use anymore))
(SubTest #(NIL NIL MakeBackLink) BackLink SubTestOf Tested? U Failed NIL doc
(* further things to Test if this tests OK)
)
(AfterTest NIL doc (* expression executed after TestExpr to do some
resetting. Currently only used by LOOPSTestEnvironment
and their subtests)))
(Methods (DefineTEST LOOPSTestObject.DefineTEST args NIL doc
(* used to define Test description for a TestObj.)
)
(Describe LOOPSTestObject.Describe args NIL doc
(* prints a description of the TestObj))
(EditTEST LOOPSTestObject.EditTEST args NIL doc
(* edits a TestObj using menus))
(EditTestInTTYProcess LOOPSTestObject.EditTestInTTYProcess args NIL doc
(* calls EditTEST in TTY Process))
(GetTestCode LOOPSTestObject.GetTestCode args NIL doc
(* returns the Test Code fields))
(ReTest LOOPSTestObject.ReTest args (TestedLst)
doc (* sends a ResetSelf if needed followed by TEST)
)
(ReTestDep LOOPSTestObject.ReTestDep args NIL doc
(* first sends ResetDep and then TESTDep to self)
)
(Reset LOOPSTestObject.Reset args (AlreadyReset)
doc (* resets the Tested type values so prior test results
are wiped out. Also Resets PreTest and ClassPreTest)
)
(Reset! LOOPSTestObject.Reset! args (ResetLst)
doc (* resets itself by sending Reset to self and also
Reset! its SyntaxTest, AltTest and SubTest.
Also does a Reset on PreTest and ClassPreTest)
)
(ResetAll LOOPSTestObject.ResetAll args (ResetLst)
doc (* completely resets itself, all tests on which it
depends, and all which depend on it)
)
(ResetDep LOOPSTestObject.ResetDep args (ResetLst)
doc (* resets itself and all tests which depend on it)
)
(ResetSelf LOOPSTestObject.ResetSelf args (AlreadyReset)
doc (* resets the Tested type values so prior test results
are wiped out.)
)
(TEST LOOPSTestObject.TEST args (TestedLst)
doc (* performs the basic TEST for a TestObject)
)
(TEST! LOOPSTestObject.TEST! args (ContFl)
doc (* first TESTs itself, and if successful, then does
other tests- SubTest, SyntaxTest, AltTest.)
)
(TESTDep LOOPSTestObject.TESTDep args NIL doc (* generates TEST call to self, and TESTDep to PreTestOf
list, and SubTest list only if it succeeds)
)
(TESTall LOOPSTestObject.TESTall args NIL doc (* generates TEST call to self, PreTestOf list, and
SubTest list))
(TestSelf LOOPSTestObject.TestSelf args (TestedLst)
doc (* performs the basic TEST for a TestObject but
continues even if PreTests fail)
))]
[DEFCLASS LOOPSTestPrimitive
(MetaClass LOOPSTestMeta Edited: (* sm: "30-MAR-83 10:59")
doc
(* instances are for testing some primitive aspect of LOOPS not covered by other classes and pointed to USUALLY by
SubTest IV in other Test objects)
)
(Supers LOOPSTestObject)
(ClassVariables (InstancePrefix LTP)
(UnnamedInstanceCount 86)
(ClassPreTest #(NIL BuildPrimClassTest AllowRemove) comm
(* this active values always adds the IV SubTestOf to this list, so that the supers are always considered as
PreTests for a Primitive TestObj)
Failed ?)
(Instances (LTP86 LTP85 LTP84 LTP83 LTP82 LTP81 LTP80 LTP79 LTP78 LTP77 LTP76
LTP75 LTP74 LTP73 LTP72 LTP71 LTP70 LTP69 LTP68 LTP67 LTP66
LTP65 LTP64 LTP63 LTP62 LTP61 LTP60 LTP59 LTP58 LTP57 LTP56
LTP55 LAVPutValue LTP54 LTP53 LAVGetValue LTP52 LTP51 LTP50
LTP49 LTP48 LTP47 LTP46 LTP45 LTP44 LTP43 LTP42 LTP41 LTP40
LTP39 LTP38 LTP37 LTP36 LTP35 LTP34 LTP33 LTP32 LTP31 LTP30
LTP29 LTP28 LTP27 LTP26 LTP25 LTP24 LTP23 LTP22 LTP21 LTP20
LTP19 LTP18 LTP17 LTP16 LTP15 LTP14 LTP13 LTP12 LTP11 LTP10 LTP9
LTP8 LTP7 LTP6 LTP5 LTP4 LTP3 LTP2 LTP1)
doc (* list of objects which are instances of this class)
))
(InstanceVariables (PreTest #(NIL BuildPreTest MakeBackLink) BackLink PreTestOf)
(SubTestOf #(NIL NIL MakeBackLink) BackLink SubTest doc
(* back link to TestObj which uses this for a subtest)
))
(Methods (XTEST LOOPSTestPrimitive.XTEST args NIL doc (* performs the basic TEST for a Primitive TestObject
ONLYIF its super test Tested T and sets own Tested? IV)
))]
[DEFCLASS LOOPSTestSyntax
(MetaClass LOOPSTestMeta Edited: (* sm: "11-OCT-82 15:49")
doc (* instances are for testing syntantic short forms in
LOOPS. these instances are pointed to from SyntaxTest IV
in particular test objects)
)
(Supers LOOPSTestObject)
(ClassVariables (InstancePrefix LTS)
(Instances NIL doc (* list of objects which are instances of this class)
))
(InstanceVariables (SyntaxTestOf #(NIL NIL MakeBackLink) BackLink SyntaxTest doc
(* list of TestObjs which use this for syntax test)
))
(Methods)]
(RPAQQ LTKERFNS (ATEST AddAltTest AllowRemove AskPreTest AskSubTest AskSyntaxTest AskTestCases
BeginLoopsTest BuildPreTest BuildPrimClassTest CheckClassTest CheckPreTest
CloseCurrentEnvironment CreateLTKBS1 DescribePreviousTry DescribeTestLink
DisplayTestBrowser DoLoopsTest DoTestSelf EQACTVAL EditOtherLinksMenu
EditPreTest EditTestOtherCmds EvaluateANDALLTest EvaluateANDTest
EvaluatePROGTest EvaluateTest ExaminePreviousTry ExecTestFields FindObjForLink
FlashTestBrowser GIVGetFn GenerateTestList GetFromActVal InformTestBrowser
LOOPSTestEnvironment.TEST LOOPSTestObject.DefineTEST LOOPSTestObject.Describe
LOOPSTestObject.EditTEST LOOPSTestObject.EditTestInTTYProcess
LOOPSTestObject.GetTestCode LOOPSTestObject.TEST LOOPSTestObject.TEST!
LOOPSTestObject.TESTDep LOOPSTestObject.TESTall LOOPSTestObject.TestSelf
LOOPSTestPrimitive.XTEST LinkEditOtherMenu LOOPSTestMeta.BeginLOOPSTest
LOOPSTestMeta.GetTestCode LOOPSTestMeta.New LOOPSTestKernel.TEST
LOOPSClassSuper.Destroy LOOPSClassSuper.GetTestCode LOOPSTestObject.ReTest
LOOPSTestObject.ReTestDep LOOPSTestObject.Reset LOOPSTestObject.Reset!
LOOPSTestObject.ResetAll LOOPSTestObject.ResetDep LOOPSTestObject.ResetSelf
MakeBackLink MakeSet ObjectName PerformAltTest PerformSetup PerformTest
PreTestsSatisfied? PrintFailedExp PrintTestCode PrintTestHeader
PushClassValueNew PutInActVal ReadLinkMenu ReasonNotDone RemoveValue
ResetLTKERCLASSES ResetLTKERVARS ResetPutLocalStateVars RunTest
SetupEditTestObjMenu TestErrorBreak TestObjectDesc TickleBrowserNodes))
(DEFINEQ
(ATEST
[LAMBDA (Exp Comm) (* sm: "30-NOV-82 16:17")
Exp])
(AddAltTest
[LAMBDA (self) (* sm: "29-OCT-82 15:29")
(* offers to help add AltTest.
Returns T -
if any added. NIL -
otherwise)
(* currently a no op)
(PROG NIL
(RETURN NIL])
(AllowRemove
[LAMBDA (self varName newValue propName activeVal type) (* sm: "11-OCT-82 15:42")
(* This is a putFn for allowing values to be removed by using the format (- v). Any other kind will be added as
such)
(COND
((ATOM newValue)
(PutLocalState activeVal (CONS newValue (GetLocalState activeVal self varName propName))
self varName propName type))
((EQ (CAR newValue)
(QUOTE -))
(PutLocalState activeVal (DREMOVE (CADR newValue)
(GetLocalState activeVal self varName propName))
self varName propName type))
(T (PutLocalState activeVal newValue self varName propName type])
(AskPreTest
[LAMBDA (self) (* sm: "20-SEP-83 16:22")
(* ask for changes to PreTests)
(PROG (PreTest)
(SETQ PreTest (ASKUSER NIL NIL (LIST "Current PreTests are:" (@ PreTest)
"Do you want to add/delete any")
(QUOTE ((A "dd
" EXPLAINSTRING "Add - enter the ADDITIONS to PreTest list" KEYLST (( NIL RETURN ANSWER CONFIRMFLG T)
))
(M "odify
" EXPLAINSTRING "Modify - enter the NEW PreTest list" KEYLST (((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(D "elete
" EXPLAINSTRING "Delete - enter the list of PreTests to be deleted" KEYLST
(((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(N "o
" EXPLAINSTRING "No - no change" RETURN NIL)))
NIL NIL (QUOTE (CONFIRMFLG NIL))
NIL))
[COND
(PreTest (SELECTQ (CAR PreTest)
((A Add)
(for x in (MKLIST (CADR PreTest)) do (PutValue self (QUOTE PreTest)
x)))
((M Modify)
(for x in (@ PreTest) do (RemoveValue self (QUOTE PreTest)
x))
(for y in (MKLIST (CADR PreTest)) do (PutValue self (QUOTE PreTest)
x)))
((D Delete)
(for x in (MKLIST (CADR PreTest)) do (RemoveValue self (QUOTE PreTest)
x)))
(printout TTY "Illegal format PreTest list. Ignoring.." PreTest T]
(printout TTY "New PreTests are:" T (@ PreTest)
T])
(AskSubTest
[LAMBDA (self) (* sm: "20-SEP-83 16:22")
(* ask for changes to SubTest list)
(PROG (PreTest)
(SETQ PreTest (ASKUSER NIL NIL (LIST "Current SubTest objects are:" (@ SubTest)
"Do you want to add/delete any")
(QUOTE ((A "dd
" EXPLAINSTRING "Add - enter the ADDITIONS to SubTest list" KEYLST (((READ)
"a number of new Primitive or a list of existing SubTest objects"
RETURN ANSWER CONFIRMFLG T)))
(M "odify
" EXPLAINSTRING "Modify - enter the NEW SubTest list" KEYLST (((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(D "elete
" EXPLAINSTRING "Delete - enter the list of SubTests to be deleted" KEYLST
(((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(N "o
" EXPLAINSTRING "No - no change" RETURN NIL)))
NIL NIL (QUOTE (CONFIRMFLG NIL))
NIL))
[COND
(PreTest (SELECTQ (CAR PreTest)
[(A Add)
(COND
[(NUMBERP (CADR PreTest))
(RPTQ (CADR PreTest)
(PutValue self (QUOTE SubTest)
(GetValue (SEND ($ LOOPSTestPrimitive)
New)
(QUOTE name]
(T (for x in (MKLIST (CADR PreTest)) do (PutValue self
(QUOTE SubTest)
x]
((M Modify)
(for x in (@ SubTest) do (RemoveValue self (QUOTE SubTest)
x))
(for y in (MKLIST (CADR PreTest)) do (PutValue self (QUOTE SubTest)
x)))
((D Delete)
(for x in (MKLIST (CADR PreTest)) do (RemoveValue self (QUOTE SubTest)
x)))
(printout TTY "Illegal format SubTest list. Ignoring.." PreTest T]
(printout TTY "New SubTests are:" T (@ SubTest)
T])
(AskSyntaxTest
[LAMBDA (self) (* sm: "20-SEP-83 16:22")
(* ask for changes to Syntax test list)
(PROG (PreTest)
(SETQ PreTest (ASKUSER NIL NIL (LIST "Current SyntaxTest objects are:" (@ SyntaxTest)
"Do you want to add/delete any")
(QUOTE ((A "dd
" EXPLAINSTRING "Add - enter the ADDITIONS to SyntaxTest list" KEYLST (((READ)
"a number of new or a list of existing SyntaxTest objects"
RETURN ANSWER CONFIRMFLG T)))
(M "odify
" EXPLAINSTRING "Modify - enter the NEW SyntaxTest list" KEYLST (((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(D "elete
" EXPLAINSTRING "Delete - enter the list of SyntaxTests to be deleted" KEYLST
(((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(N "o
" EXPLAINSTRING "No - no change" RETURN NIL)))
NIL NIL (QUOTE (CONFIRMFLG NIL))
NIL))
[COND
(PreTest (SELECTQ (CAR PreTest)
[(A Add)
(COND
[(NUMBERP (CADR PreTest))
(RPTQ (CADR PreTest)
(PutValue self (QUOTE SyntaxTest)
(GetValue (SEND ($ LOOPSTestSyntax)
New)
(QUOTE name]
(T (for x in (MKLIST (CADR PreTest)) do (PutValue self
(QUOTE SyntaxTest)
x]
((M Modify)
(for x in (@ SyntaxTest) do (RemoveValue self (QUOTE SyntaxTest)
x))
(for y in (MKLIST (CADR PreTest)) do (PutValue self (QUOTE SyntaxTest)
x)))
((D Delete)
(for x in (MKLIST (CADR PreTest)) do (RemoveValue self (QUOTE
SyntaxTest)
x)))
(printout TTY "Illegal format SyntaxTest list. Ignoring.." PreTest T]
(printout TTY "New SyntaxTests are:" T (@ SyntaxTest)
T])
(AskTestCases
[LAMBDA (self) (* sm: "20-SEP-83 16:23")
(* ask for changes to TestCases list)
(PROG (PreTest)
TC (SETQ PreTest (ASKUSER NIL NIL (LIST "Current TestCase objects are:" (@ CasesUsed)
"Do you want to add/delete any")
(QUOTE ((A "dd
" EXPLAINSTRING "Add - enter the number of new TestCase objects to be created" KEYLST
(((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(D "elete
" EXPLAINSTRING "Delete - enter the list of TestCases to be deleted" KEYLST
(((READ)
NIL RETURN ANSWER CONFIRMFLG T)))
(N "o
" EXPLAINSTRING "No - no change" RETURN NIL)))
NIL NIL (QUOTE (CONFIRMFLG NIL))
NIL))
[COND
(PreTest (SELECTQ (CAR PreTest)
[(A Add)
(COND
((NOT (NUMBERP (CADR PreTest)))
(printout TTY "Specify a number. " T)
(GO TC)))
(RPTQ (CADR PreTest)
(PutValue self (QUOTE CasesUsed)
(GetValue (SEND ($ LOOPSTestCases)
New)
(QUOTE name]
((D Delete)
(for x in (MKLIST (CADR PreTest)) do (RemoveValue self (QUOTE
CasesUsed)
x)))
(printout TTY "Illegal format CasesUsed list. Ignoring.." PreTest T]
(printout TTY "New TestCases are:" T (@ CasesUsed)
T])
(BeginLoopsTest
[LAMBDA NIL (* sm: "20-SEP-83 16:23")
(* begins the test of rest of LOOPS after the basic
tests succeeded)
(PROG (Tlis Inp)
(* Variables set: Seed -
list of initial testobjs;HasTest -
ones which have TestExpr; Tested -
ones actually tested; Failed -
those which failed; NotDone -
those not completed)
[COND
((OR LTError (NOT LTResult))
(SETQ INP (ASKUSER 60 (QUOTE Y)
"The basic tests failed. Do you still want to continue?"
(QUOTE ((Y "es
" CONFIRMFLG NIL)
(N "o
" CONFIRMFLG NIL)))
T))
(COND
((EQ INP (QUOTE N))
(RETURN NIL]
(AND LTLOGFLAG (DRIBBLE (QUOTE LTLOG2)))
(SETQ Tlis (GenerateTestList))
(SETQ Seed (CAR Tlis))
(SETQ HasTest (CDR Tlis))
(SETQ Tested (RunTest Seed))
(SETQ Failed (for x in Tested when (NULL (GetValue x (QUOTE Tested?))) collect x))
(SETQ NotDone (APPEND (LDIFFERENCE HasTest Tested)
(for x in Tested when (UnknownValue? (GetValue x (QUOTE Tested?)))
collect x)))
(printout TTY T T T 15 "Summary of LOOPS Test:" T T)
[AND Failed (PROGN (printout TTY "Following failed:" T)
(for x in Failed do (printout TTY 10 (GetValue x (QUOTE TestDesc))
T]
[AND NotDone (PROGN (printout TTY T "Following could not be run to completion:" 45 "Reason"
T)
(for x in NotDone do (printout TTY 5 (GetValue x (QUOTE TestDesc))
45
(ReasonNotDone x)
T]
(COND
[(OR Failed NotDone)
(SETQ LTABROWSER (SETQ LTBROWSER (DisplayTestBrowser (APPEND Failed NotDone)
(QUOTE FailedTestBrowser)
NIL NIL NIL T]
(T (printout TTY "Congratulations!! You have a fully tested LOOPS System. Happy LOOPing"
T)))
(AND LTLOGFLAG (DRIBBLE NIL))
(RETURN (NOT (OR Failed NotDone])
(BuildPreTest
[LAMBDA (self varName localSt propName activeVal type) (* sm: " 8-OCT-82 11:25")
(* This is a getFn for PreTest in LOOPSTestPrimitive)
(* it appends SubTestOf to the front of the local state
and returns that as the actual PreTest list)
(* ASSUMPTION: This now forces all SubTestOf objects to be considered as PreTests. If this assumption is later
violated, this scheme of building PreTest list will have to be undone)
(APPEND (%@ SubTestOf)
(GetLocalState activeVal self varName propName])
(BuildPrimClassTest
[LAMBDA (self varName localSt propName activeVal type) (* sm: " 8-OCT-82 10:56")
(* This is a getFn for ClassPreTest CV in
LOOPSTestPrimitive)
(* it adds the value of IV SubTestOf to any values already in the CV ClassPreTest to compute the actual
ClassPreTest list. Normally, no separate values are planned for ClassPreTest. Currently, the main purpose of this
active value is to return the SubTestOf list as the ClassPreTest)
(APPEND (%@ SubTestOf)
(GetLocalState activeVal self varName propName])
(CheckClassTest
[LAMBDA (self TestedLst) (* sm: "20-SEP-83 16:24")
(* Checks the Class Pretests of a TestObj)
(PROG (TestRes Mat) (* check if class already tested)
[COND
((ValueExists? (@@ ClassTested?))
(RETURN (@@ ClassTested?] (* if class has no pretest, return T)
(COND
((NULL (@@ ClassPreTest))
(PrintIfLev LTMsgLev 5 (printout TTY 10 "SysNote: No class pretests for" -4
(@ name)
T))
(RETURN T)))
[SETQ TestRes (MAPCAR (@@ ClassPreTest)
(QUOTE (LAMBDA (x)
(CONS (SEND (GetObjectRec x)
TEST TestedLst)
x]
(COND
((SETQ Mat (FASSOC NIL TestRes))
(PutClassValue self (QUOTE ClassPreTest)
(CDR Mat)
(QUOTE Failed))
(←@@
ClassTested? NIL))
((SETQ Mat (FASSOC NotSetValue TestRes))
(PutClassValue self (QUOTE ClassPreTest)
(CDR Mat)
(QUOTE Failed))
(←@@
ClassTested? NotSetValue))
(T (←@@
ClassTested? T)))
(RETURN (@@ ClassTested?])
(CheckPreTest
[LAMBDA (self) (* sm: "20-SEP-83 16:24")
(* checks the PreTest of a TestObj)
(PROG (TestRes) (* see if already tested)
[COND
((ValueExists? (GetValue self (QUOTE PreTest)
(QUOTE Tested?)))
(RETURN (GetValue self (QUOTE PreTest)
(QUOTE Tested?]
(COND
((NULL (@ PreTest))
(printout TTY 10 "SysNote: No PreTests for " -4 (@ name)
T)
(RETURN T)))
[SETQ TestRes (MAPCAR (@ PreTest)
(QUOTE (LAMBDA (X)
(SEND (GetObjectRec X)
TEST]
[COND
((FMEMB NIL TestRes)
(PutValue self (QUOTE PreTest)
NIL
(QUOTE Tested?)))
((FMEMB NotSetValue TestRes)
(PutValue self (QUOTE PreTest)
NotSetValue
(QUOTE Tested?)))
(T (PutValue self (QUOTE PreTest)
T
(QUOTE Tested?]
(RETURN (GetValue self (QUOTE PreTest)
(QUOTE Tested?])
(CloseCurrentEnvironment
[LAMBDA NIL (* sm: "23-NOV-82 14:22")
(AND CurrentEnvironment (SEND CurrentEnvironment Close])
(CreateLTKBS1
[LAMBDA NIL (* sm: " 7-FEB-83 16:49")
(* creates the knowledge base LTKBS1 used by
LTESummarize)
(PROG NIL
(← (%$ KB)
New
(QUOTE LTKBS1)
(QUOTE X1)
T)
(← (%$ X1)
Open)
(← (%$ LOOPSCasesMeta)
New
(QUOTE LOOPSEnvSumm)
(QUOTE (LOOPSTestCases)))
(← (%$ LOOPSEnvSumm)
Add
(QUOTE CV)
(QUOTE Instances)
NIL)
(← (%$ LOOPSEnvSumm)
Add
(QUOTE CV)
(QUOTE InstancePrefix)
(QUOTE LESA))
(← (%$ LOOPSEnvSumm)
Add
(QUOTE CV)
(QUOTE UnnamedInstanceCount)
0)
(← (%$ LOOPSEnvSumm)
Add
(QUOTE CV)
(QUOTE InstanceComsVar)
(QUOTE DUMMYINSTANCES))
(← (%$ LOOPSEnvSumm)
Add
(QUOTE IV)
(QUOTE Etest)
NIL)
(← (%$ LOOPSEnvSumm)
Add
(QUOTE IV)
(QUOTE Link)
NIL)
(← (%$ LOOPSEnvSumm)
New
(QUOTE LESAA))
(← (%$ LOOPSEnvSumm)
New)
(PutValue (%$ LESAA)
(QUOTE Etest)
(QUOTE Old))
(← (%$ Class)
New
(QUOTE LOOPSEnvTest))
(← (%$ LOOPSEnvTest)
Add
(QUOTE IV)
(QUOTE Key)
NIL)
(PutValue (%$ LESAA)
(QUOTE Link)
(← (%$ LOOPSEnvTest)
New))
(PutValue (GetValue (%$ LESAA)
(QUOTE Link))
(QUOTE Key)
(QUOTE LESAA))
[SETQ LTV11 (MKNAME (UID (GetValue (%$ LESAA)
(QUOTE Link]
(← (%$ X1)
Cleanup)
(← (%$ X1)
Close)
(← (%$ KB)
Old
(QUOTE LTKBS1)
(QUOTE X2))
(← (%$ X2)
Open)
(PutValue (%$ LESAA)
(QUOTE Etest)
(QUOTE New))
(← (%$ LOOPSEnvSumm)
New)
(PutValue (%$ LESA2)
(QUOTE Etest)
(QUOTE LESA2))
(← (%$ X2)
Close)
(← (%$ KB)
Old
(QUOTE LTKBS1)
(QUOTE X3))
(← (%$ X3)
Open)
(← (%$ LESA1)
Destroy)
(PutValue (%$ LESA2)
(QUOTE Link)
(← (%$ LOOPSEnvTest)
New))
(PutValue (GetValue (%$ LESA2)
(QUOTE Link))
(QUOTE Key)
(QUOTE LESA2))
[SETQ LTV12 (MKNAME (UID (GetValue (%$ LESA2)
(QUOTE Link]
(PutValue (%$ LESAA)
(QUOTE Link)
NIL)
(← (%$ X3)
Close)
(RETURN (LIST (QUOTE (LOOPSEnvSumm LOOPSEnvTest))
(QUOTE (LESAA LESA2))
(QUOTE (LESA1))
(LIST (QUOTE LTV11)
LTV11)
(LIST (QUOTE LTV12)
LTV12])
(DescribePreviousTry
[LAMBDA (self) (* sm: "20-SEP-83 16:24")
(* describes result of previous test of this obj)
(PROG NIL
(RETURN (COND
((ValueNonNIL? (ExaminePreviousTry self))
(printout TTY "Test was successful!!" T)
T)
((AND (@@ ClassPreTest)
(NOT (EQ (@@ ClassTested?)
T)))
(printout TTY "Following PreTest for this Class of tests failed:" T
(@@ self ClassPreTest Failed)
T)
NIL)
((AND (@ PreTest)
(NOT (EQ (@ self PreTest Tested?)
T)))
(printout TTY "Following PreTests failed:" (@ self PreTest Failed)
T)
NIL)
((AND (@ SetUp)
(NOT (EQ (@ self SetUp Tested?)
T)))
(printout TTY "Following SetUp expression(s) caused error:" T)
(PrintFailedExp self (@ self SetUp FailedExp))
NIL)
((NULL (@ TestExpr))
(printout TTY "No test is available yet." T)
T)
(T (printout TTY "Following TestExpression(s) failed or caused error:" T)
(PrintFailedExp self (@ self TestExpr FailedExp))
NIL])
(DescribeTestLink
[LAMBDA (self link Desc Selected) (* sm: "20-SEP-83 16:25")
(* describes the values of link, using a menu of
description-choices)
(PROG ((vals (GetValue self link))
obj) (* Desc -
if NIL, user is asked for a value)
(* Selected -
if NIL user is asked.)
(COND
((NULL vals)
(RETURN NIL)))
[COND
(Desc)
(T (SETQ Desc (MENU (create MENU
ITEMS ←(QUOTE (TestDesc TestDescAll TestDescAsk TestCode PP))
TITLE ← "Desc What"]
(COND
((NULL Desc)
(RETURN NIL)))
[COND
(Selected)
(T (SETQ Selected (ReadLinkMenu self link T T]
[for x in Selected do (PROGN (SETQ obj (GetObjectRec x))
(SELECTQ Desc
(PP (SEND obj PP))
(TestCode (PrintTestCode obj))
(TestDesc (printout TTY (ObjectName obj)
-5
(TestObjectDesc obj)
T))
(TestDescAll (printout TTY (ObjectName obj)
-5
(TestObjectDesc obj)
T)
(DescribeTestLink obj link (QUOTE
TestDescAll)
(GetValue obj link)))
(TestDescAsk (printout TTY (ObjectName obj)
-5
(TestObjectDesc obj)
T)
(DescribeTestLink obj link (QUOTE
TestDescAsk)
NIL))
(printout TTY
"Error!! Should not reach here in func: DescribeTestLink"
T]
(RETURN Selected])
(DisplayTestBrowser
[LAMBDA (Objs BrowserClass Link Region Title FlipFlg) (* sm: " 3-DEC-82 09:55")
(* displays a TestBrowser with "Objs", using "Link", in a window bounded by "Region" and "Title". All except the
first arg can be defaulted to whats in the class (%$ TestBrowser))
(* FlipFlg -
if T then all objects which have Tested? IV set to T
will be flipped)
(* binds global LTBROWSER to the browser created)
(PROG NIL
(COND
((NULL Objs)
(RETURN NIL)))
[COND
((NULL BrowserClass)
(SETQ BrowserClass (QUOTE TestBrowser]
(SETQ LTBROWSER (← (GetObjectRec BrowserClass)
New))
[COND
(Link (PutValue LTBROWSER (QUOTE subLinks)
(MKLIST Link]
(COND
(Title (PutValue LTBROWSER (QUOTE title)
Title)))
[← LTBROWSER Show [SETQ Objs (MAPCAR Objs (QUOTE (LAMBDA (X)
(GetObjectRec X]
(CREATEW [COND
(Region)
(T (GetValue LTBROWSER (QUOTE window)
(QUOTE DefRegion]
(GetValue LTBROWSER (QUOTE title]
(COND
(FlipFlg (TickleBrowserNodes Objs LTBROWSER)))
(RETURN LTBROWSER])
(DoLoopsTest
[LAMBDA (self testVar testMsg contFl TestedLst) (* sm: "20-SEP-83 16:25")
(* tests the objs indicated by IV testVar, using msg
testMsg, and force test flag contFl)
(PROG (TestRes Mat) (* set up default values if not passed)
(COND
((NULL testVar)
(printout TTY "No Test IV given." -2 "Aborting.." T)
(RETURN NIL)))
[COND
((NULL testMsg)
(SETQ testMsg (QUOTE TEST] (* see if already tested)
[COND
((ValueExists? (GetValue self testVar (QUOTE Tested?)))
(RETURN (GetValue self testVar (QUOTE Tested?]
(COND
((NULL (GetValue self testVar))
(PrintIfLev LTMsgLev 5 (printout TTY 10 "SysNote: No " testVar " for " -4
(@ name)
T))
(PutValue self testVar T (QUOTE Tested?))
(RETURN T)))
[SETQ TestRes (MAPCAR (GetValue self testVar)
(QUOTE (LAMBDA (X)
(CONS (DoMethod (GetObjectRec X)
testMsg NIL TestedLst contFl)
X]
[COND
((SETQ Mat (FASSOC NIL TestRes))
(PutValue self testVar (CDR Mat)
(QUOTE Failed))
(PutValue self testVar NIL (QUOTE Tested?)))
((SETQ Mat (FASSOC NotSetValue TestRes))
(PutValue self testVar (CDR Mat)
(QUOTE Failed))
(PutValue self testVar NotSetValue (QUOTE Tested?)))
(T (PutValue self testVar T (QUOTE Tested?]
(RETURN (GetValue self testVar (QUOTE Tested?])
(DoTestSelf
[LAMBDA (self TestedLst) (* sm: "20-SEP-83 16:25")
(* executes the SetUp, TestExpr, and AfterTest of a Test
Object)
(PROG (TestExp)
(PrintTestHeader self)
(SETQ TestExp (@ TestExpr))
[COND
((NULL TestExp)
(printout TTY 5 "No test is currently available for.." -3 (@ TestDesc)
T)
(←@
Tested?
(COND
(LTAskNoTestAvailable (ASKUSER 15 (QUOTE Y)
(QUOTE ("Indicate if this feature works OK"))
(QUOTE ((Y "es
" RETURN T EXPLAINSTRING "Yes- the test for this is marked as successful")
(N "o
" RETURN NIL EXPLAINSTRING "No- the test for this is marked as Unsuccessful")
(U "nknown
" RETURN NotSetValue EXPLAINSTRING "Unknown- the test for this is marked as incomplete")))
NIL NIL (QUOTE (CONFIRMFLG NIL))
NIL))
(T (printout TTY "Assuming it is OK" T)
T)))
(RETURN (@ Tested?]
[COND
((NOT (EQ (PerformSetup self)
T))
(AND LTBROWSER (SEND LTBROWSER BoxNode self))
(RETURN (PerformAltTest self (QUOTE SetUp)
NIL TestedLst]
(PerformTest self)
(COND
((ValueExists? (@ self SetUp Tested?))
(ERRORSET (GetValue self (QUOTE AfterTest))
T)))
(AND LTBROWSER (SEND LTBROWSER BoxNode self))
(RETURN (@ Tested?])
(EQACTVAL
[LAMBDA (ActVal Flist) (* sm: "29-NOV-82 17:08")
(* checks if ActVal is an active value and has fields as
given by Flist)
(* currently works only for singly nested active value)
(AND (EQ (CAR Flist)
(fetch localState of ActVal))
(EQ (CADR Flist)
(fetch getFn of ActVal))
(EQ (CADDR Flist)
(fetch putFn of ActVal])
(EditOtherLinksMenu
[LAMBDA NIL (* sm: "25-NOV-82 14:02")
(* gives a popup menu to select other Test Links)
(MENU (create MENU
ITEMS ←[QUOTE ((AlternateTestOf (QUOTE ATO))
(SubTestOf (QUOTE SUBO))
(UsedBy (QUOTE UB))
(ClassPreTest (QUOTE CPT]
TITLE ← "Other Test Links"])
(EditPreTest
[LAMBDA (self link) (* sm: "20-SEP-83 16:26")
(* allows user to edit a dependency list via a menu)
(PROG (INP INP2 (Redo (QUOTE LOOP))
Rval)
(COND
((NULL link)
(RETURN NIL)))
(printout TTY "Editing" -2 link "::" -2 (GetValue self link)
T) (* if linkval is NIL, offer to add via Add menu)
[COND
((NULL (GetValue self link))
(SETQ INP (MENU (create MENU
ITEMS ←(QUOTE ((Add (QUOTE Add)
"object name or list of names to be added along this link")
(AddNum (QUOTE AddNum)
"enter a number for how many objects of this type are to be added")
(DefAdd (QUOTE DefAdd)
"ClassName or (ClsName InsName) to CREATE and then add an object")))
TITLE ← "Add Options")))
(COND
(INP (SETQ Redo (QUOTE LOOP2]
LOOP(COND
((EQ Redo (QUOTE RETURN))
(RETURN Rval))
((OR (NULL Redo)
(EQ Redo (QUOTE LOOP)))
(PRIN1 "LinkEdCmd:")
(SETQ INP (READ)))
((EQ Redo (QUOTE LOOP2)) (* for looping without reading again)
))
(SETQ Redo (QUOTE RETURN))
[ERSETQ (SELECTQ INP
(Add (PRIN1 "ADD:")
(SETQ INP2 (READ))
(for x in (MKLIST INP2) do (PutValue self link x)))
[AddNum (COND
((FMEMB link (QUOTE (PreTest UsesObj)))
(printout TTY "Not a valid way to add to" -2 link -2
"Use Add commd"
T)
(SETQ Redo (QUOTE LOOP)))
(T (PRIN1 "Number:")
(SETQ INP2 (READ))
(COND
((NOT (NUMBERP INP2))
(printout TTY "Enter a number!!" T)
(SETQ Redo (QUOTE LOOP2)))
(T [RPTQ INP2 (PutValue self link
(GetValue (SEND (FindObjForLink
link self)
New)
(QUOTE name]
(SETQ Redo (QUOTE LOOP]
(Delete (SETQ INP2 (ReadLinkMenu self link NIL T))
(for x in (MKLIST INP2) do (RemoveValue self link x))
(SETQ Redo (QUOTE LOOP)))
(Desc (DescribeTestLink self link)
(SETQ Redo (QUOTE LOOP)))
(DefAdd (PRIN1 "Class or (Class Inst)::")
(SETQ INP2 (MKLIST (READ)))
(COND
[(type? class (GetObjectRec (CAR INP2)))
(PutValue self link (GetValue (SEND (GetObjectRec
(CAR INP2))
New
(COND
((CDR INP2)
(CADR INP2))
(T NIL)))
(QUOTE name]
(T (printout TTY (CAR INP2)
-2 "Not a class. Redo" T)))
(SETQ Redo (QUOTE LOOP)))
((QUIT Quit Q))
(Modify (PRIN1 "NewList:")
(SETQ INP2 (READ))
(for x in (GetValue self link) do (RemoveValue self link x))
(for y in (MKLIST INP2) do (PutValue self link y))
(SETQ Redo (QUOTE LOOP)))
((PP! PP)
(SETQ INP2 (ReadLinkMenu self link T T))
(for x in INP2 do (DoMethod (GetObjectRec x)
INP))
(SETQ Redo (QUOTE LOOP)))
[(Edit EDIT VEDIT Dedit EditIV EditCV)
(SETQ INP2 (ReadLinkMenu self link T T))
(for x in INP2 do (← (GetObjectRec x)
Edit
(SELECTQ INP
(VEDIT (QUOTE (EE)))
(Dedit (QUOTE (de)))
((Edit EDIT)
NIL)
NIL]
(List (printout TTY (GetValue self link)
T)
(SETQ Redo (QUOTE LOOP)))
(Select (SETQ INP2 (ReadLinkMenu self link T T))
(SETQ Rval INP2))
(PROGN (COND
((NULL INP))
(T (printout TTY "Illegal command" -3 INP -3 "Retry" T)))
(SETQ Redo (QUOTE LOOP]
(GO LOOP])
(EditTestOtherCmds
[LAMBDA NIL (* sm: "24-NOV-82 18:33")
(* creates a popup menu for less often used commands for
EditTEST cmds)
(MENU (create MENU
ITEMS ←(QUOTE ((Edit (QUOTE EDIT)
"edit using the lisp editor")
(EditIVs (QUOTE EDITIV)
"edit IVs only using TTYEdit")
(EditCVs (QUOTE EDITCV)
"edit CVs only using TTYEdit")
(PP!(QUOTE PP!)
"PP! of test object")
(ResetPre (QUOTE RESETPRE)
"reset test object and its pretests")
(ResetSub (QUOTE RESETSUB)
"reset test object and its subtests, syntax test etc")
(TestSub (QUOTE TESTSUB)
"test current object and all its subtests, syntax test")))
TITLE ← "Other Edit Cmds"])
(EvaluateANDALLTest
[LAMBDA (self Test) (* sm: "30-NOV-82 17:15")
(* evaluates test expressions with ANDALL for
EvaluateTest)
(* evaluates all Clauses, even if one fails or causes
error)
(PROG (Msg (Res T)
FailedVal Val Exp)
[for x in (CDR Test) do (PROGN (SETQ Val (ERRORSET (COND
((ATOM x)
(SETQ Msg NIL)
(SETQ Exp x))
((EQUAL (CAR x)
(QUOTE ATEST))
(SETQ Exp (CADR x))
[SETQ Msg (COND
((NULL (CDDR x))
NIL)
(T (CADDR x]
Exp)
(T (SETQ Msg NIL)
(SETQ Exp x)))
T))
(COND
((OR (NULL Val)
(NULL (CAR Val)))
(SETQ FailedVal Val)
(SETQ FMSG (CONS [LIST Msg Exp (COND
((NULL Val)
"*ERROR*")
(T (CAR Val]
FMSG))
(SETQ Res NIL]
(COND
((NOT Res)
(RETURN FailedVal)))
(RETURN Val])
(EvaluateANDTest
[LAMBDA (self Test) (* sm: "30-NOV-82 17:14")
(* evaluates test expressions with AND for EvaluateTest)
(PROG (Msg (Res T)
Val Exp)
[for x in (CDR Test) while Res do (PROGN (SETQ Val (ERRORSET (COND
((ATOM x)
(SETQ Msg NIL)
(SETQ Exp x))
((EQUAL (CAR x)
(QUOTE ATEST))
(SETQ Exp (CADR x))
[SETQ Msg
(COND
((NULL (CDDR x))
NIL)
(T (CADDR x]
Exp)
(T (SETQ Msg NIL)
(SETQ Exp x)))
T))
(COND
((OR (NULL Val)
(NULL (CAR Val)))
(SETQ Res NIL]
[COND
((NOT Res)
(SETQ FMSG (CONS (LIST Msg Exp (COND
((NULL Val)
"*ERROR*")
(T (CAR Val]
(RETURN Val])
(EvaluatePROGTest
[LAMBDA (self Test) (* sm: "30-NOV-82 17:17")
(* evaluates test expressions with PROG for
EvaluateTest)
(PROG (Msg (Res T)
Val Exp)
[for x in (CDR Test) while Res do (PROGN (SETQ Val (ERRORSET (COND
((ATOM x)
(SETQ Msg NIL)
(SETQ Exp x))
((EQUAL (CAR x)
(QUOTE ATEST))
(SETQ Exp (CADR x))
[SETQ Msg
(COND
((NULL (CDDR x))
NIL)
(T (CADDR x]
Exp)
(T (SETQ Msg NIL)
(SETQ Exp x)))
T))
(COND
((NULL Val)
(SETQ Res NIL]
[COND
((NOT Res)
(SETQ FMSG (CONS (LIST Msg Exp (COND
((NULL Val)
"*ERROR*")
(T (CAR Val]
(RETURN Val])
(EvaluateTest
[LAMBDA (self Field APFlg) (* sm: "20-SEP-83 16:27")
(* evaluates testfield of a TestObj.
Returns: NIL -
if error; (LIST val) otherwise)
(* APFlg -
determines if Exps without AND,ANDALL or PROGN are to be treated as one or the other. Default is PROGN, i.e.
APFlg=NIL means PROGN will be used)
(* Sets global FMSG as follows: for each failed test (error or NIL), makes a dotted pair from TestMsg and TestExp.
If no TestMsg, then makes dotted pair from TestExp and NIL.)
(* Expressions such as AND, ATEST etc receive special
treatment)
(PROG ((Test (GetValue self Field))
(DefType (QUOTE PROGN))
Res)
(SETQ FMSG NIL)
[COND
(APFlg (SETQ DefType (QUOTE AND]
[COND
((NULL Test)
(RETURN (QUOTE (T]
[COND
((ATOM Test)
(RETURN (ERRORSET Test T]
[COND
[(MEMBER (CAR Test)
(QUOTE (PROGN AND ANDALL]
(T (SETQ Test (LIST DefType Test]
[COND
((EQUAL (CAR Test)
(QUOTE AND))
(RETURN (EvaluateANDTest self Test)))
((EQUAL (CAR Test)
(QUOTE ANDALL))
(RETURN (EvaluateANDALLTest self Test)))
((EQUAL (CAR Test)
(QUOTE PROGN))
(RETURN (EvaluatePROGTest self Test]
(printout TTY "Should not reach here in function: EvaluateTest" T)
(RETURN NIL])
(ExaminePreviousTry
[LAMBDA (self TestedLst) (* sm: "29-MAR-83 14:32")
(* checks the result of previous try at running this
TestObj)
(PROG (AltRes)
[COND
((ValueNonNIL? (%@ Tested?))
(RETURN (%@ Tested?]
[SETQ AltRes (CONS (%@ Tested?)
(for x in (GetValue self (QUOTE AltTest)) collect (GetValue
(GetObjectRec x)
(QUOTE Tested?]
(RETURN (COND
((FMEMB T AltRes)
T)
((OR (FMEMB NotSetValue AltRes)
(FMEMB (QUOTE U)
AltRes))
(QUOTE U))
(T NIL])
(ExecTestFields
[LAMBDA (self) (* sm: "20-SEP-83 16:27")
(* executes one of the Test IVs -
selected from a menu)
(PROG (INP RES)
(SETQ INP (MENU (create MENU
ITEMS ←(QUOTE (SetUp TestExpr ResetExp))
TITLE ← "Test Fields")))
(COND
(INP (printout TTY "Executing.." INP -2 .PPF (GetValue self INP)
T
(PROGN (SETQ RES (ERRORSET (GetValue self INP)
T))
(COND
(RES (CAR RES))
(T "Error..")))
T)))
(RETURN self])
(FindObjForLink
[LAMBDA (link self) (* sm: "18-OCT-82 10:51")
(* returns the object corresp to the class that best
determines the values of a particular dependency link)
[COND
((NULL self)
(SETQ self (%$ LOOPSTestObject]
(SELECTQ link
(PreTest (Class self))
(CasesUsed (%$ LOOPSTestCases))
(SubTest (%$ LOOPSTestPrimitive))
(SyntaxTest (%$ LOOPSTestSyntax))
(UsesObj (%$ LOOPSTestSuper))
(AltTest (Class self])
(FlashTestBrowser
[LAMBDA (self varName newValue propName activeVal type) (* sm: "15-NOV-82 10:25")
(* This is a putFn for flashing the test node in
testbrowser)
[COND
(LTBROWSER (COND
((AND (NULL newValue)
(EQ (GetValue self varName propName)
NotSetValue))
(ERSETQ (← LTBROWSER FlashNode self 3]
(PutLocalState activeVal newValue self varName propName type])
(GIVGetFn
[LAMBDA (self varName localSt propName activeVal type) (* sm: "29-MAR-83 16:43")
(* GetFn used in LTFGetInitialValue tests.
Attached to IVs GIV1 and GIV2 in LOOPSTestClass1)
(ADD1 localSt])
(GenerateTestList
[LAMBDA NIL (* sm: "11-AUG-83 13:26")
(* returns Seed.HasTest, where Seed is list of tests
with no preconditions and HasTest is list of all tests
which are DEFINED)
(* sets global AllTest)
(PROG (HasTest Seed)
[SETQ AllTest (APPEND (GetClassValue (%$ LOOPSTestBasic)
(QUOTE Instances))
(GetClassValue (%$ LOOPSTestBraidObject)
(QUOTE Instances))
(GetClassValue (%$ LOOPSTestKernel)
(QUOTE Instances))
(GetClassValue (%$ LOOPSTestLispFunc)
(QUOTE Instances))
(GetClassValue (%$ LOOPSTestMethod)
(QUOTE Instances))
(COND
(KBTestsFlg (GetClassValue (%$ LOOPSTestEnvironment)
(QUOTE Instances)))
(T NIL]
(SETQ HasTest (for x in AllTest eachtime (SETQ y (GetObjectRec x))
when (OR (GetValue y (QUOTE TestExpr))
(GetValue y (QUOTE PreTestOf))
(GetValue y (QUOTE PreTest)))
collect y))
(SETQ Seed (for x in HasTest when [AND (NULL (GetValue x (QUOTE PreTest] collect x))
(RETURN (CONS Seed HasTest])
(GetFromActVal
[LAMBDA (self varName localSt propName activeVal type) (* sm: "25-OCT-82 15:22")
(* This is a getFn for testing Active Values)
(* It returns the local state, going down to embedded
Act Val if necessary)
(GetLocalState activeVal self varName propName])
(InformTestBrowser
[LAMBDA (self varName newValue propName activeVal type) (* sm: "29-MAR-83 15:42")
(* This is a putFn for informing TestBrowser if testobj
node is to be flashed or flipped)
[COND
(LTBROWSER (COND
((AND (UnknownValue? (GetValue self varName propName))
(ValueExists? newValue))
(ERSETQ (DoMethod LTBROWSER (COND
((EQ newValue T)
(QUOTE FlipNode))
(T (QUOTE FlashNode)))
NIL self 5)))
((AND (UnknownValue? newValue)
(EQ (GetValue self varName propName)
T))
(ERSETQ (← LTBROWSER FlipNode self]
(PutLocalState activeVal newValue self varName propName type])
(LOOPSTestEnvironment.TEST
[LAMBDA (self TestedLst) (* sm: "16-NOV-82 17:01")
(* does TEST for Environment tests)
(PROG NIL
(←Super
self TEST TestedLst)
[COND
((EQ (GetValue self (QUOTE SetUp)
(QUOTE Tested?))
T)
(ERRORSET (GetValue self (QUOTE AfterTest]
(RETURN (%@ Tested?])
(LOOPSTestObject.DefineTEST
[LAMBDA (self) (* sm: "20-SEP-83 16:27")
(* used to define Test description for a TestObj.)
(* This general proc may be used in conjunction with
more specialized ones)
(PROG (Name PreTest Cmd)
(SETQ Name (@ name))
(printout TTY " Please do not change the dependency lists in the editor" T)
(SEND self Edit)
(COND
((NULL (GetValueOnly self (QUOTE PreTest)))
(AskPreTest self)))
(COND
((NULL (@ CasesUsed))
(AskTestCases self)))
(COND
((NULL (@ SyntaxTest))
(AskSyntaxTest self)))
(COND
((NULL (@ SubTest))
(AskSubTest self)))
(RETURN self])
(LOOPSTestObject.Describe
[LAMBDA (self) (* sm: "20-SEP-83 16:27")
(* prints a description of the TestObj)
(PROG NIL
(printout TTY "Test Desc::" -2 (@ TestDesc)
T)
(COND
((@ self Tested? DoneOnce)
(DescribePreviousTry self))
(T (printout TTY "Not tested yet. To test, send TEST message or use TestBrowser" T])
(LOOPSTestObject.EditTEST
[LAMBDA (self) (* sm: "20-SEP-83 16:28")
(* edits a TestObj using menus)
(PROG ((EditTestObj self)
(Stack (CONS self))
(Redo T)
INP2 INP)
[COND
(EditTestWindows (for x in EditTestWindows do (OPENW x)))
(T (SETQ EditTestWindows (SetupEditTestObjMenu]
(printout TTY "Editing Test Object:" -4 (@ name)
T)
LOOP(COND
(Redo (PRIN1 "EditCmd:"))
(T (RETURN self)))
[ERSETQ (SELECTQ (SETQ INP (READ))
((Quit QUIT Q q)
[MAPC EditTestWindows (FUNCTION (LAMBDA (X)
(CLOSEW X]
(SETQ Redo NIL))
[DEDIT (printout TTY "Please do not edit dependency link fields" T)
(SEND EditTestObj Edit (QUOTE (de]
[(EE VEDIT)
(printout TTY "Please do not edit dependency link fields" T)
(SEND EditTestObj Edit (QUOTE (ee]
(EDIT (SEND EditTestObj Edit))
((PP PP!)
(ERSETQ (DoMethod EditTestObj INP)))
(DESCRIBE (ERSETQ (SEND EditTestObj Describe)))
(WHO (printout TTY "Editing:" (ObjectName EditTestObj)
T))
(TOP (SETQ Stack (LAST Stack))
(SETQ EditTestObj (CAR Stack))
(printout TTY "Editing:" -3 EditTestObj T))
[SELECT (PRIN1 "ObjName:")
(SETQ INP2 (READ))
(COND
((GetObjectRec INP2)
(SETQ Stack (CONS EditTestObj Stack))
(SETQ EditTestObj (GetObjectRec INP2)))
(T (printout TTY INP2 -3 "Not an object. Redo command" T]
(REMEMBER (SETQ Stack (CONS EditTestObj Stack)))
[UNREMEMBER (SETQ EditTestObj (GetObjectRec (CAR Stack)))
(printout TTY "Editing:" (ObjectName EditTestObj)
T)
(SETQ Stack (COND
((EQ (LENGTH Stack)
1)
Stack)
(T (CDR Stack]
[(PT CU SUB ST AT UO PTO SUBO ATO STO CPT UB)
[SETQ INP2 (EditPreTest EditTestObj (SELECTQ INP
(PT (QUOTE PreTest))
(SUB (QUOTE SubTest))
(PTO (QUOTE PreTestOf))
(CU (QUOTE CasesUsed))
(ST (QUOTE SyntaxTest))
(AT (QUOTE AltTest))
(UO (QUOTE UsesObj))
(SUBO (QUOTE SubTestOf))
(ATO (QUOTE AltTestOf))
(STO (QUOTE SyntaxTestOf))
(printout TTY
"Cannot edit along this link YET!"
T]
(COND
(INP2 (SETQ Stack (APPEND (CDR INP2)
(CONS EditTestObj Stack)))
(SETQ EditTestObj (GetObjectRec (CAR INP2)))
(printout TTY "Editing:" -4 (ObjectName EditTestObj)
T]
(EVAL (UE))
(EXEC (ExecTestFields EditTestObj))
(TEST (ERSETQ (SEND EditTestObj TEST)))
(RETEST (ERSETQ (SEND EditTestObj ReTest)))
(TESTSUB (ERSETQ (SEND EditTestObj TEST!)))
(RESET (ERSETQ (SEND EditTestObj ResetSelf)))
(RESETPRE (ERSETQ (SEND EditTestObj Reset)))
(RESETSUB (ERSETQ (SEND EditTestObj Reset!)))
(? (printout TTY "Use the menu" T))
(COND
((NULL INP))
(T (printout TTY "Illegal command. " -3 INP T]
(GO LOOP])
(LOOPSTestObject.EditTestInTTYProcess
[LAMBDA (self) (* sm: "31-MAY-83 16:17")
(* calls EditTEST in TTY Process)
(EVAL.IN.TTY.PROCESS (LIST (QUOTE ←)
self
(QUOTE EditTEST])
(LOOPSTestObject.GetTestCode
[LAMBDA (self) (* sm: "21-OCT-82 14:04")
(* returns the Test Code fields)
(MAPCAR (QUOTE (SetUp TestExpr ResetExp))
(QUOTE (LAMBDA (X)
(LIST X (GetValue self X])
(LOOPSTestObject.TEST
[LAMBDA (self TestedLst) (* sm: "20-SEP-83 16:28")
(* performs the basic TEST for a TestObject)
(PROG (FMSG (TestingObject self)
PrevRes HELPFLAG (HeaderFlag T)) (* HeaderFlag is used by: PreTestsSatisfied?,
DoTestSelf)
(CloseCurrentEnvironment)
(AND CurrentEnvironment (SEND CurrentEnvironment MakeNotCurrent))
(PutValue self (QUOTE Tested?)
T
(QUOTE DoneOnce))
(COND
([AND TestedLst (NOT (FMEMB self (CAR TestedLst]
(TCONC TestedLst self)))
(COND
((ValueExists? (SETQ PrevRes (ExaminePreviousTry self TestedLst)))
(PrintIfLev LTMsgLev 7 (printout TTY "Test for " -4 (@ TestDesc)
-4 "was" -5 (COND
(PrevRes "Successful")
(T "Unsuccessful"))
T))
(RETURN PrevRes))) (* check pretests)
(AND LTBROWSER (← LTBROWSER BoxNode self))
(COND
((EQ (SETQ Res (PreTestsSatisfied? self TestedLst))
T))
(T (* pretests failed. Return)
(AND LTBROWSER (← LTBROWSER BoxNode self))
(RETURN Res)))
(RETURN (DoTestSelf self TestedLst])
(LOOPSTestObject.TEST!
[LAMBDA (self ContFl) (* sm: "20-SEP-83 16:29")
(* first TESTs itself, and if successful, then does
other tests- SubTest, SyntaxTest, AltTest.)
(* Sets IV CompletelyTested? if SubTest and SyntaxTest
are successful)
(* ContFl if T, then continues, even if basic test
failed. this may be useful in some cases)
(PROG (TestRes) (* Check if already CompletelyTested?)
[COND
((ValueExists? (@ CompletelyTested?))
(printout TTY "Overall Test for" -4 (@ TestDesc)
-4 "was" -5 (COND
((@ CompletelyTested?)
"Successful")
(T "Unsuccessful"))
T)
(RETURN (@ CompletelyTested?]
(SEND self TEST)
[COND
([AND (NOT (EQ ContFl T))
(NOT (ValueNonNIL? (GetValue self (QUOTE Tested?]
(printout TTY "Not proceeding with complete test of.." -4 (@ TestDesc)
T)
(←@
CompletelyTested? NotSetValue)
(RETURN (@ CompletelyTested?]
(COND
([NOT (ValueNonNIL? (GetValue self (QUOTE Tested?]
(printout TTY
"Proceeding with complete test, even though this feature failed. Interpret results CAREFULLY"
T)))
(DoLoopsTest self (QUOTE SubTest)
(QUOTE TEST!)
ContFl)
(DoLoopsTest self (QUOTE SyntaxTest)
(QUOTE TEST!)
ContFl)
(DoLoopsTest self (QUOTE AltTest)
(QUOTE TEST!)
ContFl)
[PutValue self (QUOTE CompletelyTested?)
(PROGN [SETQ TestRes (LIST (@ Tested?)
(GetValue self (QUOTE SubTest)
(QUOTE Tested?))
(GetValue self (QUOTE SyntaxTest)
(QUOTE Tested?]
(COND
((FMEMB NotSetValue TestRes)
NotSetValue)
((FMEMB NIL TestRes)
NIL)
(T T]
(printout TTY "Overall test for" -4 (@ TestDesc)
-4 "was" -5 (SELECTQ (@ CompletelyTested?)
(NIL "Unsuccessful")
(T "Successful")
(QUOTE "Indeterminate"))
-2 TestRes T)
(RETURN (@ CompletelyTested?])
(LOOPSTestObject.TESTDep
[LAMBDA (self) (* sm: "13-DEC-82 13:15")
(* generates TEST call to self, and TESTDep to PreTestOf
list, and SubTest list only if it succeeds)
(* Returns list of objects called)
(PROG (Called)
(SETQ Called (LIST self))
(SEND self TEST)
[COND
((ValueNonNIL? (%@ Tested?))
(NCONC Called (for x in (GetValue self (QUOTE SubTest)) join (← (GetObjectRec x)
TESTDep))
(for x in (GetValue self (QUOTE PreTestOf)) join (← (GetObjectRec x)
TESTDep]
(RETURN Called])
(LOOPSTestObject.TESTall
[LAMBDA (self) (* sm: "26-OCT-82 11:35")
(* generates TEST call to self, PreTestOf list, and
SubTest list)
(* Returns list of objects called)
(PROG (Called)
(SETQ Called (LIST self))
(SEND self TEST)
(NCONC Called (for x in (GetValue self (QUOTE SubTest)) join (SEND (GetObjectRec x)
TESTall))
(for x in (GetValue self (QUOTE PreTestOf)) join (SEND (GetObjectRec x)
TESTall)))
(RETURN Called])
(LOOPSTestObject.TestSelf
[LAMBDA (self TestedLst) (* sm: "20-SEP-83 16:29")
(* performs the basic TEST for a TestObject but
continues even if PreTests fail)
(PROG (FMSG (TestingObject self)
PrevRes HELPFLAG (HeaderFlag T)) (* HeaderFlag is used by: PreTestsSatisfied?,
DoTestSelf)
(CloseCurrentEnvironment)
(AND CurrentEnvironment (SEND CurrentEnvironment MakeNotCurrent))
(PutValue self (QUOTE Tested?)
T
(QUOTE DoneOnce))
(COND
([AND TestedLst (NOT (FMEMB self (CAR TestedLst]
(TCONC TestedLst self)))
(COND
((ValueExists? (SETQ PrevRes (ExaminePreviousTry self TestedLst)))
(PrintIfLev LTMsgLev 7 (printout TTY "Test for " -4 (@ TestDesc)
-4 "was" -5 (COND
(PrevRes "Successful")
(T "Unsuccessful"))
T))
(RETURN PrevRes))) (* check pretests)
(AND LTBROWSER (← LTBROWSER BoxNode self))
(COND
((EQ (SETQ Res (PreTestsSatisfied? self TestedLst))
T))
(T (* pretests failed. Return)
(printout TTY "PreTests failed for" -4 (@ TestDesc)
-4 "Nonethless, continuing with test - interpret results accordingly" T)))
(RETURN (DoTestSelf self TestedLst])
(LOOPSTestPrimitive.XTEST
[LAMBDA (self) (* sm: "20-SEP-83 16:30")
(* performs the basic TEST for a Primitive TestObject
ONLYIF its super test Tested T and sets own Tested? IV)
(PROG (TestExp Resp Sval Tval)
[COND
((ValueExists? (@ Tested?))
(printout TTY "Basic Test for " -4 (@ TestDesc)
-4 "was" -5 (COND
((@ Tested?)
"Successful")
(T "Unsuccessful"))
T)
(RETURN (@ Tested?]
(printout TTY "TESTING.." -4 (@ TestDesc)
T)
(COND
((NOT (EQ (CheckClassTest self)
T))
(printout TTY 5 "Basic test for this class failed. Stopping.." T)
(RETURN NotSetValue))) (* The class PreTest were successful so continue...)
(COND
((NOT (EQ (CheckPreTest self)
T))
(printout TTY 5 "Basic pretests failed. Cannot test further.." T)
(RETURN NotSetValue))) (* Now test the object)
(SETQ TestExp (@ TestExpr))
[COND
((NULL TestExp)
(printout TTY 5 "No test is currently available for.." -3 (@ TestDesc)
T 5 "Indicate if this feature works OK?")
(SETQ Resp (READ))
(RETURN (COND
((FMEMB Resp (QUOTE (y t Y Yes T True YES TRUE)))
(←@
Tested? T))
((FMEMB Resp (QUOTE (n f N No F FALSE NO False nil NIL)))
(←@
Tested? NIL))
(T NotSetValue]
(SETQ Sval (ERRORSET (@ SetUp)
T))
(COND
((NULL Sval)
(printout TTY 5 "Error in setting up the test environment. Cannot test further.." T)
(RETURN NotSetValue)))
(SETQ Tval (ERRORSET (@ TestExpr)
T))
(COND
((OR (NULL Tval)
(NULL (CAR Tval)))
(printout TTY "Test failed for.." (@ TestDesc)
T 10 "Send bug report to LOOPSCORE↑.pa" T)
(←@
Tested? NIL))
(T (printout TTY "Test successful!! for.." (@ TestDesc)
T)
(←@
Tested? T)))
(RETURN (@ Tested?])
(LinkEditOtherMenu
[LAMBDA NIL (* sm: "29-MAR-83 16:08")
(* popup menu for other commands for editing Test Link
objects)
(MENU (create MENU
ITEMS ←(QUOTE (PP! (Edit (QUOTE Edit)
"edit using Lisp editor")
(EditIVs (QUOTE EditIV)
"edit IVs only using TTYEdit")
(EditCVs (QUOTE EditCV)
"edit CVs only using TTYEdit")
(Modify (QUOTE Modify)
"replace current values by new list")))
TITLE ← "Other Cmds"])
(LOOPSTestMeta.BeginLOOPSTest
[LAMBDA (self) (* sm: "20-SEP-83 16:31")
(* TESTS THE KERNEL FEATURES OF LOOPS)
(PROG (LTKInst LTKClass Temp) (* TEST: Create a new class)
(* Also test that Class is set properly)
(DC (QUOTE LTClass)
(QUOTE (Object)))
(COND
((EQ (SETQ LTKClass (GetClass ($ LTClass)))
($ Class)))
(T (printout TTY "Bug: Class of a newly created class not set properly" -5 LTKClass T)))
(* TEST: Create an instance of this)
(* Also test that Class is set properly)
(* Also tests message passing and Method Inheritance)
(SETQ LTKInst (← ($ LTClass)
New))
(COND
((EQ (SETQ LTKClass (Class LTKInst))
($ LTClass)))
(T (printout TTY "Bug: Class of an instance of LTKernel not set properly" -5 LTKClass T)))
(* TEST: Add CV and IVs to the class and Get from
Instance)
(* Tests inheritance of IV and CVs)
(← ($ LTClass)
Add
(QUOTE CV)
(QUOTE CVTest1)
(QUOTE CVal1))
(← ($ LTClass)
Add
(QUOTE IV)
(QUOTE IVTest1)
(QUOTE IVal1))
(← ($ LTClass)
Add
(QUOTE IV)
(QUOTE IVTest2)
(QUOTE IVal2))
(COND
[(EQUAL (GetClassValue ($ LTClass)
(QUOTE CVTest1))
(GetClassValue LTKInst (QUOTE CVTest1]
(T (printout TTY "Bug: CVs not being inherited properly" T)))
(COND
[(EQUAL (GetValue ($ LTClass)
(QUOTE IVTest1))
(GetValue LTKInst (QUOTE IVTest1]
(T (printout TTY "Bug: IVs not being inherited properly" T)))
(PutValue LTKInst (QUOTE IVTest2)
(QUOTE IVal3))
(COND
((EQUAL (GetValue ($ LTClass)
(QUOTE IVTest2))
(GetValue LTKInst (QUOTE IVTest2)))
(printout TTY "Bug: Inherited Values are overriding local values" T)))
(* TEST: Destroy the instance and its class)
(← LTKInst Destroy)
(← ($ LTClass)
Destroy)
[SETQ Temp (ERSETQ (GetClass ($ LTClass]
(COND
[(OR (NULL Temp)
(NULL (CAR Temp]
(T (printout TTY "Bug: Class Object not destroyed properly: GetClass returns non-NIL" T)))
(printout TTY "Kernel Test Completed." T
"Following features seem to be OK, unless indicated by an earlier message "
T "Creation of a new class" T "Instantiating a class using NEW message" T
"Setting of Class links"
T "Inheritance of methods" T "Inheritance of IVs and CVs" T
"Destruction of a class and its instance"
T "Following functions/methods partially tested" T "FUNCTIONS:" .PARA 15 -2
(QUOTE ("DC" "GetClass" "Class" "GetClassValue" "GetValue" "PutValue"))
T "METHODS:" .PARA 15 -2 (QUOTE ("New" "Add" "Destroy"))
T)
(RETURN T])
(LOOPSTestMeta.GetTestCode
[LAMBDA (self) (* sm: "21-OCT-82 14:07")
(* returns NIL, as no TestCode yet)
NIL])
(LOOPSTestMeta.New
[LAMBDA (self name) (* sm: " 6-OCT-82 13:36")
(* inherits its Super's New and then adds the instance's
name to filecoms and CV Instances)
(* if name is NIL, generate a name)
[COND
(name)
(T (SETQ name (PACK* (GetClassValue self (QUOTE InstancePrefix))
(←%@%@
UnnamedInstanceCount
(ADD1 (%@%@ UnnamedInstanceCount]
(←Super
self New name)
(PushClassValueNew self (QUOTE Instances)
name)
(EVAL (LIST (QUOTE PUSHNEW)
(GetClassValue self (QUOTE InstanceComsVar))
(KWOTE name)))
(GetObjectRec name])
(LOOPSTestKernel.TEST
[LAMBDA (self) (* sm: "20-SEP-83 16:31")
(* TESTS THE KERNEL FEATURES OF LOOPS)
(PROG (LTKInst LTKClass Temp) (* TEST: Create a new class)
(* Also test that Class is set properly)
(COND
((NOT (EQ (@ Tested?)
NotSetValue))
(printout TTY "Kernel Test was " (COND
((NULL (@ Tested?))
"Unsuccessful")
(T "Successful"))
T)
(RETURN (@ Tested?)))
(T (printout TTY "Begin test of Kernel features of LOOPS..." T)))
(DC (QUOTE LTClass)
(QUOTE (Object)))
(COND
((EQ (SETQ LTKClass (GetClass ($ LTClass)))
($ Class)))
(T (printout TTY "Bug: Class of a newly created class not set properly" LTKClass T)))
(* TEST: Create an instance of this)
(* Also test that Class is set properly)
(* Also tests message passing and Method Inheritance)
(SETQ LTKInst (← ($ LTClass)
New))
(COND
((EQ (SETQ LTKClass (Class LTKInst))
($ LTClass)))
(T (printout TTY "Bug: Class of an instance of LTClass not set properly" LTKClass T)))
(* TEST: Add CV and IVs to the class and Get from
Instance)
(* Tests inheritance of IV and CVs)
(← ($ LTClass)
Add
(QUOTE CV)
(QUOTE CVTest1)
(QUOTE CVal1))
(← ($ LTClass)
Add
(QUOTE IV)
(QUOTE IVTest1)
(QUOTE IVal1))
(← ($ LTClass)
Add
(QUOTE IV)
(QUOTE IVTest2)
(QUOTE IVal2))
(COND
[(EQUAL (GetClassValue ($ LTClass)
(QUOTE CVTest1))
(GetClassValue LTKInst (QUOTE CVTest1]
(T (←@
Tested? NIL)
(printout TTY " TestMsg: CVs not being inherited properly" T)))
(COND
[(EQUAL (GetValue ($ LTClass)
(QUOTE IVTest1))
(GetValue LTKInst (QUOTE IVTest1]
(T (←@
Tested? NIL)
(printout TTY "TestMsg: IVs not being inherited properly" T)))
(PutValue LTKInst (QUOTE IVTest2)
(QUOTE IVal3))
(COND
((EQUAL (GetValue ($ LTClass)
(QUOTE IVTest2))
(GetValue LTKInst (QUOTE IVTest2)))
(←@
Tested? NIL)
(printout TTY "TestMsg: Inherited Values are overriding local values" T)))
(* TEST: Destroy the instance and its class)
(← LTKInst Destroy)
(← ($ LTClass)
Destroy)
[SETQ Temp (ERSETQ (GetClass ($ LTClass]
(COND
[(OR (NULL Temp)
(NULL (CAR Temp]
(T (printout TTY "Class Object not destroyed properly: GetClass returns non-NIL" T)))
(COND
((NULL (@ Tested?)))
(T (←@
Tested? T)))
(printout TTY "Kernel features test " -2 (COND
((NULL (@ Tested?))
"failed.. Send bug report to LOOPSCORE↑.pa")
(T "Successfully!!"))
T)
(RETURN (@ Tested?])
(LOOPSClassSuper.Destroy
[LAMBDA (self) (* sm: " 5-OCT-82 14:30")
(* destroys an instance; updates Instancecoms var and CV
Instances)
(PROG (name)
(SETQ name (%@ name))
(←%@%@
Instances
(DREMOVE name (%@%@ Instances)))
[SET (%@%@ InstanceComsVar)
(DREMOVE name (EVAL (%@%@ InstanceComsVar]
(←Super
self Destroy)
(RETURN name])
(LOOPSClassSuper.GetTestCode
[LAMBDA (self) (* sm: "21-OCT-82 14:06")
(* returns NIL, as there is currently no Test Code here)
NIL])
(LOOPSTestObject.ReTest
[LAMBDA (self TestedLst) (* sm: "20-SEP-83 16:32")
(* sends a ResetSelf if needed followed by TEST)
(PROG (Res)
(COND
((@ self Tested? DoneOnce)
(← self ResetSelf)))
(SETQ Res (← self TEST TestedLst))
(COND
((EQ Res T)
(printout TTY "Test was successful!!" T)))
(RETURN Res])
(LOOPSTestObject.ReTestDep
[LAMBDA (self) (* sm: "30-NOV-82 12:55")
(* first sends ResetDep and then TESTDep to self)
(← self ResetDep)
(← self TESTDep])
(LOOPSTestObject.Reset
[LAMBDA (self AlreadyReset) (* sm: "25-NOV-82 15:58")
(* resets the Tested type values so prior test results
are wiped out. Also Resets PreTest and ClassPreTest)
(PROG (HELPFLAG)
[COND
((NULL AlreadyReset)
(SETQ AlreadyReset (CONS]
[COND
((NOT (FMEMB (%@ name)
(CAR AlreadyReset)))
(TCONC AlreadyReset (%@ name))
(← self ResetSelf AlreadyReset)
(for x in (%@ PreTest) do (SEND (GetObjectRec x)
Reset AlreadyReset))
(for x in (%@%@ ClassPreTest) do (SEND (GetObjectRec x)
Reset AlreadyReset]
(RETURN T])
(LOOPSTestObject.Reset!
[LAMBDA (self ResetLst) (* sm: "25-NOV-82 16:01")
(* resets itself by sending Reset to self and also
Reset! its SyntaxTest, AltTest and SubTest.
Also does a Reset on PreTest and ClassPreTest)
(* ResetLst is a list to which obj names are added as
they are reset. It is initially NIL)
(PROG (HELPFLAG) (* If ResetLst is NIL, create a pointer for it)
[COND
((NULL ResetLst)
(SETQ ResetLst (CONS]
[COND
((NOT (FMEMB (%@ name)
(CAR ResetLst)))
(TCONC ResetLst (%@ name))
(for x in (%@ AltTest) do (← (GetObjectRec x)
Reset! ResetLst))
(for x in (%@ SyntaxTest) do (← (GetObjectRec x)
Reset! ResetLst))
(for x in (%@ SubTest) do (← (GetObjectRec x)
Reset! ResetLst))
(← self ResetSelf ResetLst)
(for x in (%@ PreTest) do (← (GetObjectRec x)
Reset ResetLst))
(for x in (%@%@ ClassPreTest) do (← (GetObjectRec x)
Reset ResetLst]
(RETURN ResetLst])
(LOOPSTestObject.ResetAll
[LAMBDA (self ResetLst) (* sm: "29-NOV-82 15:16")
(* completely resets itself, all tests on which it
depends, and all which depend on it)
(* ResetLst is a list to which obj names are added as
they are reset. It is initially NIL)
(PROG (HELPFLAG) (* If ResetLst is NIL, create a pointer for it)
[COND
((NULL ResetLst)
(SETQ ResetLst (CONS]
[COND
((NOT (FMEMB (%@ name)
(CAR ResetLst)))
(TCONC ResetLst (%@ name))
(for x in (%@ AltTest) do (← (GetObjectRec x)
ResetAll ResetLst))
(for x in (%@ SyntaxTest) do (← (GetObjectRec x)
ResetAll ResetLst))
(for x in (%@ SubTest) do (← (GetObjectRec x)
ResetAll ResetLst))
(for x in (%@ PreTestOf) do (← (GetObjectRec x)
ResetAll ResetLst))
(← self ResetSelf ResetLst)
(for x in (%@ PreTest) do (← (GetObjectRec x)
ResetAll ResetLst))
(for x in (%@%@ ClassPreTest) do (← (GetObjectRec x)
ResetAll ResetLst]
(RETURN ResetLst])
(LOOPSTestObject.ResetDep
[LAMBDA (self ResetLst) (* sm: "29-NOV-82 15:08")
(* resets itself and all tests which depend on it)
(* resets itself by sending Reset to self and also
Reset! its SyntaxTest, AltTest and SubTest.
Also does a Reset on PreTestOf list)
(* ResetLst is a list to which obj names are added as
they are reset. It is initially NIL)
(PROG (HELPFLAG) (* If ResetLst is NIL, create a pointer for it)
[COND
((NULL ResetLst)
(SETQ ResetLst (CONS]
(COND
((NOT (FMEMB (%@ name)
(CAR ResetLst)))
(TCONC ResetLst (%@ name))
(for x in (%@ AltTest) do (← (GetObjectRec x)
ResetDep ResetLst))
(for x in (%@ SyntaxTest) do (← (GetObjectRec x)
ResetDep ResetLst))
(for x in (%@ SubTest) do (← (GetObjectRec x)
ResetDep ResetLst))
(for x in (%@ PreTestOf) do (← (GetObjectRec x)
ResetDep ResetLst))
(← self ResetSelf ResetLst)))
(RETURN ResetLst])
(LOOPSTestObject.ResetSelf
[LAMBDA (self AlreadyReset) (* sm: "20-SEP-83 16:32")
(* resets the Tested type values so prior test results
are wiped out.)
(PROG NIL
(COND
((ValueNonNIL? (@ self Tested? DoneOnce))
(printout TTY "RESETting.." -4 (@ name)
T)
(for x in (@@ ResetList) do (SELECTQ (CAR x)
[IV (for y in (CDR x)
do (COND
((ATOM y)
(PutValue self y NotSetValue))
(T (PutValue self (CAR y)
NotSetValue
(CADR y]
[CV (for y in (CDR x)
do (COND
((ATOM y)
(PutClassValue self y NotSetValue))
(T (PutClassValue self (CAR y)
NotSetValue
(CADR y]
(printout TTY "Illegal ResetList.." T x T ".. for"
-4 (@ name)
T)))
(ERRORSET (@ ResetExp)
T))
(T (printout TTY (@ name)
" is already Reset" T)
(RETURN NIL)))
(RETURN T])
(MakeBackLink
[LAMBDA (self varName newValue propName activeVal type) (* sm: "20-SEP-83 16:32")
(* This is a putFn for maintaining bi-links between TestCases and TestObject instances but could be used generally
too. Uses BackLink prop to find name of back link. Should NOT be invoked with other than PutValue.)
(* SPL CASES: (a) if newValue is of the form
(- v1 ..vn), then removes v1 to vn)
(* (b) if newValue is of the form
(v1 ..vn), then adds only those vi which are already not
there)
(PROG [(blink (GetValue self varName (QUOTE BackLink] (* if newValue is atom, make it a list)
[COND
((ATOM newValue)
(SETQ newValue (CONS newValue]
[COND
[(EQ (CAR newValue)
(QUOTE -))
(for x in (CDR newValue)
do (COND
[(FMEMB blink (SEND (GetObjectRec x)
List!(QUOTE IVs)))
(COND
((FMEMB x (GetLocalState activeVal self varName propName))
(PutLocalState activeVal (DREMOVE x (GetLocalState activeVal self varName
propName))
self varName propName type)
(PutValue (GetObjectRec x)
blink
(LIST (QUOTE -)
(@ name)))
(MARKASCHANGED (GetObjectName self)
(QUOTE INSTANCES))
(MARKASCHANGED x (QUOTE INSTANCES]
(T (printout TTY blink -2 "Not valid link for " x -2 "Ignoring.." T]
(T (for x in newValue do (COND
[(FMEMB blink (SEND (GetObjectRec x)
List!(QUOTE IVs)))
(COND
((NOT (FMEMB x (GetLocalState activeVal self varName
propName)))
(PutLocalState activeVal
(CONS x (GetLocalState activeVal self
varName propName))
self varName propName type)
(PutValue (GetObjectRec x)
blink
(@ name))
(MARKASCHANGED (GetObjectName self)
(QUOTE INSTANCES))
(MARKASCHANGED x (QUOTE INSTANCES]
(T (printout TTY blink -2 "Not valid link for " x -2
"Ignoring.."
T]
(RETURN (GetLocalState activeVal self varName propName])
(MakeSet
[LAMBDA (lis) (* sm: "26-OCT-82 13:35")
(* from a list removes duplicates from the back, and
changes the list)
(* RETURNs THE MODIFIED LIST)
(PROG ((Ptr lis))
LOOP(COND
((NULL Ptr)
(RETURN lis)))
[COND
((FMEMB (CAR Ptr)
(CDR Ptr))
(RPLACD Ptr (DREMOVE (CAR Ptr)
(CDR Ptr]
(SETQ Ptr (CDR Ptr))
(GO LOOP])
(ObjectName
[LAMBDA (x) (* sm: "21-OCT-82 13:42")
(* returns the name of x, where x may be an object or
object name)
(PROG (obj)
(SETQ obj (GetObjectRec x))
(RETURN (COND
((type? instance obj)
(GetValue obj (QUOTE name)))
(T (ClassName obj])
(PerformAltTest
[LAMBDA (self type default TestedLst) (* sm: "20-SEP-83 16:32")
(* tries AltTest if any. otherwise returns default)
(PROG (lis)
(SETQ lis (GetValue self (QUOTE AltTest)))
(COND
((AND (NULL lis)
(NOT (AddAltTest self)))
(printout TTY " Not continuing with test.." T)
(RETURN default)))
[COND
((NOT (EQ (GetValue self (QUOTE AltTest)
(QUOTE Tested?))
T))
(for x in lis do (SEND (GetObjectRec x)
TEST TestedLst))
(PutValue self (QUOTE AltTest)
T
(QUOTE Tested?]
(RETURN (ExaminePreviousTry self])
(PerformSetup
[LAMBDA (self) (* sm: "20-SEP-83 16:33")
(* executes the SetUp of a testobj)
(PROG (Sval Exp Res FMSG)
(COND
([ValueExists? (SETQ Res (GetValue self (QUOTE SetUp)
(QUOTE Tested?]
[COND
((NULL Res)
(printout TTY 5 "Error in setting up the test environment." T)
(PrintFailedExp self (GetValue self (QUOTE SetUp)
(QUOTE FailedExp]
(RETURN Res)))
(SETQ Exp (@ SetUp))
[COND
((NULL Exp)
(PrintIfLev LTMsgLev 2 (printout TTY "Sysnote: No SetUp expression for" -3
(@ name)
T]
(SETQ Sval (EvaluateTest self (QUOTE SetUp)
NIL))
(PutValue self (QUOTE SetUp)
(SETQ Res (COND
((NULL Sval)
NIL)
(T T)))
(QUOTE Tested?))
[COND
((NULL Res)
(ERRORSET (@ AfterTest)
T)
(printout TTY 5 "Error in setting up the test environment." T)
(COND
(FMSG (printout TTY "[Error in the following:" T)
(PutValue self (QUOTE SetUp)
FMSG
(QUOTE FailedExp))
(PrintFailedExp self FMSG]
(RETURN Res])
(PerformTest
[LAMBDA (self) (* sm: "20-SEP-83 16:33")
(* actually tests the TestExpr of self)
(PROG (Tval FMSG) (* Globals: FMSG -
list of pairs for failed tests -
(Msgstring.Testexp))
(SETQ Tval (EvaluateTest self (QUOTE TestExpr)
T))
(COND
((OR (NULL Tval)
(NULL (CAR Tval)))
(printout TTY "Test failed for.." (@ TestDesc)
T 10 "Send bug report to LOOPSCORE↑.pa" T)
(COND
(FMSG (printout TTY "[Following subtests failed: " T)
(PutValue self (QUOTE TestExpr)
FMSG
(QUOTE FailedExp))
(PrintFailedExp self FMSG)))
(←@
Tested?
(TestErrorBreak self)))
(T (PrintIfLev LTMsgLev 7 (printout TTY "Test successful!! for.." (@ TestDesc)
T))
(←@
Tested? T)))
(RETURN (@ Tested?])
(PreTestsSatisfied?
[LAMBDA (self TestedLst) (* sm: "20-SEP-83 16:33")
(* checks the PreTests of a test and returns T, NIL or
NotSetValue)
(PROG NIL
[COND
((NOT (EQ (CheckClassTest self TestedLst)
T))
(PrintTestHeader self)
(printout TTY 5 "Following PreTest for this class failed:" -4 (@@ self ClassPreTest
Failed)
T)
(RETURN (PerformAltTest self (QUOTE ClassPreTest)
NotSetValue TestedLst]
(* The class PreTest were successful so continue...)
[COND
((NOT (ValueNonNIL? (DoLoopsTest self (QUOTE PreTest)
(QUOTE TEST)
NIL TestedLst)))
(PrintTestHeader self)
(printout TTY 5 "Following pretests failed:" -4 (@ self PreTest Failed)
T)
(RETURN (PerformAltTest self (QUOTE PreTest)
NotSetValue TestedLst]
(* PreTests were successful)
(RETURN T])
(PrintFailedExp
[LAMBDA (self FailedExp) (* sm: "20-SEP-83 16:34")
(* prints the FailedExp of the type returned by
EvaluateTest)
[for x in FailedExp do (PROGN (printout TTY 1 "Comment:" 12 (CAR x))
(PrintIfLev LTELev 9 (printout TTY 1 "Code" 12 .PPF (CADR x)))
(PrintIfLev LTELev 8 (printout TTY 1 "Returned:" 12 (CADDR x]
(printout TTY "]" T)
FailedExp])
(PrintTestCode
[LAMBDA (self) (* sm: "20-SEP-83 16:34")
(* prints the Test Code fields, if type is TestObj else
nothing)
(PROG (TC)
(SETQ TC (← self GetTestCode))
[COND
(TC (printout TTY "Test Code for" -4 (ObjectName self)
T)
(for x in TC do (printout TTY .PPFTL x T]
(RETURN TC])
(PrintTestHeader
[LAMBDA (self Msg) (* sm: "20-SEP-83 16:34")
(* prints TestDesc header if global HeaderFlag is T.
Also sets the flag to NIL)
(* Msg is optional and "TESTING.."
by default)
(COND
(HeaderFlag (printout TTY (COND
((NULL Msg)
"TESTING..")
(T Msg))
-4
(@ TestDesc)
T)
(SETQ HeaderFlag NIL)
T)
(T NIL])
(PushClassValueNew
[LAMBDA (self var val prop) (* sm: " 5-OCT-82 12:29")
(* does PushClassValue only if val is already not on the
value list)
(COND
((FMEMB val (GetClassValue self var prop)))
(T (PushClassValue self var val prop)))
val])
(PutInActVal
[LAMBDA (self varName newValue propName activeVal type) (* sm: "25-OCT-82 15:24")
(* This is a putFn for testing active values)
(* it just puts the value in)
(PutLocalState activeVal newValue self varName propName type])
(ReadLinkMenu
[LAMBDA (self link default AllOpt) (* sm: "21-OCT-82 14:21")
(* asks the user to select one of the values of (self link). Returns the selected value or NIL.
If default is T, then if only one value is there, returns that as the selection, WITHOUT asking asking the user)
(* If AllOpt is T, then gives an ALL option, and returns
a list of selected names, even if all was not chosen)
(PROG ((vals (GetValue self link))
Sel)
(RETURN (COND
((NULL vals)
NIL)
[(AND (EQ (LENGTH vals)
1)
default)
(COND
(AllOpt vals)
(T (CAR vals]
(T (SETQ Sel (MENU (create MENU
ITEMS ←(COND
(AllOpt (CONS (QUOTE ALL)
vals))
(T vals))
TITLE ← "Current Values")))
(COND
((EQ Sel (QUOTE ALL))
vals)
((NULL Sel)
NIL)
(AllOpt (CONS Sel))
(T Sel])
(ReasonNotDone
[LAMBDA (self) (* sm: "29-OCT-82 17:02")
(* given a TestObj, tries to generate a reason why test
was not performed)
(SETQ self (GetObjectRec self))
(COND
((NULL (%@%@ ClassTested?))
"ClassPreTest failed")
((NULL (%@ self PreTest Tested?))
"PreTests failed")
((NULL (%@ self SetUp Tested?))
"SetUp caused error")
(T "Not tried or pretests were indeterminate"])
(RemoveValue
[LAMBDA (self var val prop) (* sm: "11-OCT-82 17:52")
(* removes a value from var. will work only with var
having the active value putFns MakeBackLink or
AllowRemove)
(PutValue self var (CONS (QUOTE -)
(MKLIST val))
prop])
(ResetLTKERCLASSES
[LAMBDA NIL (* sm: "30-MAR-83 11:18")
(PutClassValue (%$ LOOPSTestMethod)
(QUOTE ClassTested?)
(QUOTE U))
(PutClassValue (%$ LOOPSTestEnvironment)
(QUOTE ClassTested?)
(QUOTE U])
(ResetLTKERVARS
[LAMBDA NIL (* sm: "11-AUG-83 13:25")
[SETQ Failed (SETQ NotDone (SETQ HasTest (SETQ Tested NIL]
(SETQ EditTestWindows NIL)
(SETQ LTAskNoTestAvailable NIL)
(SETQ LTMsgLev (SETQ LTELev 8))
(SETQ KBTestsFlg T])
(ResetPutLocalStateVars
[LAMBDA NIL (* sm: "29-NOV-82 18:07")
(* recreates the active values in LOOPSTestClass6 used
by LTFPutLocalState)
(PutValueOnly (%$ LOOPSTestClass6)
(QUOTE PLS1)
(create activeValue
localState ←(QUOTE LTC6)
getFn ← NIL
putFn ← NIL))
(PutValueOnly (%$ LOOPSTestClass6)
(QUOTE PLS3)
(create activeValue
localState ←(create activeValue
localState ←(QUOTE LTC6)
getFn ←(QUOTE GetFromActVal)
putFn ←(QUOTE PutInActVal))
getFn ←(QUOTE GetFromActVal)
putFn ←(QUOTE PutInActVal])
(RunTest
[LAMBDA (Seed) (* sm: "16-NOV-82 13:43")
(* Runs test starting with objects in Seed)
(PROG ((Tlis (CONS NIL))
Next Ptr Y (Tested (CONS NIL)))
(LCONC Tlis (APPEND Seed))
(SETQ Ptr (CAR Tlis))
LOOP[COND
((NULL Ptr)
(RETURN (CAR Tested]
(SETQ Next (GetObjectRec (CAR Ptr)))
(for x in (GetValue Next (QUOTE SubTest)) eachtime (SETQ Y (GetObjectRec x))
when (NOT (FMEMB Y (CAR Tlis))) do (TCONC Tlis Y))
(for x in (GetValue Next (QUOTE PreTestOf)) eachtime (SETQ Y (GetObjectRec x))
when (NOT (FMEMB Y (CAR Tlis))) do (TCONC Tlis Y))
(SETQ Ptr (CDR Ptr))
[COND
((NOT (FMEMB Next (CAR Tested)))
(TCONC Tested Next)
(ERSETQ (SEND Next TEST Tested]
(GO LOOP])
(SetupEditTestObjMenu
[LAMBDA NIL (* sm: "29-MAR-83 16:10")
(* Sets up the menus for editing TestObjs)
(* returns the list of windows created)
(LIST (TMenu (QUOTE ((PreTest (QUOTE PT)
"manipulate PreTest list" "
")
(SubTest (QUOTE SUB)
"manipulate SubTest list" "
")
(PreTestOf (QUOTE PTO)
"manipulate PreTestOf list" "
")
(UsesObj (QUOTE UO)
"manipulate UsesObj list" "
")
(CasesUsed (QUOTE CU)
"manipulate CasesUsed list" "
")
(SyntaxTest (QUOTE ST)
"manipulate SyntaxTest list" "
")
(AltTest (QUOTE AT)
"manipulate Alternate Test list" "
")
(OtherLinks (EditOtherLinksMenu)
"allows selection of less often used links" "
")))
"Test Links"
(QUOTE (645 20 150 150)))
(TMenu (QUOTE ((Dedit (QUOTE DEDIT)
"Edit using Dedit" "
")
(PP (QUOTE PP)
"prettyprint this object" "
")
(Quit (QUOTE QUIT)
"Quit this editing session" "
")
(Eval (QUOTE EVAL)
"enter the USEREXEC" "
")
(Test (QUOTE TEST)
"test the current object" "
")
(ReTest (QUOTE RETEST)
"retest the object, resetting it if needed" "
")
(WhoAmI (QUOTE WHO)
"tells you which object is being edited" "
")
(Describe (QUOTE DESCRIBE)
"describes the test object and state of any tests that were run"
"
")
(Top (QUOTE TOP)
"go back to the very first object in this session" "
")
(Unremember (QUOTE UNREMEMBER)
"select (and pop) the last remembered object and edit it next"
"
")
(Remember (QUOTE REMEMBER)
"save this object on the stack" "
")
(Select (QUOTE SELECT)
"asks for the next object to be edited (remembering current)" "
")
(Reset (QUOTE RESET)
"reset the test state of current object" "
")
(Execute (QUOTE EXEC)
"evaluate one of the selected Test fields" "
")
(TtyEdit (QUOTE VEDIT)
"Edit using TTYIN editor" "
")
(Others (EditTestOtherCmds)
"allows selection of less common commands" "
")))
"TestObj Edit Cmds"
(QUOTE (470 20 170 150)))
(TMenu (QUOTE ((Add NIL "enter the objects to be added" "
")
(Delete NIL "select the object to be deleted" "
")
(Select NIL "selected item will be edited next" "
")
(Quit NIL "quit editing this link" "
")
(PP NIL "prettyprints the selected item" "
")
(Dedit NIL "edits selected object using DEDIT" "
")
(Desc NIL "describe the link values" "
")
(List NIL "displays the current list" "
")
(AddNum NIL "enter a number for new objects to be created" "
")
(DefAdd NIL "add a new object to be defined by name" "
")
(TtyEdit (QUOTE VEDIT)
"edits selected object using screen editor" "
")
(Others (LinkEditOtherMenu)
"other commands" "
")))
"Link Edit Cmds"
(QUOTE (800 20 120 150])
(TestErrorBreak
[LAMBDA (self) (* sm: "27-OCT-82 16:46")
(* come here when TestExpr has error/NIL.
should return value that Tested? will be set to)
NIL])
(TestObjectDesc
[LAMBDA (self) (* sm: "21-OCT-82 13:53")
(* returns the value of TestDesc IV if self has it, else
"")
(COND
((SEND self HasIV (QUOTE TestDesc))
(%@ TestDesc))
(T ""])
(TickleBrowserNodes
[LAMBDA (Objs Browser) (* sm: "15-NOV-82 10:26")
(* given Browser with initial objects "Objs" Flips or
Flashes these and other objects reachable via the link
(s) given in the browser)
(PROG [(Done (CONS))
(Nodes (CONS))
Ptr Next (Links (MKLIST (GetValue Browser (QUOTE subLinks]
(LCONC Nodes (APPEND Objs))
(SETQ Ptr (CAR Nodes))
LOOP(SETQ Next (GetObjectRec (CAR Ptr)))
(COND
((MEMBER Next (CAR Done))
(GO LOOP2)))
[COND
((EQ (GetValue Next (QUOTE Tested?))
T)
(ERSETQ (← Browser FlipNode Next)))
((OR (EQ (GetValue Next (QUOTE Tested?))
NIL)
(EQ (GetValue Next (QUOTE SetUp)
(QUOTE Tested?))
NIL))
(ERSETQ (← Browser FlashNode Next 5]
[for x in Links do (LCONC Nodes (APPEND (GetValue Next x]
(TCONC Done Next)
LOOP2
(SETQ Ptr (CDR Ptr))
[COND
((NULL Ptr)
(RETURN (CAR Done]
(GO LOOP])
)
(RPAQQ LTKERINSTANCES NIL)
(RPAQQ LTKERMACROS (NotSetValue? PrintIfLev UnknownValue? ValueExists? ValueNonNIL?))
(DECLARE: EVAL@COMPILE
(PUTPROPS NotSetValue? MACRO [LAMBDA (val)
(EQ val NotSetValue])
(PUTPROPS PrintIfLev MACRO [NLAMBDA (CLEV LEV EXP) (* executes EXP if LEV>=CLEV)
(COND
((GEQ (EVAL LEV)
(EVAL CLEV))
(EVAL EXP])
(PUTPROPS UnknownValue? MACRO [LAMBDA (val)
(OR (EQ val NotSetValue)
(EQ val (QUOTE U])
(PUTPROPS ValueExists? MACRO [LAMBDA (val) (* Returns T iff val is not eq NotSetValue)
(AND (NOT (EQ val NotSetValue))
(NOT (EQ val (QUOTE U])
(PUTPROPS ValueNonNIL? MACRO [LAMBDA (val) (* Returns T iff val is NOT NIL and NOT EQ NotSetValue)
(AND val (NOT (EQ val (QUOTE U)))
(NOT (EQ val NotSetValue])
)
(RPAQQ LTKERVARS (AllTest CMN DUP EditTestWindows Failed HasTest KBTestsFlg LTAskNoTestAvailable
LTELev LTMsgLev NotDone OMN Seed Tested))
(RPAQQ AllTest (LTTemplate LTDumpInstance LTLoadInstance LTMethod LTObject LTActiveValue LTKernel
LTFSendSuper LTFGetInitialValue LTFPutNthValue LTFGetNthValue
LTFGetObjectNames LTFtype? LTFClass LTFGetObjectRec LTFReplaceActiveValue
LTFPutLocalState LTFGetLocalState LTFRenameMethodFunction LTFMoveMethod
LTFMoveVariable LTFMoveClassVariable LTFRenameVariable LTFCalledFns
LTFRenameMethod LTFTryMethod LTFDoMethod LTFPutItOnly LTFGetItOnly
LTFPutIt LTFGetIt LTFPutMethodOnly LTFGetMethodOnly LTFPutMethod
LTFGetMethod LTFPutClassOnly LTFGetClassOnly LTFPutClass LTFGetClass
LTFPutClassValueOnly LTFPutValueOnly LTFPushClassValue LTFPutClassValue
LTFAddValue LTFPushValue LTFGetClassValueOnly LTFGetValueOnly
LTFGetClassValue LTFDM LTFDC LTFPutValue LTFGetValue LTFSend
LTMTitleCommandInObj LTMSetNameInObj LTMRenameInObj LTMPutInObj
LTMPPV!InObj LTMPP!InObj LTMPPInObj LTMList!InObj LTMListInObj
LTMInspectValueCommandInObj LTMInspectTitleMenuInObj LTMInspectTitleInObj
LTMInspectStoreInObj LTMInspectPropertiesInObj LTMInspectPropCommandInObj
LTMInspectFetchInObj LTMHasIVInObj LTMEditInObj LTMDumpFactsInObj
LTMDestroy!InObj LTMDestroyInObj LTMTitleCommandInClass LTMSetNameInClass
LTMRenameInClass LTMPutInClass LTMPPV!InClass LTMPP!InClass LTMPPInClass
LTMList!InClass LTMInspectValueCommandInClass LTMInspectTitleMenuInClass
LTMInspectTitleInClass LTMInspectStoreInClass LTMInspectPropertiesInClass
LTMInspectPropCommandInClass LTMInspectFetchInClass LTMHasIVInClass
LTMEditInClass LTMDumpFactsInClass LTMDestroy!InClass LTMDestroyInClass
LTMWhereIs LTMUnderstands LTMUnSetName LTMTraceIt LTMReturnDefaultValue
LTMPutIVProp LTMPrintOn LTMNoObjectForMsg LTMMessageNotUnderstood
LTMInstantiate LTMInstOf! LTMInstOf LTMInspect LTMIVMissing LTMDoMethod
LTMDeleteIV LTMCopyShallow LTMCopyDeep LTMClassName LTMClass LTMBreakIt
LTMAt LTMAssocKB LTMAddIV LTMSubClasses LTMReplaceSupers LTMPPMethod
LTMPPM LTMOnFile LTMNewWithValues LTMNewTemp LTMNew LTMMoveMethod
LTMMethodDoc LTMInitialize LTMHasCV LTMFetchMethod LTMEditMethod
LTMDisplaySubClasses LTMDefMethod LTMCopyMethod LTMCommentMethods
LTMDeleteInClass LTMAdd LTMListInClass LTEMapObjectNames LTECancel
LTEMakeCurrent LTEThawKB LTEFreezeKB LTEAssocKB LTEDumpToKB LTESummarize
LTEDelete LTECommunity LTEOld LTENew))
(RPAQQ CMN (Add CommentMethods CopyMethod DefMethod DisplaySubClasses EditMethod FetchMethod HasCV
Initialize MethodDoc MoveMethod New NewTemp NewWithValues OnFile PPM PPMethod
ReplaceSupers SubClasses))
(RPAQQ DUP (Destroy Destroy! DumpFacts Edit HasIV InspectFetch InspectPropCommand InspectProperties
InspectStore InspectTitle InspectTitleMenu InspectValueCommand List List! PP PP!
PPV! Put Rename SetName TitleCommand))
(RPAQQ EditTestWindows NIL)
(RPAQQ Failed NIL)
(RPAQQ HasTest NIL)
(RPAQQ KBTestsFlg T)
(RPAQQ LTAskNoTestAvailable NIL)
(RPAQQ LTELev 8)
(RPAQQ LTMsgLev 8)
(RPAQQ NotDone NIL)
(RPAQQ OMN (AddIV AssocKB At BreakIt Class ClassName CopyDeep CopyShallow DeleteIV DoMethod IVMissing
Inspect InstOf InstOf! Instantiate MessageNotUnderstood NoObjectForMsg PrintOn
PutIVProp ReturnDefaultValue TraceIt UnSetName Understands WhereIs))
(RPAQQ Seed (#&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())")
#&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())")
#&(LOOPSTestLispFunc "#(())")
#&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())")
#&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())")
#&(LOOPSTestLispFunc "#(())")
#&(LOOPSTestLispFunc "#(())") #&(LOOPSTestLispFunc "#(())")
))
(RPAQQ Tested NIL)
(ResetLTKERCLASSES)
(DECLARE: DONTCOPY
(FILEMAP (NIL (21531 111571 (ATEST 21541 . 21652) (AddAltTest 21654 . 22072) (AllowRemove 22074 .
22743) (AskPreTest 22745 . 24311) (AskSubTest 24313 . 26189) (AskSyntaxTest 26191 . 28127) (
AskTestCases 28129 . 29565) (BeginLoopsTest 29567 . 31743) (BuildPreTest 31745 . 32443) (
BuildPrimClassTest 32445 . 33101) (CheckClassTest 33103 . 34341) (CheckPreTest 34343 . 35412) (
CloseCurrentEnvironment 35414 . 35594) (CreateLTKBS1 35596 . 38351) (DescribePreviousTry 38353 . 39594
) (DescribeTestLink 39596 . 41409) (DisplayTestBrowser 41411 . 42762) (DoLoopsTest 42764 . 44387) (
DoTestSelf 44389 . 45870) (EQACTVAL 45872 . 46437) (EditOtherLinksMenu 46439 . 46866) (EditPreTest
46868 . 50794) (EditTestOtherCmds 50796 . 51665) (EvaluateANDALLTest 51667 . 52883) (EvaluateANDTest
52885 . 53881) (EvaluatePROGTest 53883 . 54867) (EvaluateTest 54869 . 56497) (ExaminePreviousTry 56499
. 57196) (ExecTestFields 57198 . 57849) (FindObjForLink 57851 . 58443) (FlashTestBrowser 58445 .
58937) (GIVGetFn 58939 . 59237) (GenerateTestList 59239 . 60582) (GetFromActVal 60584 . 61015) (
InformTestBrowser 61017 . 61767) (LOOPSTestEnvironment.TEST 61769 . 62215) (LOOPSTestObject.DefineTEST
62217 . 63137) (LOOPSTestObject.Describe 63139 . 63626) (LOOPSTestObject.EditTEST 63628 . 66880) (
LOOPSTestObject.EditTestInTTYProcess 66882 . 67197) (LOOPSTestObject.GetTestCode 67199 . 67523) (
LOOPSTestObject.TEST 67525 . 68901) (LOOPSTestObject.TEST! 68903 . 71273) (LOOPSTestObject.TESTDep
71275 . 72067) (LOOPSTestObject.TESTall 72069 . 72782) (LOOPSTestObject.TestSelf 72784 . 74286) (
LOOPSTestPrimitive.XTEST 74288 . 76444) (LinkEditOtherMenu 76446 . 77067) (
LOOPSTestMeta.BeginLOOPSTest 77069 . 80469) (LOOPSTestMeta.GetTestCode 80471 . 80703) (
LOOPSTestMeta.New 80705 . 81489) (LOOPSTestKernel.TEST 81491 . 84921) (LOOPSClassSuper.Destroy 84923
. 85461) (LOOPSClassSuper.GetTestCode 85463 . 85718) (LOOPSTestObject.ReTest 85720 . 86200) (
LOOPSTestObject.ReTestDep 86202 . 86482) (LOOPSTestObject.Reset 86484 . 87261) (LOOPSTestObject.Reset!
87263 . 88602) (LOOPSTestObject.ResetAll 88604 . 89984) (LOOPSTestObject.ResetDep 89986 . 91352) (
LOOPSTestObject.ResetSelf 91354 . 92507) (MakeBackLink 92509 . 94833) (MakeSet 94835 . 95426) (
ObjectName 95428 . 95856) (PerformAltTest 95858 . 96600) (PerformSetup 96602 . 97870) (PerformTest
97872 . 98885) (PreTestsSatisfied? 98887 . 100067) (PrintFailedExp 100069 . 100602) (PrintTestCode
100604 . 101091) (PrintTestHeader 101093 . 101689) (PushClassValueNew 101691 . 102070) (PutInActVal
102072 . 102452) (ReadLinkMenu 102454 . 103489) (ReasonNotDone 103491 . 104036) (RemoveValue 104038 .
104432) (ResetLTKERCLASSES 104434 . 104716) (ResetLTKERVARS 104718 . 105019) (ResetPutLocalStateVars
105021 . 105754) (RunTest 105756 . 106712) (SetupEditTestObjMenu 106714 . 109781) (TestErrorBreak
109783 . 110075) (TestObjectDesc 110077 . 110411) (TickleBrowserNodes 110413 . 111569)))))
STOP