(FILECREATED "21-Feb-84 17:55:04" {INDIGO}<LOOPS>SOURCES>LOOPSRULESD.;7 31856
changes to: (FNS GetRSAllDeclString GetRuleSetDeclarations GetWhileCondition GetRSDeclString
GetOneShotFlg GetProgVars SpaceOrItem)
previous date: "17-Feb-84 18:19:59" {INDIGO}<LOOPS>SOURCES>LOOPSRULESD.;5)
(PRETTYCOMPRINT LOOPSRULESDCOMS)
(RPAQQ LOOPSRULESDCOMS ((* Copyright (c)
1982 by Xerox Corporation)
(* Written in August 1982 by Mark Stefik, Alan Bell, and Danny Bobrow)
(* Fns for getting declarations in LOOPS RuleSets.)
(FNS * RULEDECLFNS)))
(* Copyright (c) 1982 by Xerox Corporation)
(* Written in August 1982 by Mark Stefik, Alan Bell, and Danny Bobrow)
(* Fns for getting declarations in LOOPS RuleSets.)
(RPAQQ RULEDECLFNS (AssocAuditSpecification FlushComment? GetAuditClass GetCompilerOptions
GetControlType GetDebugVars GetMetaAssns GetOneShotFlg
GetProgVars GetRSAllDeclString GetRSDeclString
GetRuleClass GetRuleMetaDecls GetRuleSetArgs
GetRuleSetDeclarations GetRuleSetTemplate GetTaskVars
GetTempVars GetWhileCondition GetWorkSpaceClass
InterpretCompilerOptions SpaceOrItem))
(DEFINEQ
(AssocAuditSpecification
[LAMBDA (auditSpec) (* mjs: "11-FEB-83 17:58")
(* * Converts an Audit specification into an association list of the form -
((varName1 . valueExpr1) (varName2 . valueExpr2)) -
where each valueExpr is an expression to be compiled later by AuditRecordCodeGen.)
(PROG (assocList varName varExpr)
(* * Collect the association list.)
(while [AND auditSpec (NOT (EQ rpar (CAR auditSpec]
do (COND
((AND (SETQ varName (pop auditSpec))
(LITATOM (CAR auditSpec))) (* Check the varName.)
T)
(T (FlushRule "Strange variable name: " varName " in meta-Assignment Statement.")
(GO Done)))
(COND
((EQ (CAR auditSpec)
leftArrow) (* Check for ←)
(pop auditSpec))
(T (FlushRule "Missing" "←" "in Audit Specification")
(GO Done)))
(SETQ varExpr (pop auditSpec)) (* Add to the Assoc list.)
(SETQ assocList (CONS (CONS varName varExpr)
assocList)))
Done(RETURN assocList])
(FlushComment?
[LAMBDA (noCheckFlg) (* mjs: "16-FEB-83 15:52")
(* * Removes comments during RuleSet compilation.)
(PROG (token doneFlg)
(while (OR noCheckFlg (AND (EQ (CAR ruleSetTokens)
lpar)
(EQ (CADR ruleSetTokens)
asterisk)))
do (* pop first left paren.)
(SETQ noCheckFlg NIL)
(pop ruleSetTokens)
[repeatuntil doneFlg
do (SETQ token (pop ruleSetTokens))
(COND
((NULL token)
(SETQ doneFlg T))
((EQ token lpar) (* Recur for embedded parens.)
(FlushComment? (QUOTE NoCheckFlg)))
((EQ token rpar)
(SETQ doneFlg T]
(SETQ doneFlg NIL))
(RETURN NIL])
(GetAuditClass
[LAMBDA (self) (* mjs: "12-FEB-83 17:51")
(* * Parses the Audit Class declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (auditClassName)
(* * Flush any leading comments and verify statement type.)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE Audit))
(NEQ (CADR ruleSetTokens)
(QUOTE Class)))
(FlushRule "Bad Audit Class Statement.")
(GO done)))
(* * Pop the Audit, Class, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Get the Class.)
[SETQ auditClassName (COND
((NEQ (CAR ruleSetTokens)
semicolon)
(pop ruleSetTokens]
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ rsAuditClass (GetClassRec auditClassName))
(COND
((AND auditClassName (NULL rsAuditClass))
(FlushRule "Audit Class not recognized: " auditClassName)))
(COND
(rsAuditClass (SETQ auditSpecification (%@%@ rsAuditClass metaAssns])
(GetCompilerOptions
[LAMBDA NIL (* dgb: "17-Feb-84 14:02")
(* * Parses the Compiler Options declaration at the beginning of a RuleSet. Argument self is the RuleSet.
Skip if ↑userCompilerOptions is set.)
(PROG [options (possibleOptions (CONSTANT (QUOTE (T B A S BT TT PR LC]
(* * Verify statement type.)
(COND
((NEQ (CAR ruleSetTokens)
(QUOTE Compiler))
(FlushRule "No Compiler Options Statement.")
(RETURN)))
(* * Pop the Compiler, Options, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Collect, uppercase, and check the options.)
[SETQ options (while (NEQ (CAR ruleSetTokens)
semicolon)
collect (U-CASE (pop ruleSetTokens]
(COND
([SETQ parseErrorFlg (for option in options thereis (NOT (FMEMB option possibleOptions]
(FlushRule "Unrecognized compiler option=" parseErrorFlg)))
(* * pop the semicolon.)
(pop ruleSetTokens)
(InterpretCompilerOptions options])
(GetControlType
[LAMBDA NIL (* dgb: "17-Feb-84 18:03")
(* * Parses the Control Structure declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG [type (controlTypes (CONSTANT (LIST (QUOTE DO1)
(QUOTE DOALL)
(QUOTE WHILE1)
(QUOTE WHILEALL)
(QUOTE FOR1)
(QUOTE FORALL)
(QUOTE DONEXT)
(QUOTE WHILENEXT]
(* * Flush any leading comments and verify statement type.)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE Control))
(NEQ (CADR ruleSetTokens)
(QUOTE Structure)))
(FlushRule "No Control Structure Statement. --- Assuming DOALL.")
(SETQQ type DOALL)
(GO done)))
(* * Pop the Control, Structure, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Get and Check the control type.)
(SETQ type (U-CASE (pop ruleSetTokens)))
[COND
((NOT (FMEMB type controlTypes))
(FlushRule "UnRecognized ControlType=" type)
(SETQ type (QUOTE DOALL]
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ controlType type])
(GetDebugVars
[LAMBDA NIL (* mjs: "12-FEB-83 15:59")
(* * Parses the Debug Vars declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (vars) (* Flush any leading comments.)
(FlushComment?)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE Debug))
(NEQ (CADR ruleSetTokens)
(QUOTE Vars)))
(FlushRule "Strange Debug Vars Statement.")
(GO done)))
(* * Pop the Debug, Vars, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Collect the Debug Vars.)
(SETQ vars (while (NEQ (CAR ruleSetTokens)
semicolon)
collect (pop ruleSetTokens)))
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ debugVars vars])
(GetMetaAssns
[LAMBDA NIL (* mjs: "12-FEB-83 17:18")
(* * Parses the Meta Assignments declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (auditTokens) (* Flush any leading comments.)
(FlushComment?)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE Meta))
(NEQ (CADR ruleSetTokens)
(QUOTE Assignments)))
(FlushRule "Strange Meta Assignments Statement.")
(GO done)))
(* * Pop the Meta, Assignments, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Collect the Audit Specification.)
(SETQ auditTokens (while (NEQ (CAR ruleSetTokens)
semicolon)
collect (pop ruleSetTokens)))
(* * pop the semicolon.)
(pop ruleSetTokens) (* Set the global variable.)
done(SETQ rsAuditSpecification auditTokens])
(GetOneShotFlg
[LAMBDA NIL (* dgb: "21-Feb-84 11:55")
(* Name and assign a TaskVar for one-shot rules in cyclic control structures. Sets global variable oneShotFlg to
the name of new Task variable. Variable is used in CompileLHS and CompileRHS and added to either the task Vars or
the rule Vars of the RuleSet. Subroutine of CompileRule.)
(PROG NIL
(COND
((FMEMB bang metaTokens) (* One shot Bang)
(SETQ oneShotBangFlg oneBang)
(SETQ metaTokens (DREMOVE bang metaTokens)))
(T (* One shot.)
(SETQ oneShotBangFlg NIL)))
(SETQ metaTokens (DREMOVE 1 metaTokens))
(COND
((AND (NULL rsTaskFlg)
(NOT (FMEMB controlType cyclicControlStructures)))
(* Ignore 1-shot indication if not cyclic and no
tasking.)
(SETQ oneShotFlg NIL)
(RETURN))) (* Compute the variable name for the rule.)
(SETQ oneShotFlg (PACK* (QUOTE ↑triedRule)
ruleNumber))
(COND
(rsTaskFlg (* If Tasking, Add to taskVars.)
(SETQ rsInternalTaskVars (NCONC1 rsInternalTaskVars oneShotFlg)))
(T (* otherwise add to tempVars.)
(SETQ rsInternalTempVars (NCONC1 rsInternalTempVars oneShotFlg])
(GetProgVars
[LAMBDA NIL (* dgb: "21-Feb-84 15:26")
(* * Subroutine of CompileRuleList. Returns the PROG vars associated with the template for a particular
controlType.)
(PROG (progVars allTemps)
(SETQ allTemps (APPEND tempVars rsInternalTempVars))
(SETQ progVars (SELECTQ controlType
((FOR1 FORALL DO1 DOALL)
(CONS (QUOTE ↑value)
allTemps))
(DONEXT (APPEND (QUOTE (↑value ruleApplied))
allTemps))
[WHILE1 (COND
(rsRuleAppliedFlg (APPEND (QUOTE (↑value ruleApplied))
allTemps))
(T (CONS (QUOTE ↑value)
allTemps]
[WHILEALL (COND
(rsRuleAppliedFlg (APPEND (QUOTE (↑value ↑prevValue
ruleApplied))
allTemps))
(T (CONS (QUOTE ↑value)
allTemps]
(WHILENEXT (APPEND (QUOTE (↑value ruleApplied ↑firstRuleTried))
allTemps))
NIL))
[COND
(rsSomeRuleAuditFlg (* Add a variable for the audit records if at least one
rule was audited.)
(SETQ progVars (CONS (QUOTE ↑auditRecord)
progVars]
(RETURN progVars])
(GetRSAllDeclString
[LAMBDA NIL (* dgb: "21-Feb-84 11:43")
(* * Returns a string representation of the declarations for the RuleSet currently being edited, that is, the one
for which the rule set global variables have been set. Should be called AFTER GetRuleSetDeclarations.)
(PROG (str (SCRLF (CONSTANT ";
")))
(SETQ str (CONCAT "WorkSpace Class: " (SpaceOrItem wsClass)
SCRLF "Compiler Options: " (SpaceOrItem rsCompilerOptions)
SCRLF "Args: " (SpaceOrItem rsArgs)
SCRLF "Temporary Vars: " (SpaceOrItem tempVars)
SCRLF "Control Structure: " (SpaceOrItem controlType)
SCRLF "Iteration Condition: " (SpaceOrItem (for term in rsWhileCondition
collect (UnParseTerm term)))
SCRLF "Audit Class: " (SpaceOrItem rsAuditClass)
SCRLF "Meta Assignments: " (SpaceOrItem rsAuditSpecification)
SCRLF "Rule Class: " (SpaceOrItem rsRuleClass)
SCRLF "Debug Vars: " (SpaceOrItem debugVars)
SCRLF "********"))
(RETURN str])
(GetRSDeclString
[LAMBDA (self) (* dgb: "21-Feb-84 11:43")
(* * Returns a string representation of the declarations for the RuleSet self.)
(PROG (str (SCRLF (CONSTANT ";
")))
(SETQ str (CONCAT "WorkSpace Class: " (SpaceOrItem (@ workSpace))
SCRLF "Compiler Options: " (SpaceOrItem (@ compilerOptions))
SCRLF "Temporary Vars: " (SpaceOrItem (@ tempVars))
SCRLF "Control Structure: " (@ controlStructure)
SCRLF))
[COND
((@ whileCondition)
(SETQ str (CONCAT str "Iteration Condition: " (SpaceOrItem (@ whileCondition))
SCRLF]
[COND
((@ args)
(SETQ str (CONCAT str "Args: " (SpaceOrItem (@ args))
SCRLF]
[COND
((AND (@ auditClass)
(NEQ (@ auditClass)
($ StandardAuditRecord)))
(SETQ str (CONCAT str "Audit Class: " (SpaceOrItem (@ auditClass))
SCRLF]
[COND
((@ metaAssignments)
(SETQ str (CONCAT str "Meta Assignments: " (SpaceOrItem (@ metaAssignments))
SCRLF]
[COND
((AND (@ ruleClass)
(NEQ (@ ruleClass)
($ Rule)))
(SETQ str (CONCAT str "Rule Class: " (SpaceOrItem (@ ruleClass))
SCRLF]
[COND
((@ debugVars)
(SETQ str (CONCAT str "Debug Vars: " (SpaceOrItem (@ debugVars))
SCRLF]
(RETURN str])
(GetRuleClass
[LAMBDA NIL (* mjs: "12-FEB-83 16:44")
(* * Parses the Rule Class declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (ruleClassName)
(* * Flush any leading comments and verify statement type.)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE Rule))
(NEQ (CADR ruleSetTokens)
(QUOTE Class)))
(FlushRule "Bad Rule Class Statement.")
(GO done)))
(* * Pop the Rule, Class, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Get the Class.)
[SETQ ruleClassName (COND
((NEQ (CAR ruleSetTokens)
semicolon)
(pop ruleSetTokens]
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ rsRuleClass (GetClassRec ruleClassName))
(COND
((AND ruleClassName (NULL rsRuleClass))
(FlushRule "Rule class not found: " ruleClassName)))
[COND
(rsRuleClass (SETQ ruleVars (← rsRuleClass List!(QUOTE IVS]
(RETURN])
(GetRuleMetaDecls
[LAMBDA NIL (* dgb: "17-Feb-84 16:06")
(* * Get the meta information (if any) associated with a rule. Subroutine of CompileRule.)
(PROG (metaTokens)
(* * Set the defaults for the rule.)
(SETQ ruleTraceFlg rsTraceFlg)
(SETQ ruleBreakFlg rsBreakFlg)
(SETQ ruleAuditFlg rsAuditFlg)
(SETQ ruleMakeAuditRecordFlg NIL)
(SETQ ruleAuditSpecification NIL)
(SETQ ruleNeedsAuditFlg NIL)
(SETQ oneShotFlg NIL)
(SETQ oneShotBangFlg NIL)
(COND
((EQ lbrace (CAR ruleSetTokens)) (* Here if {Meta-Information} provided for the rule.)
(SETQ metaTokens (while (AND (NEQ (CAR ruleSetTokens)
semicolon)
(NEQ (CAR ruleSetTokens)
rbrace))
collect (pop ruleSetTokens)))
(COND
((EQ rbrace (CAR ruleSetTokens)) (* pop the right brace.)
(pop ruleSetTokens))) (* Discard the left brace.)
(SETQ metaTokens (CDR metaTokens))
(COND
((FMEMB 1 metaTokens) (* One Shots)
(GetOneShotFlg)))
[COND
((FMEMB (QUOTE F)
metaTokens) (* Trace Rule if satisfied)
(SETQ firstLastFlg (QUOTE F))
(SETQ metaTokens (DREMOVE (QUOTE F)
metaTokens]
[COND
((FMEMB (QUOTE L)
metaTokens) (* Trace Rule if satisfied)
(SETQ firstLastFlg (QUOTE L))
(SETQ metaTokens (DREMOVE (QUOTE L)
metaTokens]
[COND
((FMEMB T metaTokens) (* Trace Rule if satisfied)
(SETQ ruleTraceFlg T)
(SETQ metaTokens (DREMOVE T metaTokens]
[COND
((FMEMB (QUOTE TT)
metaTokens) (* Trace Rule if tested)
(SETQ ruleTraceFlg T)
(SETQ metaTokens (DREMOVE (QUOTE TT)
metaTokens]
[COND
((FMEMB (QUOTE BT)
metaTokens) (* BT Break Rule if tested.)
(SETQ ruleBreakFlg (QUOTE BT))
(SETQ metaTokens (DREMOVE (QUOTE BT)
metaTokens)))
((FMEMB (QUOTE B)
metaTokens) (* Break Rule if satisfied.)
(SETQ ruleBreakFlg (QUOTE B))
(SETQ metaTokens (DREMOVE (QUOTE B)
metaTokens]
[COND
((FMEMB (QUOTE A)
metaTokens) (* Audit Rule)
(SETQ ruleAuditFlg T)
(SETQ someRuleAuditFlg T)
(SETQ metaTokens (DREMOVE (QUOTE A)
metaTokens]
(COND
(metaTokens (* Interpret the audit specs.)
(SETQ someRuleAuditFlg T)
(SETQ ruleAuditSpecification (AssocAuditSpecification metaTokens])
(GetRuleSetArgs
[LAMBDA NIL (* mjs: " 1-JUN-83 10:09")
(* * Parses the Args declaration at the beginning of a RuleSet.)
(PROG (args)
(* * Pop the Args and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Collect the Args)
(SETQ args (while (NEQ (CAR ruleSetTokens)
semicolon)
collect (pop ruleSetTokens)))
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ rsArgs args])
(GetRuleSetDeclarations
[LAMBDA (sourceStr userCompilerOptions) (* dgb: "21-Feb-84 11:42")
(* * Parse the declarations at the beginning of the RuleSet. Subroutine of CompileRuleList.
Argument self is the RuleSet.)
(PROG (token newDecl oldDecl endDeclPos)
(* * Find the declaration delimiters in the source string, parse the tokens, and process the declarations.)
(SETQ endDeclPos (STRPOS "********" sourceStr))
(SETQ declStr (SUBSTRING sourceStr 1 endDeclPos))
(ParseTokens declStr)
(* * Initialize for default declarations.)
(SETQ controlType (QUOTE DOALL))
(SETQ rsTraceFlg NIL)
(SETQ rsBreakFlg NIL)
(SETQ rsAuditFlg NIL)
(SETQ rsTaskFlg NIL)
[COND
((NULL userCompilerOptions)
(SETQ rsCompilerOptions NIL))
(T (SETQ rsCompilerOptions (InterpretCompilerOptions userCompilerOptions]
(SETQ wsClass NIL)
(SETQ rsRuleClass ($ Rule))
(SETQ rsAuditClass ($ StandardAuditRecord))
(SETQ auditSpecification (@@ rsAuditClass metaAssns))
(SETQ rsAuditSpecification NIL)
(SETQ rsWhileCondition NIL)
(SETQ ruleVars NIL)
(SETQ taskVars NIL)
(SETQ tempVars NIL)
(SETQ debugVars NIL)
(SETQ wsVars NIL)
(SETQ rsArgs NIL)
(SETQ rsSomeDeclChanged NIL)
(* * Loop through the given RuleSet declarations.)
rsDeclLoop
(FlushComment?)
(SETQ token (CAR ruleSetTokens))
(SELECTQ token
(WorkSpace (GetWorkSpaceClass))
(Audit (GetAuditClass))
(Rule (GetRuleClass))
(Meta (GetMetaAssns))
(Args (GetRuleSetArgs))
(Control (GetControlType))
((While Iteration)
(GetWhileCondition))
(Compiler (GetCompilerOptions))
(Temporary (GetTempVars))
(Task (GetTaskVars))
(Debug (GetDebugVars))
(GO NoMoreDecls))
(GO rsDeclLoop)
NoMoreDecls
(SETQ rsSomeRuleAuditFlg rsAuditFlg)
(SETQ auditSpecification (AssocAuditSpecification (APPEND auditSpecification
rsAuditSpecification)))
(RETURN NIL])
(GetRuleSetTemplate
[LAMBDA NIL (* dgb: "17-Feb-84 17:50")
(* * Subroutine of CompileRuleList. Returns a code template for the RuleSet that is specialized to the control
Type.)
(COND
([AND rsRuleAppliedFlg (FMEMB controlType (CONSTANT (LIST (QUOTE WHILE1)
(QUOTE WHILEALL]
(* Add extra bookkeeping if the While Condition
reference ↑ruleApplied.)
(SELECTQ controlType
[WHILE1 (QUOTE (PROG ↑progVars (SETQ ruleApplied T)
↑firstRules cycleLoop (COND
((NOT ↑whileCondition)
(* Quit if while condition is not satisfied.)
(GO QUIT)))
(SETQ ruleApplied T)
(COND
↑rules)
(GO cycleLoop)
QUIT ↑lastRules (RETURN ↑value]
[WHILEALL (QUOTE (PROG ↑progVars (SETQ ruleApplied T)
↑firstRules cycleLoop (COND
((NOT ↑whileCondition)
(GO QUIT)))
(SETQ ↑value ↑noRuleApplied)
↑rules
(COND
((EQ ↑value ↑noRuleApplied)
(* Here if no rule applied.)
(SETQ ruleApplied NIL)
(SETQ ↑value ↑prevValue))
(T (* Here if some rule applied.)
(SETQ ruleApplied T)
(SETQ ↑prevValue ↑value)))
(GO cycleLoop)
QUIT ↑lastRules (RETURN ↑value]
NIL))
(T (SELECTQ controlType
[DO1 (QUOTE (PROG ↑progVars ↑firstRules (COND
↑rules)
QUIT ↑lastRules (RETURN ↑value]
[DOALL (QUOTE (PROG ↑progVars ↑firstRules ↑rules QUIT ↑lastRules (RETURN ↑value]
[DONEXT (QUOTE (PROG ↑progVars ↑firstRules cycleLoop (SETQ ↑prevValue ↑value)
(SETQ ↑value NotSetValue)
(SELECTQ (@ ↑task ruleNumber)
↑rules NIL)
@
(↑task ruleNumber)
←
(ADD1 (@ ↑task ruleNumber))
(COND
((AND (EQ ↑value NotSetValue)
(ILEQ (@ ↑task ruleNumber)
(@ ↑rs numRules)))
(* Try again if no rule was satisfied and there are more
rules to try.)
(GO cycleLoop)))
QUIT ↑lastRules (RETURN ↑value]
[WHILE1 (QUOTE (PROG ↑progVars ↑firstRules cycleLoop (COND
((NOT ↑whileCondition)
(* Quit if while condition is not satisfied.)
(GO QUIT)))
(COND
↑rules)
(GO cycleLoop)
QUIT ↑lastRules (RETURN ↑value]
[(FOR1 FORALL)
(QUOTE (PROG ↑progVars ↑firstRules ↑forLoop QUIT ↑lastRules (RETURN ↑value]
[WHILEALL (QUOTE (PROG ↑progVars ↑firstRules cycleLoop (COND
((NOT ↑whileCondition)
(* Quit if while condition is not satisfied.)
(GO QUIT)))
↑rules
(GO cycleLoop)
QUIT ↑lastRules (RETURN ↑value]
[WHILENEXT (QUOTE (PROG ↑progVars ↑firstRules (SETQ ↑firstRuleTried
(@ ↑task ruleNumber))
(COND
((NOT ↑whileCondition)
(GO QUIT)))
cycleLoop
(SELECTQ (@ ↑task ruleNumber)
↑rules NIL)
@
(↑task ruleNumber)
←
(ADD1 (@ ↑task ruleNumber))
[COND
((EQ ↑value ↑noRuleApplied)
(* Here if this rule not satisfied.)
(COND
((EQ (@ ↑task ruleNumber)
↑firstRuleTried)
(* Quit if all the rules were tried but none were
satisfied.)
(SETQ ↑value NIL)
(GO QUIT))
((IGREATERP (@ ↑task ruleNumber)
(@ ↑rs numRules))
(* Try again starting at beginning.)
@
(↑task ruleNumber)
←1
(COND
((EQ ↑firstRuleTried 1)
(GO QUIT]
(GO cycleLoop)
QUIT ↑lastRules (RETURN ↑value]
(ERROR (CONCAT "Unrecognized Control Type=" controlType])
(GetTaskVars
[LAMBDA NIL (* mjs: "12-FEB-83 15:58")
(* * Parses the Task Vars declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (vars) (* Flush any leading comments.)
(FlushComment?)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE Task))
(NEQ (CADR ruleSetTokens)
(QUOTE Vars)))
(FlushRule "Bad Task Vars Statement.")
(GO done)))
(* * Pop the Task, Vars, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Collect the Task Vars.)
(SETQ vars (while (NEQ (CAR ruleSetTokens)
semicolon)
collect (pop ruleSetTokens)))
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ taskVars vars])
(GetTempVars
[LAMBDA NIL (* mjs: "12-FEB-83 15:58")
(* * Parses the Temporary Vars declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (vars)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE Temporary))
(NEQ (CADR ruleSetTokens)
(QUOTE Vars)))
(FlushRule "Bad Temporary Vars Statement.")
(GO done)))
(* * Pop the Temporary, Type, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Collect the Temporary Vars.)
(SETQ vars (while (NEQ (CAR ruleSetTokens)
semicolon)
collect (pop ruleSetTokens)))
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ tempVars vars])
(GetWhileCondition
[LAMBDA NIL (* dgb: "21-Feb-84 11:42")
(* * Parses the While Condition declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (wcTokens) (* Flush any leading comments.)
(FlushComment?)
(COND
((OR (AND (NEQ (CAR ruleSetTokens)
(QUOTE While))
(NEQ (CAR ruleSetTokens)
(QUOTE Iteration)))
(NEQ (CADR ruleSetTokens)
(QUOTE Condition)))
(FlushRule "Strange While Condition Statement.")
(GO done)))
(* * Pop the While, Condition, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Collect the While Condition.)
(SETQ wcTokens (while (NEQ (CAR ruleSetTokens)
semicolon)
collect (pop ruleSetTokens)))
(* * pop the semicolon.)
(pop ruleSetTokens)
(* * Set rsRuleAppliedFlg if ↑ruleApplied is mentioned in the tokens.)
(SETQ rsRuleAppliedFlg (FMEMB (QUOTE ruleApplied)
wcTokens)) (* Set the global taskVars.)
done(SETQ rsWhileCondition wcTokens])
(GetWorkSpaceClass
[LAMBDA NIL (* mjs: " 7-JUN-83 14:39")
(* * Parses the workSpace Class declaration at the beginning of a RuleSet. Argument self is the RuleSet.)
(PROG (wsClassName)
(* * Flush any leading comments and verify statement type.)
(COND
((OR (NEQ (CAR ruleSetTokens)
(QUOTE WorkSpace))
(NEQ (CADR ruleSetTokens)
(QUOTE Class)))
(FlushRule "Bad WorkSpace Statement.")
(GO done)))
(* * Pop the WorkSpace, Class, and colon tokens.)
(pop ruleSetTokens)
(pop ruleSetTokens)
(pop ruleSetTokens)
(* * Get the Class.)
[SETQ wsClassName (COND
((NEQ (CAR ruleSetTokens)
semicolon)
(pop ruleSetTokens]
(* * pop the semicolon.)
(pop ruleSetTokens)
done(SETQ wsClass (GetClassRec wsClassName))
[COND
(wsClass (SETQ wsVars (← wsClass List!(QUOTE IVS]
(RETURN])
(InterpretCompilerOptions
[LAMBDA (compilerOptions) (* mjs: " 8-FEB-83 18:27")
(* * Interprets compiler compilerOptions for the RuleSet compiler. Used in processing declarations, and when user
specifies re-compilation without editing.)
(* * Set global vars for the different options.)
(SETQ rsAuditFlg (COND
((FMEMB (QUOTE A)
compilerOptions)
T)))
(SETQ rsTraceFlg (COND
((FMEMB (QUOTE TT)
compilerOptions) (* Trace if tested.)
(QUOTE TT))
((FMEMB T compilerOptions) (* Trace if satisfied.)
T)))
[SETQ rsBreakFlg (COND
((FMEMB (QUOTE BT)
compilerOptions) (* Break if Tested.)
(QUOTE BT))
((FMEMB (QUOTE B)
compilerOptions) (* Break if Satisfied.)
(QUOTE B]
(SETQ rsTaskFlg (FMEMB (QUOTE S)
compilerOptions))
(SETQ rsLispCompileFlg (FMEMB (QUOTE LC)
compilerOptions))
(SETQ rsPrintRuleFlg (FMEMB (QUOTE PR)
compilerOptions))
(SETQ rsCompilerOptions compilerOptions])
(SpaceOrItem
[LAMBDA (item) (* dgb: "21-Feb-84 11:06")
(* Returns a space character if item is NIL, a string of separate items if item is a list, the object name if name
is an object, and item otherwise.)
(OR (COND
((LISTP item)
[for x on item bind y (str ← space) finally (RETURN str)
do (SETQ y (CAR x))
(COND
((OR (EQ y (QUOTE %())
(EQ (CADR x)
(QUOTE %))))
(LIST y)
(SETQ str (CONCAT str y)))
(T (SETQ str (CONCAT str y space]
(PROG (str)
(SETQ str space)
(for item it on item
do (SETQ it (CAR item))
(SETQ str (CONCAT str space it)))
(RETURN str)))
((Object? item)
(ClassName item)))
item space])
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1213 31834 (AssocAuditSpecification 1223 . 2373) (FlushComment? 2375 . 3184) (
GetAuditClass 3186 . 4385) (GetCompilerOptions 4387 . 5609) (GetControlType 5611 . 6948) (GetDebugVars
6950 . 7934) (GetMetaAssns 7936 . 9049) (GetOneShotFlg 9051 . 10620) (GetProgVars 10622 . 11883) (
GetRSAllDeclString 11885 . 13030) (GetRSDeclString 13032 . 14465) (GetRuleClass 14467 . 15658) (
GetRuleMetaDecls 15660 . 18458) (GetRuleSetArgs 18460 . 19052) (GetRuleSetDeclarations 19054 . 21368)
(GetRuleSetTemplate 21370 . 25604) (GetTaskVars 25606 . 26579) (GetTempVars 26581 . 27469) (
GetWhileCondition 27471 . 28777) (GetWorkSpaceClass 28779 . 29848) (InterpretCompilerOptions 29850 .
30998) (SpaceOrItem 31000 . 31832)))))
STOP