(FILECREATED "20-SEP-83 18:26:38" {INDIGO}<LOOPS>SOURCES>LOOPSRULES.;17 45812
changes to: (FNS DefRSM)
previous date: "10-AUG-83 13:48:50" {INDIGO}<LOOPS>SOURCES>LOOPSRULES.;16)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT LOOPSRULESCOMS)
(RPAQQ LOOPSRULESCOMS [(* Copyright (c)
1982 by Xerox Corporation)
(* * Package for Rule-Oriented Programming in LOOPS. - File LOOPSRULES
contains the basic class definitions. File LOOPSRULESP contains the rule
parser. - File LOOPSRULESC contains the rule compiler. File LOOPSRULESD
interprets RuleSet declarations.)
(* Written in August 1982 by Mark Stefik, Alan Bell, and Danny Bobrow)
(* Classes for Rule-Oriented Programming in LOOPS.)
(CLASSES * LOOPSRULESCLASSES)
(FNS * LOOPSRULESFNS)
(FNS * RULESETMISCFNS)
(VARS (↑rs NIL)
(↑ws NIL)
(↑caller NIL)
(↑task NIL)
(reWindow NIL)
(reTraceWindow NIL)
(reInspectWindow NIL)
(rsTraceFont (FONTCREATE (QUOTE GACHA)
8)))
(P (CLDISABLE (QUOTE ↑)))
[P (INTERRUPTCHAR 6 (LIST (FUNCTION RE]
(MACROS RunRS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA WRITETTY])
(* Copyright (c) 1982 by Xerox Corporation)
(* * Package for Rule-Oriented Programming in LOOPS. - File LOOPSRULES contains the basic class
definitions. File LOOPSRULESP contains the rule parser. - File LOOPSRULESC contains the rule
compiler. File LOOPSRULESD interprets RuleSet declarations.)
(* Written in August 1982 by Mark Stefik, Alan Bell, and Danny Bobrow)
(* Classes for Rule-Oriented Programming in LOOPS.)
(RPAQQ LOOPSRULESCLASSES (Rule RuleSet RuleSetMeta RuleSetNode RuleSetSource StandardAuditRecord Task
TestAuditRecord))
(DEFCLASSES Rule RuleSet RuleSetMeta RuleSetNode RuleSetSource StandardAuditRecord Task
TestAuditRecord)
[DEFCLASS Rule
(MetaClass Class doc
(* * Class for describing rules as objects. Instances of this class (rule objects) are created as a side-effect
when RuleSets are compiled in audit mode.)
Edited: (* mjs: "12-FEB-83 12:19")
)
(Supers Object)
(ClassVariables)
(InstanceVariables (source NIL doc (* string that was the source of the rule in the
RuleSet.))
(edited NIL doc (* person who edited the rule.))
(editor NIL doc (* time and date of the editing.))
(ruleNumber 0 doc (* sequence number of the rule in the RuleSet at the
time of editing.))
(ruleSet NIL doc (* RuleSet to which this rule belongs.)))
(Methods (Print Rule.Print args (file)
doc
(* * Print out formatted information about a rule -
the source, RuleSet, and editing information.)
))]
[DEFCLASS RuleSet
(MetaClass RuleSetMeta doc
(* * A RuleSet is a set of rules, together with methods for interpreting them.)
Edited: (* mjs: " 1-JUN-83 09:55")
)
(Supers NamedObject Perspective Object)
(ClassVariables)
(InstanceVariables (compiledRules NIL doc (* Name of Lisp Function for Rules.))
(workSpace NIL doc (* name of class for work space.))
(args NIL doc (* arguments to the RuleSet other than self.)
)
(tempVars NIL doc (* temporary variables.))
(taskVars NIL doc (* Task variables.))
(debugVars NIL doc (* variables to be printed during a trace or break.)
)
(numRules NIL doc (* Number of Rules in RuleSet.))
(controlStructure doAll doc (* control structure for rules.))
(whileCondition NIL doc (* while condition for RuleSet.))
(compilerOptions NIL doc (* Compilation options.))
(auditClass #$StandardAuditRecord doc
(* name of class for audit records.))
(metaAssignments NIL doc (* RuleSet specific meta-assignment statements.)
)
(ruleClass #$Rule doc (* name of class for rule objects.))
(taskClass NIL doc (* Name of class used for tasking.))
(perspectiveNode #$RuleSetNode))
(Methods (CompileRules RuleSet.CompileRules doc (* Compile the RuleSet.))
(CopyRules RuleSet.CopyRules args (newName)
doc (* Creates a new RuleSet containing a copy of the
rules.)
)
(ER RuleSet.EditRules doc (* Shorthand for EditRules))
(EditRules RuleSet.EditRules doc (* Forward the Edit message to the Source perspective of
the RuleSet.)
args NIL)
(Off RuleSet.Off args (compilerOption)
doc (* Turn off a compiler option.)
)
(On RuleSet.On args (compilerOption)
doc (* Turn on a compiler option.)
)
(PPR RuleSet.PPRules doc (* Shorthand for PPRules))
(PPRules RuleSet.PPRules args NIL doc (* PrettyPrint the Rules.)))]
[DEFCLASS RuleSetMeta
(MetaClass MetaClass doc
(* * MetaClass for RuleSets.)
Edited: (* mjs: "29-SEP-82 09:14")
)
(Supers Template)
(ClassVariables)
(InstanceVariables)
(Methods (New RuleSetMeta.New doc
(* * Create a new rule set.)
args
(name)))]
[DEFCLASS RuleSetNode
(MetaClass Template doc (* Node for RuleSet perspectives.)
Edited: (* mjs: "29-SEP-82 10:43")
)
(Supers Node Object)
(ClassVariables)
(InstanceVariables (perspectives NIL Source #$RuleSetSource RuleSet #$RuleSet))
(Methods)]
[DEFCLASS RuleSetSource
(MetaClass Template doc
(* * Source code for a RuleSet. Contains editing information about the RuleSet, and an indexed list of rule
objects.)
Edited: (* mjs: "12-FEB-83 12:16")
)
(Supers DatedObject Perspective VarLength)
(ClassVariables)
(InstanceVariables (perspectiveNode #$RuleSetNode)
(edited NIL doc (* Date last edited.))
(editor NIL doc (* Last User to edit the rules.)))
(Methods (CompileRules RuleSetSource.CompileRules doc
(* * Compile the Rules for a RuleSet from the Rule Language into Interlisp.)
args
(↑userCompilerOptions sourceRules))
(EditRules RuleSetSource.EditRules doc (* Edit the rules associated with a RuleSetSource.)
args NIL)
(GetSource RuleSetSource.GetSource args (allDeclFlg)
doc
(* Compute the source string for a RuleSet for printing or editing. If allDeclFlg is T, the computed string will
include extra rule declarations beyond the basic set, even if they have no current value.)
)
(PPRules RuleSetSource.PPRules args (file)
doc (* Pretty Print the Rules)
))]
[DEFCLASS StandardAuditRecord
(MetaClass Class doc
(* * Standard (default) audit record for makeing audit trails of RuleSet invocations.)
Edited: (* mjs: " 9-JUN-83 09:53")
)
(Supers Object)
(ClassVariables (metaAssns (rule ← ruleObject)
doc (* default meta-assignment statements associated with
this audit record.)
))
(InstanceVariables (rule NIL doc (* Rule used in setting the value.)))
(Methods)]
[DEFCLASS Task
(MetaClass Class doc
(* * Representation of the invocation of a RuleSet. Used in creating variations of agenda control structures.
Similar to the idea of closures.)
Edited: (* mjs: " 7-JUN-83 10:24")
)
(Supers Object)
(ClassVariables)
(InstanceVariables (ruleNumber 1 doc (* Number of the next rule to be executed.
Used for RuleSet debugging and for doNext and
cycleNext.))
(rs NIL doc (* RuleSet that was invoked.))
(self NIL doc (* workSpace given to the RuleSet.))
(value NIL doc (* value returned by the RuleSet))
(status Started doc (* Execution status. Examples: Started, Done, Aborted,
Suspended.))
(reason NotKnown doc (* Reason for the status. Examples: Success, NoSpace,
Blocked))
(caller NIL doc (* Caller of the RuleSet.)))
(Methods (Step NIL doc (* Method to Step the Task.)))]
[DEFCLASS TestAuditRecord
(MetaClass Class doc (* For Test cases.)
Edited: (* mjs: "11-NOV-82 09:30")
)
(Supers StandardAuditRecord)
(ClassVariables)
(InstanceVariables (↑rs NIL)
(↑ruleNumber 0)
(cf .3)
(support NIL))
(Methods)]
(RPAQQ LOOPSRULESFNS (ListRuleSets MakeEditMenu REObject ReinstallRuleSets Rule.Print
RuleSet.CompileRules RuleSet.CopyRules RuleSet.EditRules
RuleSet.Off RuleSet.On RuleSet.PPRules RuleSetMeta.New
RuleSetSource.CompileRules RuleSetSource.EditRules
RuleSetSource.GetSource RuleSetSource.PPRules SaveRules
SearchStackForWorkSpace))
(DEFINEQ
(ListRuleSets
[LAMBDA (ruleSetsSpec pressFileName) (* sm: "10-AUG-83 13:48")
(* * Prints a list of RuleSets to a file. Arg can be either a RuleSetName, or a list of RuleSetNames, or a file
name, or a className. If it is a className, all of the RuleSets that are methods of the class are printed.)
(PROG (ruleSetNames numNames class ruleSetName ruleSet (listFile (OR pressFileName (QUOTE
{CORE}ListRules)))
fileHandle)
(* * Decode the argument to find the RuleSet Names.)
[SETQ ruleSetNames (COND
((LISTP ruleSetsSpec)
ruleSetsSpec)
[(PROG1 (FILECOMSLST (U-CASE ruleSetsSpec)
(QUOTE INSTANCES))
(SETQ class (GetClassRec ruleSetsSpec]
((SETQ class (GetClassRec ruleSetsSpec))
(for method in (← class List (QUOTE Methods)) when (SETQ ruleSetName
(GetMethod class method
(QUOTE RuleSet)))
collect ruleSetName))
(T (LIST ruleSetsSpec] (* mumble)
(* * Create a temporary file.)
(SETQ fileHandle (OPENFILE listFile (QUOTE OUTPUT)))
(COND
(class (← class PP fileHandle)
(printout fileHandle .PAGE T)))
(SETQ numNames (FLENGTH ruleSetNames))
[for rsn in ruleSetNames as num from 1 to numNames
do (SETQ ruleSet (GetObjectRec rsn))
(COND
(ruleSet (PRIN1 rsn)
(SPACES 1)
(printout fileHandle T T "*********************************************" T
T)
(← ruleSet PPRules fileHandle)
(COND
((NEQ num numNames) (* New page except last one)
(printout fileHandle .PAGE T T T]
(CLOSEF fileHandle)
(COND
((NOT pressFileName) (* Print and Delete the file if name not given by user.)
(EMPRESS fileHandle)
(DELFILE fileHandle])
(MakeEditMenu
[LAMBDA NIL (* mjs: " 9-JUN-83 09:36")
(* Makes a menu for the Rule Editor.
Saves in the global variable reEditMenu to avoid
recreating the menu over again each time.)
[COND
((NULL reEditMenu)
(SETQ reEditMenu (create MENU
ITEMS ←(QUOTE (OK EditRules Help EditAllDecls EditWS STOP Undo! UE
EF Compile Save InspectRuleSet))
TITLE ← "Rule Edit Options"]
reEditMenu])
(REObject
[LAMBDA (↑ws) (* dgb: " 1-FEB-83 12:24")
(* * Used to call RE after binding ↑ws.)
(RE])
(ReinstallRuleSets
[LAMBDA (className) (* mjs: " 8-JUN-83 18:15")
(PROG (class methods ruleSetName)
(SETQ class (GetClassRec className))
(for selector in (← class List (QUOTE Methods)) do (COND
((SETQ ruleSetName
(GetMethod class selector
(QUOTE RuleSet)))
(DefRSM className selector
ruleSetName])
(Rule.Print
[LAMBDA (self file) (* mjs: " 9-JUN-83 09:17")
(* * Print out formatted information about a rule -
the source, RuleSet, and editing information.)
(printout file T .FONT BOLDFONT (@ source)
.FONT DEFAULTFONT T)
(printout file T .FONT COMMENTFONT .SP 5 "... Rule " (@ ruleNumber)
" from "
(@(@ ruleSet)
name))
(printout file T .SP 5 " edited by " (@ editor)
" on "
(@ edited)
.FONT DEFAULTFONT T T)
T])
(RuleSet.CompileRules
[LAMBDA (self compilerOptions) (* mjs: "22-JAN-83 10:01")
(* Forward the Compile message to the Source perspective
of the RuleSet.)
(PROG (sourcePerspective)
(SETQ sourcePerspective (← self GetPersp (QUOTE Source)))
(← sourcePerspective CompileRules compilerOptions)
(RETURN self])
(RuleSet.CopyRules
[LAMBDA (self newName workSpace) (* mjs: "22-JUL-83 14:43")
(* * Creates a new RuleSet containing a copy of the rules.)
(PROG (newRS ruleSetSource)
(* * Create a RuleSet)
(SETQ newRS (← self Copy newName))
(COND
(workSpace (←@
newRS workSpace workSpace))) (* Copy the rule objects.)
(SETQ rsRuleClass (@ ruleClass))
(SETQ ruleSetSource (← self GetPersp (QUOTE Source)))
(SaveRules ruleSetSource self (← ruleSetSource GetSource))
(* Compile the Rules.)
(SETQ rsCompilerOptions NIL)
(← newRS CompileRules)
(RETURN newRS])
(RuleSet.EditRules
[LAMBDA (self coms) (* SDG "27-MAY-83 08:52")
(* Forward the Edit message to the Source perspective of
the RuleSet.)
(PROG (sourcePerspective)
(SETQ sourcePerspective (← self GetPersp (QUOTE Source)))
(← sourcePerspective EditRules coms)
(RETURN self])
(RuleSet.Off
[LAMBDA (self compilerOption) (* mjs: "13-JUN-83 19:17")
(* Turn off a compiler option.)
(COND
((FMEMB compilerOption (@ compilerOptions))
(←@
compilerOptions
(REMOVE compilerOption (@ compilerOptions)))
(← self CompileRules))
(T (printout T .FONT BOLDFONT compilerOption .FONT DEFAULTFONT " not on for " self T])
(RuleSet.On
[LAMBDA (self compilerOption) (* mjs: "13-FEB-83 11:57")
(* Turn on a compiler option.)
(COND
((NOT (FMEMB compilerOption (@ compilerOptions)))
(←@
compilerOptions
(NCONC1 (@ compilerOptions)
compilerOption))
(← self CompileRules])
(RuleSet.PPRules
[LAMBDA (self file) (* mjs: "28-JAN-83 18:19")
(* * PrettyPrint the Rules.)
(← (← self GetPersp (QUOTE Source))
PPRules file])
(RuleSetMeta.New
[LAMBDA (self assocList name) (* mjs: "12-FEB-83 12:20")
(* * Create a new rule set. (The argument self is the class RuleSet.))
(PROG (newRuleSet sourcePersp)
(* * Insist on getting a name for the RuleSet.)
[SETQ name (OR name (INTTY "RuleSet name: " NIL
"RuleSets need to have names. Please enter a name for the RuleSet."
(QUOTE noShiftFlg]
(* * Make the RuleSet and its other perspectives.)
(SETQ newRuleSet (←Super
self New assocList))
(* * Set the Name in the RuleSet.)
(← newRuleSet SetName name)
(* * Return the RuleSet.)
(RETURN newRuleSet])
(RuleSetSource.CompileRules
[LAMBDA (self userCompilerOptions sourceStr) (* mjs: " 8-JUN-83 16:25")
(* * Compile the Rules for a RuleSet from the Rule Language into Interlisp. self is the Source perspective of the
RuleSet.)
(PROG (codeBody ruleSet rulePos ruleStr ruleSetArgs)
(SETQ ruleSet (← self GetPersp (QUOTE RuleSet)))
(COND
(userCompilerOptions (←@
ruleSet compilerOptions userCompilerOptions)))
(SETQ rsName (@ ruleSet name))
(printout NIL .FONT BOLDFONT "Compiling " rsName " to Lisp." .FONT DEFAULTFONT T)
(* Compute the source rules unless supplied by the rule
editor.)
[COND
((NULL sourceStr)
(SETQ sourceStr (← self GetSource] (* Process the declarations.)
(GetRuleSetDeclarations sourceStr userCompilerOptions)
(COND
(parseErrorFlg (RETURN rsName))) (* Locate the start of the rules.)
(SETQ rulePos (PLUS 8 (STRPOS "********" sourceStr)))
(SETQ ruleStr (SUBSTRING sourceStr rulePos)) (* Parse the tokens.)
(ParseTokens ruleStr) (* Generate the LISP code for the rules.)
(COND
(parseErrorFlg (RETURN rsName)))
(SETQ rsNumRules (CountRules sourceStr))
(SETQ rsRuleObjects (GetRules sourceStr ruleSet))
(SETQ codeBody (CompileRuleList ruleSet self))
(SETQ ruleSetArgs (CONS (QUOTE self)
rsArgs))
(* * Install the code in a function with the same rsName as the RuleSet unless there was an error during
compilation.)
[COND
((NULL parseErrorFlg)
(DEFINE (LIST (LIST rsName ruleSetArgs codeBody)))
(* Make a pointer to the function in the RuleSet.)
(←@
ruleSet compiledRules rsName)
(TERPRI)
(COND
((AND (FMEMB (QUOTE LC)
userCompilerOptions)
(NULL parseErrorFlg))
(printout NIL .FONT BOLDFONT "Compiling " rsName " to ByteCodes." .FONT DEFAULTFONT
T T)
(BKSYSBUF "ST
")
(BKSYSBUF "N
")
(COMPILE rsName]
(RETURN rsName])
(RuleSetSource.EditRules
[LAMBDA (self coms) (* mjs: " 8-JUN-83 17:56")
(* Edit the rules associated with a RuleSetSource.
Also sets rsOldRuleStrings and rsRuleStrings -- lists of
statements that are compared during RuleSet
compilation.)
(PROG (command oldSourceRules ruleSet sourceRules doneFlg workSpace rulePos (needToCompileFlg
T)) (* Collect old statements from BEFORE the Edit.)
(SETQ ruleSet (← self GetPersp (QUOTE RuleSet)))
(SETQ oldSourceRules (← self GetSource))
(SETQ sourceRules oldSourceRules)
(SETQ rsName (@ ruleSet name))
(MakeEditMenu)
[COND
((NULL coms) (* Initially place user in rule editor.)
(SETQ coms (LIST (QUOTE EditRules]
(while (NULL doneFlg)
do ((SETQ command (OR (pop coms)
(MENU reEditMenu)))
(SELECTQ command
(UE (UE))
[EditRules (SETQ needToCompileFlg T)
(WINDOWPROP TTYINEDITWINDOW (QUOTE TITLE)
(CONCAT "TTYIN Edit of RuleSet " rsName
" (StopGap Version)"))
(RESETLST (SET.TTYINEDIT.WINDOW)
(PROG1 (SETQ sourceRules
(TTYIN " " NIL NIL (QUOTE (STRING NORAISE
REPEAT))
NIL NIL sourceRules]
[EditAllDecls (SETQ needToCompileFlg T)
(WINDOWPROP TTYINEDITWINDOW (QUOTE TITLE)
(CONCAT "TTYIN Edit of RuleSet " rsName
" (StopGap Version)"))
(RESETLST (SET.TTYINEDIT.WINDOW)
(GetRuleSetDeclarations sourceRules)
(SETQ rulePos (PLUS 8 (STRPOS "********"
sourceRules)))
(SETQ sourceRules (CONCAT (GetRSAllDeclString)
(SUBSTRING sourceRules
rulePos)))
(SETQ sourceRules (TTYIN " " NIL NIL
(QUOTE (STRING NORAISE
REPEAT))
NIL NIL sourceRules]
[OK (COND
(needToCompileFlg (SETQ parseErrorFlg NIL)
(← self CompileRules NIL sourceRules)))
(COND
((NULL parseErrorFlg) (* Here if compiled without error.)
(SETQ doneFlg T)
(SaveRules self ruleSet sourceRules rsRuleObjects)
(SHRINKW TTYINEDITWINDOW]
(Compile (SETQ parseErrorFlg NIL)
(← self CompileRules NIL sourceRules)
(SETQ needToCompileFlg NIL))
(STOP (SETQ doneFlg T))
(Save (SaveRules self ruleSet sourceRules))
[EF (COND
((FNTYP rsName)
(APPLY (QUOTE EF)
rsName)
(CLEARBUF]
(InspectRuleSet (← ruleSet Inspect))
[EditWS (SETQ workSpace (GetClassRec (@ ruleSet workSpace)))
(COND
(workSpace (← workSpace Edit))
(T (WRITE "Class for Workspace not found."]
(Undo! (SETQ sourceRules oldSourceRules))
(Help (printout T
"Use OK to Compile the rules, save them, and exit.
Use EditRules to edit the rules.
Use EditAllDecls to edit the rules, showing all declarations.
Use STOP to exit without compiling or saving.
Use Undo! to restore the original RuleSet.
Use UE to go into a Lisp user exec.
Use EF to edit the compiled lisp code for the RuleSet.
Use Compile to compile the rules without exiting.
Use InspectRuleSet to inspect the RuleSet object.
Use Help to get this list."
T))
NIL])
(RuleSetSource.GetSource
[LAMBDA (self) (* dlsb: "16-FEB-83 11:58")
(* Compute the source string for a RuleSet for printing
or editing.)
(PROG (declStr str ruleSource ruleSet numRules (CRLF (CONSTANT "
")))
(SETQ ruleSet (← self GetPersp (QUOTE RuleSet)))
(SETQ declStr (GetRSDeclString ruleSet))
(SETQ str CRLF) (* Collect the strings for the rules.)
(SETQ numRules (OR (@ ruleSet numRules)
0))
(for ruleNum from 1 to numRules when (SETQ ruleSource (GetValue (GetNthValue self ruleNum)
(QUOTE source)))
do (SETQ str (CONCAT str CRLF CRLF ruleSource)))
(RETURN (CONCAT declStr "********" CRLF str])
(RuleSetSource.PPRules
[LAMBDA (self file) (* mjs: "12-FEB-83 12:00")
(* Pretty Print the Rules)
(COND
((NULL file) (* Default PP file.)
(SETQ file PPDefault)))
(printout file .FONT BOLDFONT "RuleSet " (@(← self GetPersp (QUOTE RuleSet))
name)
T)
(printout file .FONT COMMENTFONT "Last Edited: " (@ edited)
" by "
(@ editor)
.FONT DEFAULTFONT T)
(printout file (← self GetSource)
T)
self])
(SaveRules
[LAMBDA (ruleSetSource ruleSet sourceRules ruleObjects) (* mjs: "22-JUL-83 18:31")
(* * Saves the rules and declarations from the given sourceRules.)
(PROG (editor edited)
(SETQ editor (COND
((EQ USERNAME (QUOTE LOOPSCOURSE))
StudentName)
(T USERNAME)))
(SETQ edited (DATE))
(* * Save the declarations.)
(GetRuleSetDeclarations sourceRules)
[COND
(wsClass (←@
ruleSet workSpace (ClassName wsClass]
(←@
ruleSet taskVars taskVars)
(←@
ruleSet tempVars tempVars)
(←@
ruleSet debugVars debugVars)
(←@
ruleSet args rsArgs)
(←@
ruleSet controlStructure controlType)
(←@
ruleSet whileCondition rsWhileCondition)
(←@
ruleSet compilerOptions rsCompilerOptions)
[←@
ruleSet auditClass (COND
((EQ rsAuditClass ($ StandardAuditRecord))
NIL)
(T (ClassName rsAuditClass]
(←@
ruleSet metaAssignments rsAuditSpecification)
[←@
ruleSet ruleClass (COND
((EQ rsRuleClass ($ Rule))
NIL)
(T (ClassName rsRuleClass]
(←@
ruleSetSource editor editor)
(←@
ruleSetSource edited edited)
(* * Save the rules.)
(COND
((NULL ruleObjects)
(SETQ rsNumRules (CountRules sourceRules))
(SETQ ruleObjects (GetRules sourceRules ruleSet)))
(T (SETQ numRules rsNumRules)
(SETQ ruleObjects rsRuleObjects)))
(←@
ruleSet numRules rsNumRules) (* Hack to remove old Rule objects from indexed vars.)
(←@
ruleSetSource indexedVars NIL)
(for rule in ruleObjects as I from 1 to rsNumRules
do (←@
rule edited edited)
(←@
rule editor editor)
(PutNthValue ruleSetSource I rule])
(SearchStackForWorkSpace
[LAMBDA NIL (* mjs: "10-JUN-83 11:36")
(* Climbs the Lisp stack to find the first function corresponding to the invocation of a RuleSet.
Then returns the object (self) that is the workspace of the RuleSet during that invocation.)
(PROG (ruleSetName)
[for I from 1 to 1000 while (SETQ ruleSetName (STKNTHNAME I))
thereis (AND ($! ruleSetName)
(← ($! ruleSetName)
InstOf!(QUOTE RuleSet]
(RETURN (COND
(ruleSetName (EVALV (QUOTE self)
(STKPOS ruleSetName 0])
)
(RPAQQ RULESETMISCFNS (CloseREWindow CountRules DefRSM GetRules MINUSMINUS PAUSE PLUSPLUS PutAuditRec
PutClassAuditRec RE RE1 REAskWhy REFocusRuleSet RETraceSelectFn
RSGetFn RSPutFn RuleSetStop RuleSetTransfer SetUpRE TraceLHS
TraceRHS WRITETTY WhichRule?))
(DEFINEQ
(CloseREWindow
[LAMBDA NIL (* mjs: "29-JUL-83 16:10")
(* * CLOSEFN for the Rule Exec window. Closes related windows.)
(COND
(reTraceWindow (CLOSEW reTraceWindow)))
(COND
(reInspectWindow (CLOSEW reInspectWindow])
(CountRules
[LAMBDA (sourceStr) (* mjs: "13-FEB-83 10:57")
(* * Counts the number of rules in the given string.)
(PROG (str rulePos (char T))
(* * First skip the declarations.)
(SETQ rulePos (IPLUS 8 (STRPOS "********" sourceStr)))
(SETQ str (SUBSTRING sourceStr rulePos))
(* * Then count the semicolons.)
(RETURN (while char count (EQ semicolon (SETQ char (GNC str])
(DefRSM
[LAMBDA (className selector ruleSetName) (* dgb: "20-SEP-83 16:56")
(* Installs a RuleSet as a method in the class. If ruleSetName is NIL, then DefRSM creates a RuleSet, invokes the
RuleSet editor, compiles the RuleSet, and installs it as a method in the class. Also initializes the workspace
instance variable.)
(PROG (ruleSet classRec) (* Check that class exists.)
(COND
((NOT (SETQ classRec (GetClassRec className)))
(PROMPT "Class" className " not found.")
(RETURN NIL)))
(OR selector (SETQ selector (PromptRead "Type selector for RuleSet Method: "))
(RETURN))
[COND
((Object? className)
(SETQ className (ClassName className] (* Create RuleSet if not specified.)
[COND
((NULL ruleSetName)
(SETQ ruleSetName (PACK* selector className))
(* Make the RuleSet.)
(SETQ ruleSet (← ($ RuleSet)
New NIL ruleSetName)) (* Edit and Compile the RuleSet.)
(←@
ruleSet workSpace className)
(← ruleSet ER))
(T (SETQ ruleSet (GetObjectRec ruleSetName))
(←@
ruleSet workSpace className)
(SETQ ruleSet (GetObjectRec ruleSetName] (* Create the installation fn.)
(* Install and document the RuleSet as a method.)
(PutMethod classRec selector ruleSetName)
(PutMethod classRec selector ruleSetName (QUOTE RuleSet))
(RETURN ruleSetName])
(GetRules
[LAMBDA (sourceStr ruleSet) (* mjs: " 9-JUN-83 09:32")
(* * Returns a list of rule objects for rules derived from the given string. Assumes that global rsRuleClass has
been set.)
(PROG (str rulePos rules rule semiPos ruleStr char (ruleCount 0))
(* * First skip the declarations.)
(SETQ rulePos (IPLUS 8 (STRPOS "********" sourceStr)))
(SETQ str (SUBSTRING sourceStr rulePos))
(* * Then collect the rules as text between semicolons.)
NextRule
(SETQ semiPos (STRPOS semicolon str))
(COND
((NULL semiPos)
(GO Done)))
(SETQ rule (← rsRuleClass New))
(SETQ ruleStr (SUBSTRING str 1 semiPos)) (* Eliminate leading CRLFs.)
(while [AND (SETQ char (SUBATOM ruleStr 1 1))
(FMEMB char (CONSTANT (LIST carriageReturn lineFeed]
do (SETQ ruleStr (SUBSTRING ruleStr 2)))
(←@
rule source ruleStr)
(←@
rule ruleSet ruleSet)
(SETQ ruleCount (ADD1 ruleCount))
(←@
rule ruleNumber ruleCount)
(SETQ rules (NCONC1 rules rule))
(SETQ str (SUBSTRING str (ADD1 semiPos)))
(GO NextRule)
Done(RETURN rules])
(MINUSMINUS
[LAMBDA (a b) (* mjs: " 3-SEP-82 11:47")
(* * MinusMinus operator for rules. Defined here to be integer subtraction modulo 4)
(IREMAINDER (IDIFFERENCE a b)
4])
(PAUSE
[LAMBDA (msg1 msg2 msg3 msg4) (* mjs: "22-JAN-83 10:55")
(* * Causes computation to pause until a carriage return is typed.)
(PROG (msg)
(SETQ msg (COND
(msg4 (CONCAT msg1 msg2 msg3 msg4))
(msg3 (CONCAT msg1 msg2 msg3))
(msg2 (CONCAT msg1 msg2))
(msg1 msg1)
(T "PAUSE: Type RETURN to continue.")))
(INTTYL msg NIL "Type Return when ready to Continue")
(RETURN T])
(PLUSPLUS
[LAMBDA (a b) (* mjs: " 3-SEP-82 11:47")
(* * PlusPlus operator for rules. Defined here to be integer addition modulo 4)
(IREMAINDER (IPLUS a b)
4])
(PutAuditRec
[LAMBDA (auditObject auditVarName newValue auditRecord) (* mjs: "22-NOV-82 15:24")
(* * Procedure to set an instance variable to newValue, and then to set its reason property to the given audit
record.)
(PutValue auditObject auditVarName auditRecord (QUOTE reason))
(PutValue auditObject auditVarName newValue])
(PutClassAuditRec
[LAMBDA (self varName newValue auditRecord) (* mjs: " 5-NOV-82 09:30")
(* * Procedure to set a class variable to newValue, and then to set its reason property to the given audit
record.)
(PutClassValue self varName auditRecord (QUOTE reason))
(PutClassValue self varName newValue])
(RE
[LAMBDA (wsName) (* mjs: "29-JUL-83 14:04")
(* * The Rule Exec. Part of the RuleSet debugging facilities. Interprets commands in the syntax of the rule
language and executes them immediately.)
(COND
((NULL reWindow) (* Allocate an RE Exec Window if needed.)
(SETQ reWindow
(CREATEW (create REGION
LEFT ← 277
BOTTOM ← 12
WIDTH ← 600
HEIGHT ← 250)
"Rule Exec (Stopgap Version)"))
(WINDOWPROP reWindow (QUOTE CLOSEFN)
(FUNCTION CloseREWindow))
(DSPSCROLL (QUOTE ON)
reWindow)
(WINDOWPROP reWindow (QUOTE RIGHTBUTTONFN)
NIL)))
(* * Clear the reWindow and direct TTY there.)
(CLEARW reWindow)
(RESETLST (RESETSAVE (TTY.PROCESS (THIS.PROCESS)))
[RESETSAVE (TTYDISPLAYSTREAM (WINDOWPROP reWindow (QUOTE DSP]
(RESETSAVE NIL (LIST (QUOTE CLOSEW)
reWindow))
(PROG [(↑ws (OR wsName (SearchStackForWorkSpace]
LP [COND
((NULL ↑ws)
(SETQ ↑ws (INTTY "Work space: " NIL
"Type name of workSpace.
Type ok to quit."
T] (* Here if RuleSet found.)
(COND
((FMEMB ↑ws (QUOTE (ok Ok OK)))
(RETURN T)))
(SETQ ↑ws ($! ↑ws))
(COND
((NULL ↑ws)
(WRITE "Work space not found.")
(GO LP)))
(RE1)
(RETURN T])
(RE1
[LAMBDA NIL (* mjs: "29-JUL-83 16:18")
(* * Subroutine of RE. Contains the Read-Compile-Eval-Print Loop.)
(PROG [self ↑ruleSetNames ↑comStr ↑comExpr prevTokens [whyTokens (CONSTANT (QUOTE (WHY Why why]
(↑doneExprs (CONSTANT (QUOTE (OK Ok ok DONE Done done BYE Bye bye]
(* * Set up RE menus.)
(SETQ ↑ruleSetNames (SetUpRE))
(* * Read Compile Evaluate Print Loop.)
(SETQ self ↑ws)
RELoop
(TOTOPW reTraceWindow)
[SETQ ↑comStr (TTYIN "re: " NIL NIL (QUOTE (STRING NORAISE]
(COND
((NULL ↑comStr)
(GO RELoop))
((OR (STREQUAL ↑comStr "UE")
(STREQUAL ↑comStr "ue"))
(CLOSEW reWindow)
(UE)
(GO RELoop))
((STREQUAL ↑comStr "?")
(WRITE
"To inspect a work space, use LEFT mouse button in trace menu.
To print a RuleSet, use MIDDLE mouse button in trace menu.
To evaluate a Rule expression, type it in this window.
To get the LISP User Exec, type UE.
To quit, type OK.")
(GO RELoop))) (* Parse the tokens.)
(ParseTokens ↑comStr)
(COND
((FMEMB (CAR ruleSetTokens)
whyTokens)
(REAskWhy)
(GO RELoop))
((FMEMB (CAR ruleSetTokens)
↑doneExprs)
(RETURN T))) (* Save tokens in case next query is a bare why.)
(SETQ prevTokens ruleSetTokens)
(* * Add extra semicolon and Parse the rule.)
(SETQ ruleSetTokens (NCONC1 ruleSetTokens semicolon))
(SETQ ↑comExpr (CompileRule1 (QUOTE specialFlg)))
(COND
(rsCompilerDebugFlg (WRITE "↑comExpr=" ↑comExpr)))
[COND
((NULL parseErrorFlg)
(NLSETQ (WRITE (EVAL ↑comExpr]
(REFocusRuleSet)
(GO RELoop])
(REAskWhy
[LAMBDA NIL (* mjs: " 1-JUN-83 16:53")
(* Subroutine of RE to handle a WHY command to see why a
variable has a particular value.)
(PROG (compiledExpr rule) (* First Remove the WHY token.)
(pop ruleSetTokens)
(COND
((EQ semicolon (CAR ruleSetTokens))
(SETQ ruleSetTokens prevTokens)
(printout T " -- That is, why " (CAR ruleSetTokens)
T T))) (* Compile the expression as if a regular fetch.)
(SETQ ruleSetTokens (NCONC1 ruleSetTokens semicolon))
(SETQ compiledExpr (CompileRule1)) (* Remove the ↑value code.)
(SETQ compiledExpr (CADDR compiledExpr))
(SELECTQ (CAR compiledExpr)
(GetValue (RPLACA compiledExpr (QUOTE WhichRule?)))
(GetClassValue (RPLACA compiledExpr (QUOTE WhichRule?))
(NCONC1 compiledExpr T))
(PROGN (WRITE "eh?")
(GO Done)))
(SETQ rule (EVAL compiledExpr))
(COND
(rule (← rule Print))
(T (WRITE "Rule not known.")))
Done(TERPRI])
(REFocusRuleSet
[LAMBDA NIL (* mjs: " 8-JUN-83 10:47")
(* * Initialize global variables for a RuleSet so that RE will operate correctly with the compiler.
The variable self is the RuleSet.)
(SETQ wsClass (Class ↑ws))
(SETQ wsVars (← wsClass List!(QUOTE IVS)))
(SETQ taskVars NIL)
(SETQ tempVars NIL)
(SETQ controlType (QUOTE DOALL))
(SETQ ruleNumber -10000)
(SETQ rsTraceFlg NIL)
(SETQ rsBreakFlg NIL)
(SETQ rsAuditFlg NIL)
(SETQ ruleObject NIL)
(SETQ rsTaskFlg NIL])
(RETraceSelectFn
[LAMBDA (item menu key) (* mjs: " 9-JUN-83 10:40")
(* Menu Select Fn for the RuleExec Trace Window.
Allows printing of RuleSet or Inspecting of its work
space.)
(PROG (ws)
(SELECTQ key
(LEFT (SETQ ws (CADR item))
(SETQ ↑reInspectWindow (← ws Inspect)))
[MIDDLE (EVAL.IN.TTY.PROCESS (BQUOTE (← , (GetObjectRec (CAR item))
ER]
NIL])
(RSGetFn
[LAMBDA (self varName localSt propName activeVal type) (* mjs: " 7-JUN-83 10:48")
(* * This is the getFn for invoking a RuleSet on Get operations in an active value. It assumes that the RuleSet
can be found on the RSGet property of the varName variable in self. The local state is given to the RuleSet as its
work space. The value returned by RSGetFn is the value computed by the RuleSet.)
(PROG (ruleSet ruleValue)
[SETQ ruleSet (GetObjectRec (GetValue self varName (QUOTE RSGet]
(COND
((OR (NULL ruleSet)
(NOT (Class? (QUOTE RuleSet)
ruleSet)))
(ERROR "RuleSet not found for active value.")))
(SETQ ruleValue (RunRS ruleSet localSt))
(RETURN ruleValue])
(RSPutFn
[LAMBDA (self varName newValue propName activeVal type) (* mjs: " 7-JUN-83 10:49")
(* * This is a putFn for invoking a RuleSet on Put operations in active values. It assumes that the RuleSet can be
found on the property RSPut of varName in self. The argument newValue is given to the RuleSet as its the work
space. The value returned by the RuleSet is put into the local state of the active value.)
(PROG (ruleSet ruleValue)
[SETQ ruleSet (GetObjectRec (GetValue self varName (QUOTE RSPut]
(COND
((OR (NULL ruleSet)
(NOT (Class? (QUOTE RuleSet)
ruleSet)))
(ERROR "RuleSet not found for active value.")))
(SETQ ruleValue (RunRS ruleSet newValue))
(RETURN (PutLocalState activeVal ruleValue self varName propName type])
(RuleSetStop
[LAMBDA (stopValue ↑status ↑reason) (* mjs: " 7-JUN-83 10:18")
(* * Used to carry out STOP statements in RuleSets. Sets instance variables in the Task. Arg ↑value is implicitly
passed from the RuleSet.)
(SETQ ↑value stopValue) (* Add code here to save status and reason when tasks
get implemented.)
↑value])
(RuleSetTransfer
[LAMBDA (ruleSetArgs) (* mjs: "29-OCT-82 17:00")
(* Does a control transfer eliminating tail recursion for rule sets. Special version of RETAPPLY which cuts back
past internal frames put on the stack if RETAPPLY was used before.)
(PROG [(ruleSetPos (STKPOS (QUOTE RuleSet.Run]
(COND
((NULL ruleSetPos)
(ERROR "Must be inside a RuleSetR.Run to transfer"))
((AND (EQ (QUOTE APPLY)
(STKNTHNAME -1 ruleSetPos))
(EQ (QUOTE *ENV*)
(STKNTHNAME -2 ruleSetPos))) (* RETAPPLY has been used before.
Fix up stack pointer to be 2 back)
(STKNTH -3 ruleSetPos ruleSetPos)))
(ENVAPPLY (QUOTE RuleSet.Run)
ruleSetArgs ruleSetPos ruleSetPos T T])
(SetUpRE
[LAMBDA NIL (* mjs: "29-JUL-83 16:20")
(* * Fn to initialize the break windows and menus for the RuleExec.)
(PROG (ruleSetNames stkName traceMenu mPosition wRegion)
(SETQ controltype (QUOTE DOALL))
(REFocusRuleSet)
(* * Set up Trace Menu.)
[SETQ ruleSetNames (for I from 1 to 1000 while (SETQ stkName (STKNTHNAME I))
when (AND (GetObjectRec stkName)
(← (GetObjectRec stkName)
InstOf!(QUOTE RuleSet)))
collect (PROG [(WS (EVALV (QUOTE self)
(STKPOS stkName 0]
(RETURN (LIST stkName WS (CONCAT "Left to INSPECT "
(GetObjectName WS)
"
" "Middle to EDIT " stkName " rules"]
(SETQ traceMenu
(create MENU
ITEMS ← ruleSetNames
ITEMWIDTH ← 150
MENUCOLUMNS ← 1
MENUFONT ← rsTraceFont
WHENSELECTEDFN ←(FUNCTION RETraceSelectFn)))
(SETQ wRegion (WINDOWPROP reWindow (QUOTE REGION)))
(SETQ mPosition (create POSITION
XCOORD ←(IDIFFERENCE (fetch LEFT of wRegion)
151)
YCOORD ←(IPLUS (fetch BOTTOM of wRegion)
(fetch HEIGHT of wRegion)
-50)))
(ADDMENU traceMenu NIL mPosition (QUOTE ScrollFlg))
(SETQ reTraceWindow (WFROMMENU traceMenu])
(TraceLHS
[LAMBDA (ruleSetName ruleLab ruleNum) (* mjs: " 8-JUN-83 11:28")
(* * Invoked to print a trace msg for the LHS of a rule.)
(PROGN (printout T "Testing rule " .FONT BOLDFONT (OR ruleLab ruleNum)
.FONT DEFAULTFONT " in RuleSet " .FONT BOLDFONT ruleSetName .FONT DEFAULTFONT T)
T])
(TraceRHS
[LAMBDA (ruleSetName ruleLab ruleNum ↑value) (* mjs: " 8-JUN-83 11:28")
(* * Invoked to print a trace msg for the RHS of a rule.)
(PROGN (printout T "Executing rule " .FONT BOLDFONT (OR ruleLab ruleNum)
.FONT DEFAULTFONT " in RuleSet " .FONT BOLDFONT ruleSetName .FONT DEFAULTFONT T)
↑value])
(WRITETTY
[LAMBDA nargs (* mjs: "15-NOV-82 09:51")
(* Write each argument out to the TTY.
Value is T. Called by various rule tracing fns.)
(PROG ((I 0))
[while (ILESSP I nargs) do (PRIN1 (ARG nargs (SETQ I (ADD1 I]
(TERPRI)
(RETURN T])
(WhichRule?
[LAMBDA (obj varName classFlg) (* mjs: " 9-JUN-83 09:42")
(* * Returns the source code for the rule that set the variable named varName on object if an appropriate audit
record has been saved on the reason property of the variable.)
(PROG (auditRecord)
[SETQ auditRecord (COND
(classFlg (GetClassValue obj varName (QUOTE reason)))
(T (GetValue obj varName (QUOTE reason]
(RETURN (COND
((AND auditRecord (NEQ auditRecord NotSetValue))
(@ auditRecord rule])
)
(RPAQQ ↑rs NIL)
(RPAQQ ↑ws NIL)
(RPAQQ ↑caller NIL)
(RPAQQ ↑task NIL)
(RPAQQ reWindow NIL)
(RPAQQ reTraceWindow NIL)
(RPAQQ reInspectWindow NIL)
(RPAQ rsTraceFont (FONTCREATE (QUOTE GACHA)
8))
(CLDISABLE (QUOTE ↑))
(INTERRUPTCHAR 6 (LIST (FUNCTION RE)))
(DECLARE: EVAL@COMPILE
(PUTPROPS RunRS MACRO ((rs ws . args)
(APPLY* (COND
((LITATOM rs)
rs)
(T (GetObjectName rs)))
ws . args)))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA WRITETTY)
)
(PUTPROPS LOOPSRULES COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (10428 27555 (ListRuleSets 10438 . 12418) (MakeEditMenu 12420 . 12992) (REObject 12994
. 13171) (ReinstallRuleSets 13173 . 13619) (Rule.Print 13621 . 14180) (RuleSet.CompileRules 14182 .
14638) (RuleSet.CopyRules 14640 . 15421) (RuleSet.EditRules 15423 . 15858) (RuleSet.Off 15860 . 16318)
(RuleSet.On 16320 . 16689) (RuleSet.PPRules 16691 . 16911) (RuleSetMeta.New 16913 . 17672) (
RuleSetSource.CompileRules 17674 . 20009) (RuleSetSource.EditRules 20011 . 23459) (
RuleSetSource.GetSource 23461 . 24343) (RuleSetSource.PPRules 24345 . 24970) (SaveRules 24972 . 26916)
(SearchStackForWorkSpace 26918 . 27553)) (27849 45114 (CloseREWindow 27859 . 28165) (CountRules 28167
. 28676) (DefRSM 28678 . 30345) (GetRules 30347 . 31656) (MINUSMINUS 31658 . 31907) (PAUSE 31909 .
32404) (PLUSPLUS 32406 . 32642) (PutAuditRec 32644 . 33014) (PutClassAuditRec 33016 . 33373) (RE 33375
. 34804) (RE1 34806 . 36712) (REAskWhy 36714 . 37956) (REFocusRuleSet 37958 . 38550) (RETraceSelectFn
38552 . 39085) (RSGetFn 39087 . 39865) (RSPutFn 39867 . 40706) (RuleSetStop 40708 . 41148) (
RuleSetTransfer 41150 . 41971) (SetUpRE 41973 . 43391) (TraceLHS 43393 . 43749) (TraceRHS 43751 .
44113) (WRITETTY 44115 . 44528) (WhichRule? 44530 . 45112)))))
STOP