Fixed CloneInstructionIntoBlock

Fixed CloneInstructionIntoBlock

I fixed the duplicate-instance and message sends to use the proper instance
names instead of the straight id value.

;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; Contains rules associated with the act of actually scheduling instructions
; into blocks on the wavefront
;
; Written by Joshua Scoggins
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::AssertScheduleCPVIntoTargetBlock
         (object (is-a Wavefront)
                 (values $? ?e $?))
         (object (is-a Diplomat)
                 (id ?e)
                 (IsOpen TRUE))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (MovableCompensationPathVectors
                             $?cpvs&:(<> 0 (length$ $?cpvs))))
         =>
         (modify-instance ?agObj (MovableCompensationPathVectors))
         (progn$ (?cpv $?cpvs)
                 (assert (message (to wavefront-scheduling)
                                  (action determine-schedule-style)
                                  (arguments ?cpv => ?e)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsMove
         "This rule attempts to determine if the CPV should be moved into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted"
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;the two sets are the same
         (test (equal$ ?paths ?cpvPaths))
         =>
         ;change the action...nothing more :D
         (modify ?fct (action move-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsCompensate
         "This rule attempts to determine if the CPV should be copied into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted."
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;there are more paths in the CPV than in the block
         (test (subsetp ?paths ?cpvPaths))
         =>
         (modify ?fct (action clone-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::RemoveScheduleStyleForCPV
         (declare (salience 1))
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?i)
                 (Paths $?cpvPaths))
         (test (not (subsetp ?paths ?cpvPaths)))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionList $?il))
         =>
         ;TODO: Put code in here to delete a given instruction from the target
         ;      instruction list as well.
         ;
         ; Eventually, I will detect if we are in a loop. If we are then it is
         ; necessary to figure out which paths remain in the loop and those
         ; that exit.
         ;this should prevent a potential infinite loop
         ;(printout t "Preventing " ?i " from being scheduled into " ?e crlf)
         (retract ?fct)
         (bind ?ind (member$ ?i $?il))
         (if ?ind then (slot-delete$ ?agObj InstructionList ?ind ?ind)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::MoveInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last)
                              (Produces $?nBProds))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionPropagation $?agIP)
                           (ScheduledInstructions $?agSI)
                           (ReplacementActions $?agRA))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (ScheduleTargets $?cpvST)
                               (Aliases $?cpvAliases))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (Consumers $?niConsumers)
                             (class ?class))
         ?oldBlock <- (object (is-a BasicBlock)
                              (id ?otherBlock)
                              (Produces $?pBefore ?inst $?pRest)
                              (contents $?before ?inst $?rest))
         ;TODO: add another rule where we have to update the consumers list as
         ;      well
         =>
         (object-pattern-match-delay
           ;(printout t "Scheduled " ?inst " into " ?e crlf)
           (modify-instance ?terminator (TimeIndex (+ ?ti 1)))
           ;(modify-instance ?newBlock (Produces ?nBProds ?register))
           (modify-instance ?oldBlock (contents $?before $?rest)
                            (Produces $?pBefore $?pRest))
           ;(modify-instance ?cpvObject (Paths))
           (modify ?fct (action remove-evidence)
                   (arguments ?inst => $?niConsumers))
           (assert (message (to wavefront-scheduling)
                            (action recompute-block)
                            (arguments ?otherBlock)))
           (if (eq StoreInstruction ?class) then
             (modify-instance ?agObj
                              (ScheduledInstructions $?agSI ?inst ?register)
                              (ReplacementActions $?agRA ?inst ?inst !))
             ;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (contents $?blockBefore ?inst ?last))
             (modify-instance ?cpvObject
                              (Paths)
                              (ScheduleTargets ?cpvST ?e ?inst)
                              (Aliases $?cpvAliases ?inst ?e))
             (llvm-unlink-and-move-instruction-before ?nPtr ?tPtr)
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?inst)
             ;(slot-insert$ ?cpvObject Aliases 1 ?inst ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?inst !)
             else
             (bind ?newName (sym-cat movedinstruction. (gensym*) . ?inst))
             (modify-instance ?cpvObject (Paths)
                              (ScheduleTargets ?cpvST ?e ?newName)
                              (Aliases ?cpvAliases ?newName ?e))
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
             ;(slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (contents $?blockBefore ?newName ?last))
             (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
             ;purge the list of producers and consumers
             (duplicate-instance ?newInst to ?newName
                                 (id ?newName)
                                 (Name ?newName)
                                 (pointer ?newPtr)
                                 (Producers)
                                 (Consumers)
                                 (NonLocalDependencies)
                                 (LocalDependencies)
                                 (TimeIndex ?ti)
                                 (parent ?e))
             (llvm-move-instruction-before ?newPtr ?tPtr)
             (slot-insert$ ?oldBlock UnlinkedInstructions 1 ?inst)
             (modify-instance ?agObj (ReplacementActions $?agRA ?inst ?newName !)
                              (InstructionPropagation $?agIP ?inst ?newName ?e !)
                              (ScheduledInstructions $?agSI ?inst)))))
;(slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::CloneInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (Paths $?cpvPaths))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (class ?class))
         =>
         ;we also need to update all CPVs within
         (object-pattern-match-delay
           (bind ?newName (sym-cat compensation.copy. (gensym*) . ?inst))
           ;(printout t "Scheduled " ?inst " into " ?e " from " ?otherBlock
           ;            " as " ?newName crlf)
           (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
           ;purge the list of producers and consumers
           (duplicate-instance ?newInst to ?newName
                               (id ?newName)
                               (Name ?newName)
                               (pointer ?newPtr)
                               (parent ?e)
                               (TimeIndex (+ ?ti 1)))
           (llvm-move-instruction-before ?newPtr ?tPtr)
           ;we add the original name so that we don't have to do
           ; an insane number of updates to the CPVs that follow
           ; this object
           (if (eq StoreInstruction ?class) then
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             else
             (slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst))
           (slot-insert$ ?newBlock Produces 1 ?register)
           (modify-instance ?newBlock (contents $?blockBefore ?newName ?last))
           (slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
           (slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
           (slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
           (modify ?fct (action recompute-block)
                   (arguments ?otherBlock))
           (assert (message (to wavefront-scheduling)
                            (action reopen-blocks)
                            (arguments ?cpv)))
           (bind ?leftOvers (create$))
           (progn$ (?z ?cpvPaths)
                   (bind ?cPath (instance-address *
                                 (symbol-to-instance-name ?z)))
                   (if (not (member$ ?e (send ?cPath get-values))) then
                     (bind ?leftOvers (insert$ ?leftOvers 1 ?z))))
           (modify-instance ?cpvObject (Paths ?leftOvers))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-CLONE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't clone " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-MOVE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't move " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-SCHEDULE-STYLE
         (declare (salience -768))
         (message (to wavefront-scheduling)
                  (action determine-schedule-style)
                  (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p)
                 (Aliases $?aliases)
                 (Paths $?cpvPaths))
         ?pa <- (object (is-a PathAggregate)
                        (parent ?e))
         (object (is-a Instruction)
                 (id ?p)
                 (parent ?bb))
         (object (is-a BasicBlock)
                 (id ?e)
                 (parent ?r)
                 (Paths $?paths))
         (object (is-a Wavefront)
                 (parent ?r)
                 (values $?z)
                 (Closed $?y))
         (object (is-a Region)
                 (id ?r)
                 (Entrances ?x $?))
         (object (is-a BasicBlock)
                 (id ?x)
                 (Paths $?allPaths))
         =>
         (printout t "ERROR: Couldn't figure out scheduling stype for " ?p
                   " which is targeted for " ?e crlf
                   "Blocks on the wavefront = " ?z crlf
                   "Closed Blocks = " ?y crlf
                   "For reference ?cpvPaths = " ?cpvPaths crlf
                   "For reference aliases of ?cpv are = " $?aliases crlf
                   "For reference ?paths = " ?paths crlf
                   "Parent of " ?p " is " ?bb crlf
                   "Printing out the path aggregate for " ?p crlf )
         (send ?pa print)
         (progn$ (?apath ?allPaths)
                 (bind ?aObj (instance-name (symbol-to-instance-name ?apath)))
                 (printout t "  " ?apath " = " (send ?aObj get-contents) crlf))
         (facts)
         (halt))
;------------------------------------------------------------------------------

;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; Contains rules associated with the act of actually scheduling instructions
; into blocks on the wavefront
;
; Written by Joshua Scoggins
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::AssertScheduleCPVIntoTargetBlock
         (object (is-a Wavefront)
                 (values $? ?e $?))
         (object (is-a Diplomat)
                 (id ?e)
                 (IsOpen TRUE))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (MovableCompensationPathVectors
                             $?cpvs&:(<> 0 (length$ $?cpvs))))
         =>
         (modify-instance ?agObj (MovableCompensationPathVectors))
         (progn$ (?cpv $?cpvs)
                 (assert (message (to wavefront-scheduling)
                                  (action determine-schedule-style)
                                  (arguments ?cpv => ?e)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsMove
         "This rule attempts to determine if the CPV should be moved into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted"
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;the two sets are the same
         (test (equal$ ?paths ?cpvPaths))
         =>
         ;change the action...nothing more :D
         (modify ?fct (action move-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsCompensate
         "This rule attempts to determine if the CPV should be copied into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted."
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;there are more paths in the CPV than in the block
         (test (subsetp ?paths ?cpvPaths))
         =>
         (modify ?fct (action clone-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::RemoveScheduleStyleForCPV
         (declare (salience 1))
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?i)
                 (Paths $?cpvPaths))
         (test (not (subsetp ?paths ?cpvPaths)))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionList $?il))
         =>
         ;TODO: Put code in here to delete a given instruction from the target
         ;      instruction list as well.
         ;
         ; Eventually, I will detect if we are in a loop. If we are then it is
         ; necessary to figure out which paths remain in the loop and those
         ; that exit.
         ;this should prevent a potential infinite loop
         ;(printout t "Preventing " ?i " from being scheduled into " ?e crlf)
         (retract ?fct)
         (bind ?ind (member$ ?i $?il))
         (if ?ind then (slot-delete$ ?agObj InstructionList ?ind ?ind)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::MoveInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last)
                              (Produces $?nBProds))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionPropagation $?agIP)
                           (ScheduledInstructions $?agSI)
                           (ReplacementActions $?agRA))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (ScheduleTargets $?cpvST)
                               (Aliases $?cpvAliases))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (Consumers $?niConsumers)
                             (class ?class))
         ?oldBlock <- (object (is-a BasicBlock)
                              (id ?otherBlock)
                              (Produces $?pBefore ?inst $?pRest)
                              (contents $?before ?inst $?rest))
         ;TODO: add another rule where we have to update the consumers list as
         ;      well
         =>
         (object-pattern-match-delay
           ;(printout t "Scheduled " ?inst " into " ?e crlf)
           (modify-instance ?terminator (TimeIndex (+ ?ti 1)))
           ;(modify-instance ?newBlock (Produces ?nBProds ?register))
           (modify-instance ?oldBlock (contents $?before $?rest)
                            (Produces $?pBefore $?pRest))
           ;(modify-instance ?cpvObject (Paths))
           (modify ?fct (action remove-evidence)
                   (arguments ?inst => $?niConsumers))
           (assert (message (to wavefront-scheduling)
                            (action recompute-block)
                            (arguments ?otherBlock)))
           (if (eq StoreInstruction ?class) then
             (modify-instance ?agObj
                              (ScheduledInstructions $?agSI ?inst ?register)
                              (ReplacementActions $?agRA ?inst ?inst !))
             ;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (contents $?blockBefore ?inst ?last))
             (modify-instance ?cpvObject
                              (Paths)
                              (ScheduleTargets ?cpvST ?e ?inst)
                              (Aliases $?cpvAliases ?inst ?e))
             (llvm-unlink-and-move-instruction-before ?nPtr ?tPtr)
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?inst)
             ;(slot-insert$ ?cpvObject Aliases 1 ?inst ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?inst !)
             else
             (bind ?newName (sym-cat movedinstruction. (gensym*) . ?inst))
             (modify-instance ?cpvObject (Paths)
                              (ScheduleTargets ?cpvST ?e ?newName)
                              (Aliases ?cpvAliases ?newName ?e))
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
             ;(slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (contents $?blockBefore ?newName ?last))
             (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
             ;purge the list of producers and consumers
             (bind ?inst-addr (instance-address *
                               (symbol-to-instance-name ?inst)))
             (duplicate-instance ?inst-addr to ?newName
                                 (id ?newName)
                                 (Name ?newName)
                                 (pointer ?newPtr)
                                 (Producers)
                                 (Consumers)
                                 (NonLocalDependencies)
                                 (LocalDependencies)
                                 (TimeIndex ?ti)
                                 (parent ?e))
             (llvm-move-instruction-before ?newPtr ?tPtr)
             (slot-insert$ ?oldBlock UnlinkedInstructions 1 ?inst)
             (modify-instance ?agObj (ReplacementActions $?agRA ?inst ?newName !)
                              (InstructionPropagation $?agIP ?inst ?newName ?e !)
                              (ScheduledInstructions $?agSI ?inst)))))
;(slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::CloneInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (Paths $?cpvPaths))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (class ?class))
         =>
         ;we also need to update all CPVs within
         (object-pattern-match-delay
           (bind ?newName (sym-cat compensation.copy. (gensym*) . ?inst))
           ;(printout t "Scheduled " ?inst " into " ?e " from " ?otherBlock
           ;            " as " ?newName crlf)
           (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
           ;purge the list of producers and consumers
           (duplicate-instance ?inst to ?newName
                               (id ?newName)
                               (Name ?newName)
                               (pointer ?newPtr)
                               (parent ?e)
                               (TimeIndex (+ ?ti 1)))
           (llvm-move-instruction-before ?newPtr ?tPtr)
           ;we add the original name so that we don't have to do
           ; an insane number of updates to the CPVs that follow
           ; this object
           (if (eq StoreInstruction ?class) then
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             else
             (slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst))
           (slot-insert$ ?newBlock Produces 1 ?register)
           (modify-instance ?newBlock (contents $?blockBefore ?newName ?last))
           (slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
           (slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
           (slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
           (modify ?fct (action recompute-block)
                   (arguments ?otherBlock))
           (assert (message (to wavefront-scheduling)
                            (action reopen-blocks)
                            (arguments ?cpv)))
           (bind ?leftOvers (create$))
           (progn$ (?z ?cpvPaths)
                   (bind ?cPath (symbol-to-instance-name ?z))
                   (if (not (member$ ?e (send ?cPath get-contents))) then
                     (bind ?leftOvers (insert$ ?leftOvers 1 ?z))))
           (modify-instance ?cpvObject (Paths ?leftOvers))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-CLONE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't clone " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-MOVE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't move " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-SCHEDULE-STYLE
         (declare (salience -768))
         (message (to wavefront-scheduling)
                  (action determine-schedule-style)
                  (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p)
                 (Aliases $?aliases)
                 (Paths $?cpvPaths))
         ?pa <- (object (is-a PathAggregate)
                        (parent ?e))
         (object (is-a Instruction)
                 (id ?p)
                 (parent ?bb))
         (object (is-a BasicBlock)
                 (id ?e)
                 (parent ?r)
                 (Paths $?paths))
         (object (is-a Wavefront)
                 (parent ?r)
                 (values $?z)
                 (Closed $?y))
         (object (is-a Region)
                 (id ?r)
                 (Entrances ?x $?))
         (object (is-a BasicBlock)
                 (id ?x)
                 (Paths $?allPaths))
         =>
         (printout t "ERROR: Couldn't figure out scheduling stype for " ?p
                   " which is targeted for " ?e crlf
                   "Blocks on the wavefront = " ?z crlf
                   "Closed Blocks = " ?y crlf
                   "For reference ?cpvPaths = " ?cpvPaths crlf
                   "For reference aliases of ?cpv are = " $?aliases crlf
                   "For reference ?paths = " ?paths crlf
                   "Parent of " ?p " is " ?bb crlf
                   "Printing out the path aggregate for " ?p crlf )
         (send ?pa print)
         (progn$ (?apath ?allPaths)
                 (bind ?aObj (instance-name (symbol-to-instance-name ?apath)))
                 (printout t "  " ?apath " = " (send ?aObj get-contents) crlf))
         (facts)
         (halt))
;------------------------------------------------------------------------------


Added set_delete function and rule.

Added set_delete function and rule.

-> For facts that should be deleted after a certain time.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;			GLOBALS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defglobal ?*outlog* = t)
(defglobal ?*logLevel* = ERROR) ; INFO | WARNING | ERROR | DEBUG (print always)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;			FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deffunction log-message
	; Receives level and message chunks that would be concatenated.
	; Level is one of: INFO | WARNING | ERROR | DEBUG (print always)
	(?level ?msg1 $?msg2)

	(bind ?message ?msg1)
	(progn$ (?var $?msg2)
		(bind ?message (str-cat ?message ?var) )
	)
	(if (eq ?level DEBUG) then
		(printout ?*outlog* ?level ": " ?message crlf)
		(return)
	)
	(bind ?currentLogLevel 10)
	(bind ?lvl 10)
	(switch ?*logLevel*
		(case INFO then (bind ?currentLogLevel 0))
		(case ERROR then (bind ?currentLogLevel 20))
		(case WARNING then (bind ?currentLogLevel 10))
	)
	(switch ?level
		(case INFO then (bind ?lvl 0))
		(case ERROR then (bind ?lvl 20))
		(case WARNING then (bind ?lvl 10))
	)
	(if (>= ?lvl ?currentLogLevel) then
		(printout ?*outlog* ?level ": " ?message crlf)
	)
)

(deffunction setCmdTimer
	(?time ?cmd ?id)
	(python-call setCmdTimer ?time ?cmd ?id)
)

(deffunction setTimer
	; Receives time in miliseconds and a symbol to identify fact that indicates the timer ran off.
	(?time ?sym)
	(python-call setTimer ?time ?sym)
	(assert (timer_sent ?sym (time) (/ ?time 1000.0)))
)

(defrule clear_timers
	(declare (salience -1000))
	?t <-(BB_timer $?)
	=>
	(retract ?t)
)

(defrule delete_old_timers
	(declare (salience -1000))
	?t <-(timer_sent ? ?time ?duration)
	(test (>= (time) (+ ?time ?duration) ) )
	=>
	(retract ?t)
)

(defrule delete_old_timers
	(declare (salience -1000))
	?t <-(timer_sent ?sym ?time ?duration)
	(test (< (time) (+ ?time ?duration) ) )
	=>
	(retract ?t)
	(assert (timer_sent ?sym ?time ?duration))
)

(deffunction sleep
	; Receives time in miliseconds.
	; Prevents python from running during that time, even when messages are received.
	(?ms)
	(bind ?sym (gensym*))
	(python-call sleep ?ms ?sym)
	(halt)
)

(deffunction set_delete
	(?fact ?time_in_secs)
	(bind ?sym (gensym*))
	(setTimer (* ?time_in_secs 1000) ?sym)
	(assert
		(BB_set_delete ?fact ?sym)
	)
)

(defrule set_delete-delete_fact
	(BB_timer ?sym)
	?f <-(BB_set_delete ?fact ?sym)
	=>
	(retract ?f ?fact)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;			GLOBALS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defglobal ?*outlog* = t)
(defglobal ?*logLevel* = ERROR) ; INFO | WARNING | ERROR | DEBUG (print always)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;			FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deffunction log-message
	; Receives level and message chunks that would be concatenated.
	; Level is one of: INFO | WARNING | ERROR | DEBUG (print always)
	(?level ?msg1 $?msg2)

	(bind ?message ?msg1)
	(progn$ (?var $?msg2)
		(bind ?message (str-cat ?message ?var) )
	)
	(if (eq ?level DEBUG) then
		(printout ?*outlog* ?level ": " ?message crlf)
		(return)
	)
	(bind ?currentLogLevel 10)
	(bind ?lvl 10)
	(switch ?*logLevel*
		(case INFO then (bind ?currentLogLevel 0))
		(case ERROR then (bind ?currentLogLevel 20))
		(case WARNING then (bind ?currentLogLevel 10))
	)
	(switch ?level
		(case INFO then (bind ?lvl 0))
		(case ERROR then (bind ?lvl 20))
		(case WARNING then (bind ?lvl 10))
	)
	(if (>= ?lvl ?currentLogLevel) then
		(printout ?*outlog* ?level ": " ?message crlf)
	)
)

(deffunction setCmdTimer
	(?time ?cmd ?id)
	(python-call setCmdTimer ?time ?cmd ?id)
)

(deffunction setTimer
	; Receives time in miliseconds and a symbol to identify fact that indicates the timer ran off.
	(?time ?sym)
	(python-call setTimer ?time ?sym)
	(assert (timer_sent ?sym (time) (/ ?time 1000.0)))
)

(defrule clear_timers
	(declare (salience -1000))
	?t <-(BB_timer $?)
	=>
	(retract ?t)
)

(defrule delete_old_timers
	(declare (salience -1000))
	?t <-(timer_sent ? ?time ?duration)
	(test (> (time) (+ ?time ?duration) ) )
	=>
	(retract ?t)
)

(deffunction sleep
	; Receives time in miliseconds.
	; Prevents python from running during that time, even when messages are received.
	(?ms)
	(bind ?sym (gensym*))
	(python-call sleep ?ms ?sym)
	(halt)
)


Added WidgetEvent.clp

Added WidgetEvent.clp

A WidgetEvent object is a standard way to define event handlers for different
actions for a given widget.

;------------------------------------------------------------------------------
;Copyright (c) 2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; WidgetEvent.clp - Base class of all events to cause widgets to do things
;
; Written by Joshua Scoggins
; Started on 3/11/2013
;------------------------------------------------------------------------------
(defclass widget::WidgetEvent
 "Base class of all events in the widget library"
 (is-a Object)
 (slot event-name (type SYMBOL))
 (slot function-to-call (type SYMBOL))
 (message-handler raise-event primary))
;------------------------------------------------------------------------------
(defmessage-handler widget::WidgetEvent raise-event primary ($?args)
 (funcall ?self:function-to-call $?args))
;------------------------------------------------------------------------------

error: pathspec 'src/lib/widget/WidgetEvent.clp' did not match any file(s) known to git


- fixed a bug in fipa-requestWhen protocol

git-svn-id: 9643e93313b82f5e4da82d8413267a0daa4b5472@1468 2cd91b7d-3b21-0410-a5f4-f42db4f24360

; ===================================================
; Definition of rules that handle the protocol
; fipa-request-when for all possible performatives.
; ===================================================

(defrule fipa-requestWhen-error
	"Fires for agent-evaluation-error facts with protocol request and performative request."
	?message <- (agent-message
		(protocol "fipa-request-when")
		(performative "request-when")
	)
	(agent-evaluation-error
		(message ?message)
		(error ?error)
	)

	=>

	(bind ?receivers (prepare-receivers ?message))

	(assert
		(agent-message
			(receivers ?receivers)
			(performative "refuse")
			(content (str-cat (fact-slot-value ?message "content") crlf "\"" ?error "\""))
			(language (fact-slot-value ?message "language"))
			(encoding (fact-slot-value ?message "encoding"))
			(ontology (fact-slot-value ?message "ontology"))
			(protocol (fact-slot-value ?message "protocol"))
			(conversation-id (fact-slot-value ?message "conversation-id"))
			(in-reply-to (fact-slot-value ?message "reply-with"))
			(reply-with "")
			(reply-by 0)
			(timestamp (datetime2timestamp (now)))
			(incoming FALSE)
		)
	)
)

(defrule fipa-requestWhen
	"Fires for agent-message facts with protocol request-when and performative request-when that are not linked by an error."
	?message <- (agent-message
		(protocol "fipa-request-when")
		(performative "request-when")
		(processed TRUE)
	)
	(not
		(agent-evaluation-error
			(message ?message)
		)
	)

	=>

	(send-agree ?message "")

)

(defrule fipa-requestWhen-result
	"Fires for agent-requestWhen-result facts with protocol request-when and performative request-when."
	?message <- (agent-message
		(protocol "fipa-request-when")
		(performative "request-when")
	)
	?inform <- (agent-message
		(performative "inform")
		(sender ?sender)
		(receivers ?receivers)
		(content ?content)
	)
	(agent-requestWhen-result
		(message ?message)
		(result ?result)
	)
	(test (eq ?inform (fact-id ?result)))

	=>

	(bind ?senderName (fact-slot-value ?sender "name"))

	(bind ?receiverList (agent-identifiers-to-names ?receivers))

	(assert
		(agent-message
			(sender ?senderName)
			(receivers ?receiverList)
			(performative "inform")
			(content ?content)
			(language (fact-slot-value ?message "language"))
			(encoding (fact-slot-value ?message "encoding"))
			(ontology (fact-slot-value ?message "ontology"))
			(protocol (fact-slot-value ?message "protocol"))
			(conversation-id (fact-slot-value ?message "conversation-id"))
			(in-reply-to (fact-slot-value ?message "reply-with"))
			(reply-with "")
			(reply-by 0)
			(timestamp (datetime2timestamp (now)))
			(incoming FALSE)
		)
	)
)

; ===================================================
; Definition of rules that handle the protocol
; fipa-request-when for all possible performatives.
; ===================================================

(defrule fipa-requestWhen-error
	"Fires for agent-evaluation-error facts with protocol request and performative request."
	?message <- (agent-message
		(protocol "fipa-request-when")
		(performative "request-when")
	)
	(agent-evaluation-error
		(message ?message)
		(error ?error)
	)

	=>

	(bind ?receivers (prepare-receivers ?message))

	(assert
		(agent-message
			(receivers ?receivers)
			(performative "refuse")
			(content (str-cat (fact-slot-value ?message "content") crlf "\"" ?error "\""))
			(language (fact-slot-value ?message "language"))
			(encoding (fact-slot-value ?message "encoding"))
			(ontology (fact-slot-value ?message "ontology"))
			(protocol (fact-slot-value ?message "protocol"))
			(conversation-id (fact-slot-value ?message "conversation-id"))
			(in-reply-to (fact-slot-value ?message "reply-with"))
			(reply-with "")
			(reply-by 0)
			(timestamp (datetime2timestamp (now)))
			(incoming FALSE)
		)
	)
)

(defrule fipa-requestWhen
	"Fires for agent-message facts with protocol request-when and performative request-when that are not linked by an error."
	?message <- (agent-message
		(protocol "fipa-request-when")
		(performative "request-when")
		(processed TRUE)
	)
	(not
		(agent-evaluation-error
			(message ?message)
		)
	)

	=>

	(send-agree ?message "")

)

(defrule fipa-requestWhen-result
	"Fires for agent-requestWhen-result facts with protocol request-when and performative request-when."
	?message <- (agent-message
		(protocol "fipa-request-when")
		(performative "request-when")
	)
	?inform <- (agent-message
		(performative "inform")
		(sender ?sender)
		(receiver ?receivers)
		(content ?content)
	)
	(agent-requestWhen-result
		(message ?message)
		(result ?result)
	)
	(test (eq ?inform (fact-id ?result)))

	=>

	(bind ?senderName (fact-slot-value ?sender "name"))

	(bind ?receiverList (agent-identifiers-to-names ?receivers))

	(assert
		(agent-message
			(sender ?senderName)
			(receivers ?receiverList)
			(performative "inform")
			(content ?content)
			(language (fact-slot-value ?message "language"))
			(encoding (fact-slot-value ?message "encoding"))
			(ontology (fact-slot-value ?message "ontology"))
			(protocol (fact-slot-value ?message "protocol"))
			(conversation-id (fact-slot-value ?message "conversation-id"))
			(in-reply-to (fact-slot-value ?message "reply-with"))
			(reply-with "")
			(reply-by 0)
			(timestamp (datetime2timestamp (now)))
			(incoming FALSE)
		)
	)
)


Add an example

Add an example

(defimport builtins list)
(defimport builtins print)
(defimport time sleep)

(doseq
  [x (pmap
    (fn [x]
      (do
        (sleep 0.5)
        (print "+ x 1:" x)
        (+ x 1)))
    (pmap
      (fn [x]
        (do
          (print "* x x:" x)
          (* x x)))
      [0 1 2 3 4 5 6 7 8 9]))]
  (print x))

error: pathspec 'examples/pmap-example.clp' did not match any file(s) known to git


snapshot

snapshot

(deftemplate rocky
  (slot name))

(deftemplate boris
  (slot name))

(deftemplate natasha
  (slot name)
  (slot nemesis))

(defrule nemesis
  (rocky (name ?n&"rocky"))
  (natasha (name "natasha") (nemesis ?n))
  =>
  (printout t "nemesis fired!" crlf))

;  (defrule schtum
;    ?rocky <- (rocky (name "rocky"))
;    (boris (name "boris"))
;    ?natasha <- (natasha (name "natasha"))
;    =>
;    (retract ?rocky)
;    (retract ?natasha)
;    (printout t "schtum!" crlf))

; (defrule schtum-shared
;   (boris (name "boris"))
;   =>
;   (printout t "schtum-shared!" crlf))

; (defrule schtum-simple
;   ?f <- (rocky (name "rocky"))
;   =>
;   (retract ?f)
;   (printout t "schtum-simple!" crlf))

; (defrule no-patterns
;   =>
;   (printout t "no-patterns!" crlf))

(assert (rocky (name "rocky")))
(assert (natasha (name "natasha") (nemesis "rocky")))
(run)

(deftemplate rocky
  (slot name))

(deftemplate boris
  (slot name))

(deftemplate natasha
  (slot name)
  (slot nemesis))

;(defrule nemesis
;  (natasha (name "natasha") (nemesis "bullwinkle"))
;  =>
;  (printout t "nemesis fired!" crlf))

 (defrule schtum
   ?rocky <- (rocky (name "rocky"))
   (boris (name "boris"))
   ?natasha <- (natasha (name "natasha"))
   =>
   (retract ?rocky)
   (retract ?natasha)
   (printout t "schtum!" crlf))

; (defrule schtum-shared
;   (boris (name "boris"))
;   =>
;   (printout t "schtum-shared!" crlf))

; (defrule schtum-simple
;   ?f <- (rocky (name "rocky"))
;   =>
;   (retract ?f)
;   (printout t "schtum-simple!" crlf))

; (defrule no-patterns
;   =>
;   (printout t "no-patterns!" crlf))

;(reset)
;(assert (natasha (name "natasha") (nemesis "bullwinkle")))
;(retract (fact-id 1))
(reset)
(assert (rocky (name "rocky")))
(assert (boris (name "boris")))
(assert (natasha (name "natasha")))
(run)
;(assert (boris (name "boris")))
;(retract (fact-id 1))


Added logic.clp to contain the single rule necessary to run indirect passes

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
(defrule MAIN::run
 "Starts the process of invoking a pass within clips. The fact asserted is
 generated by LLVM and passed into CLIPS automatically."
 ?fct <- (passes $?passes)
 =>
 (retract ?fct)
 (assert (message (from MAIN) (to pipeline)
			 (action pass-description)
			 (arguments $?passes)))
 (focus pipeline))
;------------------------------------------------------------------------------

error: pathspec 'lib/durandal/modules/main/logic.clp' did not match any file(s) known to git


Fixed a bug where I put multifield instead of multislot

;------------------------------------------------------------------------------
;Copyright (c) 2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; GLConstantConversion.clp - an expert system that reads a define and generates
; conversion code for it.
;------------------------------------------------------------------------------
(defmodule types
           (export ?ALL))
;------------------------------------------------------------------------------
(defmodule identify-lines
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule convert-templates
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule build-groups
           (import types ?ALL))
;------------------------------------------------------------------------------
(defclass types::opened-file
  (is-a USER)
  (slot id)
  (slot index (type INTEGER) (range 0 ?VARIABLE))
  (message-handler next-index)
  (message-handler read-line)
  (message-handler close-file))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file next-index ()
                    (bind ?old ?self:index)
                    (bind ?self:index (+ ?old 1))
                    (return ?old))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file read-line ()
                    (readline ?self:id))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file close-file ()
                    (close ?self:id))
;------------------------------------------------------------------------------
(deftemplate types::file-line
             (slot index)
             (slot parent)
             (slot type)
             (multislot contents))
;------------------------------------------------------------------------------
(deftemplate types::heading-span
             "Defines a span between two different headings"
             (slot header-name)
             (multislot contents)
             (slot from)
             (slot to)
             (slot parent)
             (slot distance))
;------------------------------------------------------------------------------
(deftemplate types::message
             (slot from)
             (slot to)
             (slot action)
             (multislot arguments))
;------------------------------------------------------------------------------
(defclass types::line-entry
  (is-a USER)
  (slot id)
  (slot index)
  (slot parent)
  (slot type)
  (multifield contents))
;------------------------------------------------------------------------------
(defmessage-handler types::line-entry init after ()
                    (bind ?self:id (instance-name-to-symbol (instance-name ?self))))
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction types::get-input-form-factor ()
             (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule MAIN::open-target-file
         "This rule takes a fact of the above INPUT FORM and attempts to open the file"
         ?fct <- (parse constant file ?path)
         =>
         (bind ?name (gensym*))
         (retract ?fct)
         (if (open ?path ?name "r") then
           (make-instance of opened-file (id ?name) (index 0))
           (assert (read file ?name))
           (focus identify-lines convert-templates build-groups)
           else
           (printout t "ERROR: target file at " ?path " does not exist!" crlf
                     "Halting!" crlf)
           (halt)))
;------------------------------------------------------------------------------
(defrule identify-lines::build-file-line
         ?fct <- (read file ?fid)
         ?obj <- (object (is-a opened-file)
                         (id ?fid))
         =>
         (retract ?fct)
         (bind ?result (send ?obj read-line))
         (if (neq ?result EOF) then
           (assert (read file ?fid)
                   (file-line (index (send ?obj next-index))
                              (type UNKNOWN)
                              (parent ?fid)
                              (contents (explode$ ?result))))
           else
           (send ?obj close-file)
           (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(defrule identify-lines::retract-unknowns
         (declare (salience -10))
         ?f <- (file-line (type UNKNOWN))
         =>
         (retract ?f))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-heading-groups
         "Tags lines that consist of /* $? */ as group headings"
         ?f <- (file-line (type UNKNOWN)
                          (contents /* $? */))
         =>
         (modify ?f (type heading)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-entry-line
         "Tags lines that are defines and modifies the associated contents"
         ?f <- (file-line (type UNKNOWN)
                          (contents #define ?name ?))
         =>
         (modify ?f (type #define) (contents ?name)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-three-line-headers
         "Merges simple three line headings into one rule"
         ?f0 <- (file-line (index ?i)
                           (type UNKNOWN)
                           (contents /*))
         ?f1 <- (file-line (index ?i2&:(= ?i2 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents * $?c))
         ?f2 <- (file-line (index ?i3&:(= ?i3 (+ ?i 2)))
                           (type UNKNOWN)
                           (contents */))
         =>
         (retract ?f1 ?f2)
         (modify ?f0 (contents /* $?c */)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-glapi-calls
         "marks glapi calls"
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $? "(" $? ")"))
         =>
         (modify ?f (type GLAPI-DEF)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-potential-glapi-calls
         "Merges the next line of a GLAPI call if the line doesn't end with )"
         (declare (salience -1))
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $?vals "(" $?c)
                          (index ?i))
         (test (not (member$ ")" $?c)))
         ?f0 <- (file-line (index ?i0&:(= ?i0 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents $?contents))
         =>
         (retract ?f)
         (modify ?f0 (contents GLAPI $?vals "(" $?c $?contents)))
;------------------------------------------------------------------------------
(defrule identify-lines::define-header-spans-initial
         "Defines spans between headers"
         (declare (salience -3))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i)
                    (contents /* $?name */))
         (not (exists (heading-span (from ?i)
                                    (parent ?parent))))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?i2 ?i)))
         =>
         (bind ?difference (- ?i2 ?i))
         (if (> ?difference 0) then
           (assert (heading-span (header-name (implode$ $?name))
                                 (from ?i)
                                 (to ?i2)
                                 (parent ?parent)
                                 (distance ?difference)))))
;------------------------------------------------------------------------------
(defrule identify-lines::modify-header-spans-for-smaller-size
         "Retracts the heading-span in response to finding an earlier heading"
         ?f <- (heading-span (from ?i)
                             (to ?j)
                             (parent ?parent))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify ?f (to ?i2)
                 (distance (- ?i2 ?i))))
;------------------------------------------------------------------------------
(defrule convert-templates::convert-line-objects
         ?f <- (file-line (type ?t) (parent ?p) (index ?i)
                          (contents $?c))
         =>
         (retract ?f)
         (bind ?name (gensym*))
         (assert (message (to build-groups)
                          (action add-to-span)
                          (arguments ?name)))
         (make-instance ?name of line-entry
                        (type ?t)
                        (parent ?p)
                        (index ?i)
                        (contents $?c)))
;------------------------------------------------------------------------------
(defrule build-groups::build-grouping
         ?f <- (heading-span (from ?i)
                             (to ?i2)
                             (parent ?parent)
                             (contents $?c))
         (object (is-a line-entry)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify ?f (contents $?c ?id)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;Copyright (c) 2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; GLConstantConversion.clp - an expert system that reads a define and generates
; conversion code for it.
;------------------------------------------------------------------------------
(defmodule types
           (export ?ALL))
;------------------------------------------------------------------------------
(defmodule identify-lines
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule convert-templates
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule build-groups
           (import types ?ALL))
;------------------------------------------------------------------------------
(defclass types::opened-file
  (is-a USER)
  (slot id)
  (slot index (type INTEGER) (range 0 ?VARIABLE))
  (message-handler next-index)
  (message-handler read-line)
  (message-handler close-file))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file next-index ()
                    (bind ?old ?self:index)
                    (bind ?self:index (+ ?old 1))
                    (return ?old))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file read-line ()
                    (readline ?self:id))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file close-file ()
                    (close ?self:id))
;------------------------------------------------------------------------------
(deftemplate types::file-line
             (slot index)
             (slot parent)
             (slot type)
             (multifield contents))
;------------------------------------------------------------------------------
(deftemplate types::heading-span
             "Defines a span between two different headings"
             (slot header-name)
             (multislot contents)
             (slot from)
             (slot to)
             (slot parent)
             (slot distance))
;------------------------------------------------------------------------------
(deftemplate types::message
             (slot from)
             (slot to)
             (slot action)
             (multislot arguments))
;------------------------------------------------------------------------------
(defclass types::line-entry
  (is-a USER)
  (slot id)
  (slot index)
  (slot parent)
  (slot type)
  (multifield contents))
;------------------------------------------------------------------------------
(defmessage-handler types::line-entry init after ()
                    (bind ?self:id (instance-name-to-symbol (instance-name ?self))))
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction types::get-input-form-factor ()
             (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule MAIN::open-target-file
         "This rule takes a fact of the above INPUT FORM and attempts to open the file"
         ?fct <- (parse constant file ?path)
         =>
         (bind ?name (gensym*))
         (retract ?fct)
         (if (open ?path ?name "r") then
           (make-instance of opened-file (id ?name) (index 0))
           (assert (read file ?name))
           (focus identify-lines convert-templates build-groups)
           else
           (printout t "ERROR: target file at " ?path " does not exist!" crlf
                     "Halting!" crlf)
           (halt)))
;------------------------------------------------------------------------------
(defrule identify-lines::build-file-line
         ?fct <- (read file ?fid)
         ?obj <- (object (is-a opened-file)
                         (id ?fid))
         =>
         (retract ?fct)
         (bind ?result (send ?obj read-line))
         (if (neq ?result EOF) then
           (assert (read file ?fid)
                   (file-line (index (send ?obj next-index))
                              (type UNKNOWN)
                              (parent ?fid)
                              (contents (explode$ ?result))))
           else
           (send ?obj close-file)
           (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(defrule identify-lines::retract-unknowns
         (declare (salience -10))
         ?f <- (file-line (type UNKNOWN))
         =>
         (retract ?f))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-heading-groups
         "Tags lines that consist of /* $? */ as group headings"
         ?f <- (file-line (type UNKNOWN)
                          (contents /* $? */))
         =>
         (modify ?f (type heading)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-entry-line
         "Tags lines that are defines and modifies the associated contents"
         ?f <- (file-line (type UNKNOWN)
                          (contents #define ?name ?))
         =>
         (modify ?f (type #define) (contents ?name)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-three-line-headers
         "Merges simple three line headings into one rule"
         ?f0 <- (file-line (index ?i)
                           (type UNKNOWN)
                           (contents /*))
         ?f1 <- (file-line (index ?i2&:(= ?i2 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents * $?c))
         ?f2 <- (file-line (index ?i3&:(= ?i3 (+ ?i 2)))
                           (type UNKNOWN)
                           (contents */))
         =>
         (retract ?f1 ?f2)
         (modify ?f0 (contents /* $?c */)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-glapi-calls
         "marks glapi calls"
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $? "(" $? ")"))
         =>
         (modify ?f (type GLAPI-DEF)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-potential-glapi-calls
         "Merges the next line of a GLAPI call if the line doesn't end with )"
         (declare (salience -1))
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $?vals "(" $?c)
                          (index ?i))
         (test (not (member$ ")" $?c)))
         ?f0 <- (file-line (index ?i0&:(= ?i0 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents $?contents))
         =>
         (retract ?f)
         (modify ?f0 (contents GLAPI $?vals "(" $?c $?contents)))
;------------------------------------------------------------------------------
(defrule identify-lines::define-header-spans-initial
         "Defines spans between headers"
         (declare (salience -3))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i)
                    (contents /* $?name */))
         (not (exists (heading-span (from ?i)
                                    (parent ?parent))))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?i2 ?i)))
         =>
         (bind ?difference (- ?i2 ?i))
         (if (> ?difference 0) then
           (assert (heading-span (header-name (implode$ $?name))
                                 (from ?i)
                                 (to ?i2)
                                 (parent ?parent)
                                 (distance ?difference)))))
;------------------------------------------------------------------------------
(defrule identify-lines::modify-header-spans-for-smaller-size
         "Retracts the heading-span in response to finding an earlier heading"
         ?f <- (heading-span (from ?i)
                             (to ?j)
                             (parent ?parent))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify ?f (to ?i2)
                 (distance (- ?i2 ?i))))
;------------------------------------------------------------------------------
(defrule convert-templates::convert-line-objects
         ?f <- (file-line (type ?t) (parent ?p) (index ?i)
                          (contents $?c))
         =>
         (retract ?f)
         (bind ?name (gensym*))
         (assert (message (to build-groups)
                          (action add-to-span)
                          (arguments ?name)))
         (make-instance ?name of line-entry
                        (type ?t)
                        (parent ?p)
                        (index ?i)
                        (contents $?c)))
;------------------------------------------------------------------------------
(defrule build-groups::build-grouping
         ?f <- (heading-span (from ?i)
                             (to ?i2)
                             (parent ?parent)
                             (contents $?c))
         (object (is-a line-entry)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify ?f (contents $?c ?id)))
;------------------------------------------------------------------------------


Deleted /src/module/engine/Object.clp

Deleted /src/module/engine/Object.clp

This class has been made redundant by cortex::Object

; Object.clp - Base class for all objects in Pathways
; See LICENSE for licensing details
; Written by Joshua Scoggins

(defclass engine::Object
 "Base class for all custom objects in pathways"
 (is-a USER)
 (slot id (type SYMBOL) (access initialize-only) (visibility public)))

(defmessage-handler engine::Object init around ()
 (call-next-handler)
 (bind ?self:id (instance-name-to-symbol (instance-name ?self))))


Added more decode rules

Added more decode rules

They're basically the same rule but with a different target. I will need to
eventually automate the process but at this point im not sure what would be the
best way to do that.

;------------------------------------------------------------------------------
;electron
;Copyright (c) 2012-2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of The Adventure Engine nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;-------------------------------------------------------------------------------
; Simulator.clp - Defines a simple computer to be executed through an expert
;                 system. This computer is unique in that instructions declare
;                 actions instead of perform actions directly.
;
;                 The Theoretical Architecture is an 8-bit declarative
;                 processor architecture. It has an 8-bit direct address space
;                 that can be extended through the use of jump instructions.
;-------------------------------------------------------------------------------
(defclass cell
  (is-a USER)
  (role abstract)
  (slot cell-type
        (type SYMBOL)
        (storage shared)
        (access read-only)
        (default unknown))
  (slot address
        (type INTEGER)
        (visibility public)
        (storage local)
        (range 0 ?VARIABLE))
  (slot value
        (type INTEGER)
        (range 0 255)
        (visibility public)
        (default-dynamic 0)))
(defclass memory-cell
  (is-a cell)
  (role concrete)
  (pattern-match reactive)
  (slot cell-type
        (source composite)
        (default memory)))

(defclass cache-cell
  (is-a cell)
  (role concrete)
  (pattern-match reactive)
  (slot address
        (source composite)
        (storage shared)
        (access initialize-only)
        (default 0))
  (slot cell-type
        (source composite)
        (default cache)))

(defclass register
  "Represents a storage location that is \"close\" to the procesor"
  (is-a USER)
  (slot offset
        (type INTEGER)
        (storage local)
        (default ?NONE))
  (slot value
        (type INTEGER)))

(defclass machine
  (is-a USER)
  (multislot registers
             (type INSTANCE)
             (allowed-classes register)))

(defgeneric next)
(defgeneric next-one)
(defgeneric next-two)
(defgeneric next-three)
(defmethod next
  ((?value NUMBER)
   (?count NUMBER (> ?count 3))
   (?inc NUMBER (!= ?inc 1)))
  (bind ?out (create$))
  (loop-for-count (?i 1 ?count) do
                  (bind ?out (create$ ?out (+ ?value (* ?i ?inc)))))
  (return ?out))

(defmethod next
  ((?value NUMBER)
   (?count NUMBER (> ?count 3))
   (?inc NUMBER (= ?inc 1)))
  (bind ?out (create$))
  (loop-for-count (?i 1 ?count) do
                  (bind ?out (create$ ?out (+ ?value ?i))))
  (return ?out))
(defmethod next
  ((?value NUMBER)
   (?count NUMBER (= ?count 1))
   (?inc NUMBER))
  (create$ (+ ?value ?inc)))
(defmethod next
  ((?value NUMBER)
   (?count NUMBER (= ?count 2))
   (?inc NUMBER (!= ?count 1)))
  (create$ (+ ?value ?inc)
           (+ ?value ?inc ?inc)))
(defmethod next
  ((?value NUMBER)
   (?count NUMBER (= ?count 2))
   (?inc NUMBER (= ?count 1)))
  (create$ (+ ?value 1)
           (+ ?value 2)))

(defmethod next
  ((?value NUMBER)
   (?count NUMBER (= ?count 3))
   (?inc NUMBER (!= ?count 1)))
  (create$ (+ ?value ?inc)
           (+ ?value ?inc ?inc)
           (+ ?value ?inc ?inc ?inc)))

(defmethod next
  ((?value NUMBER)
   (?count NUMBER (= ?count 3))
   (?inc NUMBER (= ?count 1)))
  (create$ (+ ?value 1)
           (+ ?value 2)
           (+ ?value 3)))

(defmethod next
  ((?value NUMBER)
   (?count NUMBER))
  (next ?value ?count 1))

(defmethod next-one
  ((?value NUMBER)
   (?inc NUMBER))
  (next ?value 1 ?inc))

(defmethod next-one
  ((?value NUMBER))
  (next ?value 1 1))

(defmethod next-two
  ((?value NUMBER)
   (?inc NUMBER))
  (next ?value 2 ?inc))

(defmethod next-two
  ((?value NUMBER))
  (next ?value 2 1))

(defmethod next-three
  ((?value NUMBER)
   (?inc NUMBER))
  (next ?value 3 ?inc))

(defmethod next-three
  ((?value NUMBER))
  (next ?value 3 1))
;TODO: automate the generation of the register set
(defrule setup-machine
         (initial-fact)
         =>
         (bind ?registers (instance-name (make-instance pc of register (offset 256))))
         (loop-for-count (?i 0 255) do
                         (bind ?registers (create$ ?registers (instance-name (make-instance (sym-cat r ?i) of register (offset ?i))))))
         (make-instance proc of machine
                        (registers ?registers))
         (assert (Machine setup)))
(defrule load-program-into-memory
         ?s <- (Machine setup)
         ?f <- (load ?program-path into memory)
         =>
         (retract ?s ?f)
         ;build the memory cells right now
         (if (open ?program-path file "r") then
           (bind ?this (get-char file))
           (bind ?i 0)
           (while (!= ?this -1) do
                  (make-instance of memory-cell
                                 (address ?i)
                                 (value ?this))
                  (bind ?this (get-char file))
                  (bind ?i (+ ?i 1)))
           (close file)
           (assert (stage decode execute restart))
           else
           (printout t "ERROR: Couldn't load program" crlf)
           (halt)))
(defrule next-stage
         (declare (salience -10000))
         ?f <- (stage ? $?rest)
         =>
         (retract ?f)
         (if (> (length$ ?rest) 0) then
           (assert (stage $?rest))))
(defrule load-instruction-into-decoder
         (stage decode $?)
         (object (is-a register)
                 (name [pc])
                 (value ?location))
         (object (is-a memory-cell)
                 (address ?location)
                 (value ?operation))
         =>
         ;tee hee, silly computer scientist, it's not a fixed
         ;decoder location :D. But it will serve our purposes
         ;well.
         (assert (invoke operation ?operation at ?location)))

(defrule decode:invalid
         (declare (salience -1))
         (stage decode $?)
         ?f <- (invoke operation ? at ?)
         =>
         (retract ?f)
         (printout t "ERROR: Target operation is not valid" crlf)
         (halt))

; MACHINE SPECIFIC DESCRIPTION CODE FOLLOWS:
; With the exception of one instruction, the rest of the instruction
; set operates on available registers (which is why there are 255 of
; them). This only applies to the externally visible instruction set
; which is transformed internally to provide on the fly optimizations.
;
; This is the basis of the procedurally declarative processor design
; I'm implementing. Eventually, this will have more features but at
; this point it is important to get a basic implementation.
;
; TODO: Modify the instruction set to define the program counter
(defglobal MAIN
           ; finding a zero will cause the processor to terminate instruction
           ; execution
           ?*terminate-instruction* = 0
           ?*nop-instruction* = 1
           ?*add-instruction* = 2
           ?*subtract-instruction* = 3
           ?*multiply-instruction* = 4
           ?*divide-instruction* = 5
           ?*right-shift-instruction* = 6
           ?*left-shift-instruction* = 7
           ?*equal-instruction* = 8
           ?*not-equal-instruction* = 9
           ?*less-than-instruction* = 10
           ?*greater-than-instruction* = 11
           ?*and-instruction* = 12
           ?*or-instruction* = 13
           ?*not-instruction* = 14
           ?*branch-instruction* = 15
           ; load r1 <= [r2] is the only supported load instruction
           ?*load-instruction* = 16
           ; store [r1] <= r2 is the only supported store instruction
           ?*store-instruction* = 17
           ; set r1 <= constant is the only immediate operation in the
           ; instruction set
           ?*set-instruction* = 18
           ; system r1
           ?*interrupt-instruction* = 250
           )
(defrule decode:nop
         "defines a nop instruction"
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?x ?*nop-instruction*) at ?)
         =>
         (retract ?f)
         (assert (nop)))

(defrule decode:load
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?*load-instruction* ?x) at ?loc)
         =>
         (retract ?f)
         (assert (load (next-two ?loc))))

(defrule decode:store
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?x ?*store-instruction*) at ?loc)
         =>
         (retract ?f)
         (assert (store (next-two ?loc))))

(defrule decode:add
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?x ?*add-instruction*) at ?loc)
         =>
         (retract ?f)
         (assert (add (next-three ?loc))))

(defrule decode:subtract
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?x ?*subtract-instruction*) at ?loc)
         =>
         (retract ?f)
         (assert (subtract (next-three ?loc))))

(defrule decode:multiply
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?x ?*multiply-instruction*) at ?loc)
         =>
         (retract ?f)
         (assert (multiply (next-three ?loc))))

(defrule decode:divide
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?x ?*divide-instruction*) at ?loc)
         =>
         (retract ?f)
         (assert (divide (next-three ?loc))))

(defrule decode:equal
         (stage decode $?)
         ?f <- (invoke operation ?x&:(= ?x ?*equal-instruction*) at ?loc)
         =>
         (retract ?f)
         (assert (equal (next-three ?loc))))

; NOTES
; the encoding of this processor can change from time to time but my
; current idea is to have a 255 byte window that represents a set of
; actions to be performed by the machine itself. This isn't valid at
; this point but I may come back to this at another point

;------------------------------------------------------------------------------
;electron
;Copyright (c) 2012-2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of The Adventure Engine nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;-------------------------------------------------------------------------------
; Simulator.clp - Defines a simple computer to be executed through an expert
;                 system. This computer is unique in that instructions declare
;                 actions instead of perform actions directly.
;
;                 The Theoretical Architecture is an 8-bit declarative
;                 processor architecture. It has an 8-bit direct address space
;                 that can be extended through the use of jump instructions.
;-------------------------------------------------------------------------------
(defclass cell
  (is-a USER)
  (role abstract)
  (slot cell-type
        (type SYMBOL)
        (storage shared)
        (access read-only)
        (default unknown))
  (slot address
        (type INTEGER)
        (visibility public)
        (storage local)
        (range 0 ?VARIABLE))
  (slot value
        (type INTEGER)
        (range 0 255)
        (visibility public)
        (default-dynamic 0)))
(defclass memory-cell
  (is-a cell)
  (role concrete)
  (slot cell-type
        (source composite)
        (default memory)))

(defclass cache-cell
  (is-a cell)
  (role concrete)
  (slot address
        (source composite)
        (storage shared)
        (access initialize-only)
        (default 0))
  (slot cell-type
        (source composite)
        (default cache)))

(defclass register
  "Represents a storage location that is \"close\" to the procesor"
  (is-a USER)
  (slot offset
        (type INTEGER)
        (storage local)
        (default ?NONE))
  (slot value
        (type INTEGER)))

(defclass machine
  (is-a USER)
  (multislot registers
             (type INSTANCE)
             (allowed-classes register)))
;TODO: automate the generation of the register set
(defrule setup-machine
         (initial-fact)
         =>
         (bind ?registers (instance-name (make-instance pc of register (offset 256))))
         (loop-for-count (?i 0 255) do
                         (bind ?registers (create$ ?registers (instance-name (make-instance (sym-cat r ?i) of register (offset ?i))))))
         (make-instance proc of machine
                        (registers ?registers))
         (assert (Machine setup)))
(defrule load-program-into-memory
         ?s <- (Machine setup)
         ?f <- (load ?program-path into memory)
         =>
         (retract ?s ?f)
         ;build the memory cells right now
         (if (open ?program-path file "r") then
           (bind ?this (get-char file))
           (bind ?i 0)
           (while (!= ?this -1) do
                  (make-instance of memory-cell
                                 (address ?i)
                                 (value ?this))
                  (bind ?this (get-char file))
                  (bind ?i (+ ?i 1)))
           (close ?file)
           (assert (stage decode execute restart))
           else
           (printout t "ERROR: Couldn't load program" crlf)
           (halt)))
(defrule next-stage
         (declare (salience -10000))
         ?f <- (stage ? $?rest)
         =>
         (retract ?f)
         (if (> (length$ ?rest) 0) then
           (assert (stage $?rest))))
(defrule load-instruction-into-decoder
         (stage decode $?)
         (object (is-a register)
                 (name [pc])
                 (value ?location))
         (object (is-a memory-cell)
                 (address ?location)
                 (value ?operation))
         =>
         ;tee hee, silly computer scientist, it's not a fixed
         ;decoder location :D. But it will serve our purposes
         ;well.
         (assert (invoke operation ?operation at ?location)))

(defrule decode:invalid
         (declare (salience -1))
         (stage decode $?)
         ?f <- (invoke operation ? at ?)
         =>
         (retract ?f)
         (printout t "ERROR: Target operation is not valid" crlf)
         (halt))
; MACHINE SPECIFIC DESCRIPTION CODE FOLLOWS:
; With the exception of one instruction, the rest of the instruction
; set operates on available registers (which is why there are 255 of
; them). This only applies to the externally visible instruction set
; which is transformed internally to provide on the fly optimizations.
;
; This is the basis of the procedurally declarative processor design
; I'm implementing. Eventually, this will have more features but at
; this point it is important to get a basic implementation.
;
; TODO: Modify the instruction set to define the program counter
(defglobal MAIN
 ; finding a zero will cause the processor to terminate instruction
 ; execution
 ?*terminate-instruction* = 0
 ?*nop-instruction* = 1
 ?*add-instruction* = 2
 ?*subtract-instruction* = 3
 ?*multiply-instruction* = 4
 ?*divide-instruction* = 5
 ?*right-shift-instruction*= 6
 ?*left-shift-instruction* = 7
 ?*equal-instruction* = 8
 ?*not-equal-instruction* = 9
 ?*less-than-instruction* = 10
 ?*greater-than-instruction* = 11
 ?*and-instruction* = 12
 ?*or-instruction* = 13
 ?*not-instruction* = 14
 ; uses a register as a predicate
 ; br r1 [r2]
 ?*branch-instruction* = 15
 ; load r1 <= [r2] is the only supported load instruction
 ?*load-instruction* = 16
 ; store [r1] <= r2 is the only supported store instruction
 ?*store-instruction* = 17
 ; set r1 <= constant is the only immediate operation in the
 ; instruction set
 ?*set-instruction* = 18
 ; system r1
 ?*interrupt-instruction* = 250
 ?*terminate-instruction* = 255)
(defrule decode:nop
 "defines a nop instruction"
 (stage decode $?)
 ?f <- (invoke operation 0 at ?location)
 =>
 (retract ?f)
 (assert (nop)))

(defrule decode:load:base
 "the current operation is a load, further analysis required"
 (stage decode $?)
 ?f <- (invoke operation 1 at ?location)
 =>
 (retract ?f)
 (assert (determine:load ?location)))

(defrule decode:load:register<=immediate
 (stage decode $?)
 ?f <- (determine:load ?offset)
 ;grab the status code
 (object (is-a memory-cell)
         (address =(+ ?offset 1))
         (value 0))
 =>
 (retract ?f)
 (assert (load register<=immediate ?destl ?srcl)))
(defrule decode:load:register<=register-immediate
 (stage decode $?)
 ?f <- (load 1 ?destl ?srcl)
 =>
 (retract ?f)
 (assert (load register<=register-immediate ?destl ?srcl)))
(defrule decode:store:base
 (stage decode $?)
 ?f <- (invoke operation 2 at ?location
(defrule add-operation
 (stage execute $?)

; NOTES
; the encoding of this processor can change from time to time but my
; current idea is to have a 255 byte window that represents a set of
; actions to be performed by the machine itself. This isn't valid at
; this point but I may come back to this at another point


Added the interface slot to the message template

;------------------------------------------------------------------------------
;electron-filesystem
;Copyright (c) 2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of electron-filesystem nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; message.clp - Defines the standard message template. Useful for passing
; information between modules and making it possible to have reusable code.
;------------------------------------------------------------------------------
(deftemplate message
             "A standard way to pass information around"
             (slot interface)
             (slot to)
             (slot from)
             (slot action)
             (multislot contents))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;electron-filesystem
;Copyright (c) 2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of electron-filesystem nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; message.clp - Defines the standard message template. Useful for passing
; information between modules and making it possible to have reusable code.
;------------------------------------------------------------------------------
(deftemplate message
             "A standard way to pass information around"
             (slot to)
             (slot from)
             (slot action)
             (multislot contents))
;------------------------------------------------------------------------------