Added a rule to strip out blank lines

Added a rule to strip out blank lines

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
(defclass 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 opened-file next-index ()
 (bind ?old ?self:index)
 (bind ?self:index (+ ?old 1))
 (return ?old))
;------------------------------------------------------------------------------
(defmessage-handler opened-file read-line ()
 (readline ?self:id))
;------------------------------------------------------------------------------
(defmessage-handler opened-file close-file ()
 (close ?self:id))
;------------------------------------------------------------------------------
(deftemplate file-line
 (slot index)
 (slot parent)
 (multifield contents))
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction get-input-form-factor ()
 (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule 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))
 else
 (printout t "ERROR: target file at " ?path " does not exist!" crlf
  "Halting!" crlf)
 (halt)))
;------------------------------------------------------------------------------
(defrule 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))
           (parent ?fid)
           (contents (explode$ ?result))))
  else
  (send ?obj close-file)
  (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(defrule retract-blank-lines
 ?f <- (file-line (contents))
 =>
 (retract ?f))
;------------------------------------------------------------------------------


Fixed errors in LoopRegionMerging.clp

Fixed errors in LoopRegionMerging.clp

These errors include:
1) Needing to replace Contents with contents due to changes in slot names
2) Updating module names to use merging instead of building

;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.
;------------------------------------------------------------------------------
; LoopRegionMerging.clp - Contains rules that merge loops and regions together
; Written by Joshua Scoggins (6/26/2012)
;
; Major Rewrite started on 10/22/2012 to reflect changes made to
; LibExpertSystem
;------------------------------------------------------------------------------
; The first thing to understand is that LibExpertSystem will no longer be
; lifting a finger to assist us in merging loops and regions. I did a thought
; experiment and I realized that it will be easier this way to ensure proper
; merging and (by proxy) ordering.
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::ConstructFlatListForRegion
			"Creates a flat representation of the contents of the given region"
			(object (is-a Region) (id ?id) (contents $?z))
			(not (exists (object (is-a FlatList) (parent ?id))))
			=>
			(make-instance of FlatList (parent ?id))
			(assert (Populate FlatList of ?id with $?z)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-BasicBlock
			?f <- (Populate FlatList of ?id with ?first $?rest)
			?o <- (object (is-a FlatList) (parent ?id))
			(object (is-a BasicBlock) (id ?first))
			=>
			(slot-insert$ ?o contents 1 ?first)
			(retract ?f)
			(assert (Populate FlatList of ?id with $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-Region
			?f <- (Populate FlatList of ?id with ?first $?rest)
			?o <- (object (is-a FlatList) (parent ?id))
			(object (is-a Region) (id ?first))
			(object (is-a FlatList) (parent ?first) (id ?name))
			=>
			;Add the reference to FlatList for the time being until we have
			;finished constructing an entire flat list
			(slot-insert$ ?o contents 1 ?name)
			(retract ?f)
			(assert (Populate FlatList of ?id with $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::RetractFlatListConstruction
			?f <- (Populate FlatList of ? with)
			=>
			(retract ?f))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-expand::ExpandFlatListEntry
			"Takes a flat list and expands one of the elements of the contents if
			it turns out that element is another flat list"
			?id <- (object (is-a FlatList) (contents $?a ?b $?c))
			(object (is-a FlatList) (id ?b) (contents $?j))
			=>
			(modify-instance ?id (contents $?a $?j $?c)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnership
			"Asserts that a region owns another through a subset check. The first
			flat list is checked to see if it is a _proper_ subset of the second"
			?f0 <- (object (is-a FlatList) (id ?i0) (contents $?c0) (parent ?p0))
			?f1 <- (object (is-a FlatList) (id ?i1&~?i0) (contents $?c1)
								(parent ?p1))
			(test (and (subsetp ?c0 ?c1) (> (length$ ?c1) (length$ ?c0))))
			=>
			(assert (claim ?p1 owns ?p0)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnershipOfBlocks
			"This rule is used to assert ownership claims on basic blocks"
			?f0 <- (object (is-a FlatList) (parent ?p) (contents $? ?b $?))
			(object (is-a BasicBlock) (id ?b))
			=>
			(assert (claim ?p owns ?b)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimEquivalence
			"Asserts that two regions are equivalent if one flat list contains the
			same elements as a second one."
			?f0 <- (object (is-a FlatList) (id ?i0) (contents $?c0) (parent ?p0))
			?f1 <- (object (is-a FlatList) (id ?i1&~?i0) (contents $?c1)
								(parent ?p1))
			(test (and (subsetp ?c0 ?c1) (= (length$ ?c1) (length$ ?c0))))
			=>
			(assert (claim ?p1 equivalent ?p0)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::MergeClaimsOfEquivalence
			"It is possible for two facts of equivalence to actually be the same
			fact"
			(declare (salience -1))
			?f0 <- (claim ?a equivalent ?b)
			?f1 <- (claim ?b equivalent ?a)
			=>
			(retract ?f0 ?f1)
			(assert (claim ?a equivalent ?b)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopFirst
			"If we find an equivalence then it means that a loop and a region
			contain the same elements. Therefore the loop persists and the region
			dies. The loop is the first entry."
			(declare (salience 1))
			?f0 <- (claim ?a equivalent ?b)
			(object (is-a Loop) (id ?a))
			(object (is-a Region&~Loop) (id ?b))
			=>
			(retract ?f0)
			(assert (delete region ?b)
					  (replace ?b with ?a)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopSecond
			"If we find an equivalence then it means that a loop and a region
			contain the same elements. Therefore the loop persists and the region
			dies. The loop is the second entry."
			(declare (salience 1))
			?f0 <- (claim ?b equivalent ?a)
			(object (is-a Loop) (id ?a))
			(object (is-a Region&~Loop) (id ?b))
			=>
			(retract ?f0)
			(assert (delete region ?b)
					  (replace ?b with ?a)))
;------------------------------------------------------------------------------
; Now that we have asserted delete and replacement claims it's necessary to
; carry those claims out. First, we need to do the replacement actions
; We need to apply these changes to the flat lists associated with these
; objects to ensure that we do the proper replacement thing.
; What we do is we use those replacement facts to retract the ownership claims
;
; Then we go through and perform partial replacement on the flat lists
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-DeletionTargetClaimsAnother
			"We target claims of ownership that deal with a given region that has
			to be replaced by another due to equivalence"
			(declare (salience 1))
			?f0 <- (replace ?old with ?new)
			?f1 <- (claim ?old owns ?other)
			=>
			(retract ?f0 ?f1)
			(assert (claim ?new owns ?other)
					  (replace ?old with ?new)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-AnotherClaimsDeletionTarget
			(declare (salience 1))
			?f0 <- (replace ?old with ?new)
			?f1 <- (claim ?other owns ?old)
			=>
			(retract ?f0 ?f1)
			(assert (claim ?other owns ?new)
					  (replace ?old with ?new)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-NoMoreConvergence
			"Retract replacement facts because there are no more claims to worry
			about"
			?f0 <- (replace ?old with ?new)
			=>
			(retract ?f0))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::DeleteTargetRegion
			"Deletes the target region slated for deletion"
			?f0 <- (delete region ?r0)
			?region <- (object (is-a Region) (id ?r0))
			=>
			(retract ?f0)
			(unmake-instance ?region))
;------------------------------------------------------------------------------
(defrule loop-region-merging-cleanup-merger::DeleteFlatLists
			"Deletes all of the flat lists in a single rule fire"
			=>
			(progn$ (?fl (find-all-instances ((?list FlatList)) TRUE))
					  (unmake-instance ?fl)))
;------------------------------------------------------------------------------

;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.
;------------------------------------------------------------------------------
; LoopRegionMerging.clp - Contains rules that merge loops and regions together
; Written by Joshua Scoggins (6/26/2012)
;
; Major Rewrite started on 10/22/2012 to reflect changes made to
; LibExpertSystem
;------------------------------------------------------------------------------
; The first thing to understand is that LibExpertSystem will no longer be
; lifting a finger to assist us in merging loops and regions. I did a thought
; experiment and I realized that it will be easier this way to ensure proper
; merging and (by proxy) ordering.
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::ConstructFlatListForRegion
			"Creates a flat representation of the contents of the given region"
			(object (is-a Region) (id ?id) (Contents $?z))
			(not (exists (object (is-a FlatList) (parent ?id))))
			=>
			(make-instance of FlatList (parent ?id))
			(assert (Populate FlatList of ?id with $?z)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-BasicBlock
			?f <- (Populate FlatList of ?id with ?first $?rest)
			?o <- (object (is-a FlatList) (parent ?id))
			(object (is-a BasicBlock) (id ?first))
			=>
			(slot-insert$ ?o Contents 1 ?first)
			(retract ?f)
			(assert (Populate FlatList of ?id with $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-Region
			?f <- (Populate FlatList of ?id with ?first $?rest)
			?o <- (object (is-a FlatList) (parent ?id))
			(object (is-a Region) (id ?first))
			(object (is-a FlatList) (parent ?first) (id ?name))
			=>
			;Add the reference to FlatList for the time being until we have
			;finished constructing an entire flat list
			(slot-insert$ ?o Contents 1 ?name)
			(retract ?f)
			(assert (Populate FlatList of ?id with $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::RetractFlatListConstruction
			?f <- (Populate FlatList of ? with)
			=>
			(retract ?f))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-expand::ExpandFlatListEntry
			"Takes a flat list and expands one of the elements of the contents if
			it turns out that element is another flat list"
			?id <- (object (is-a FlatList) (Contents $?a ?b $?c))
			(object (is-a FlatList) (id ?b) (Contents $?j))
			=>
			(modify-instance ?id (Contents $?a $?j $?c)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnership
			"Asserts that a region owns another through a subset check. The first
			flat list is checked to see if it is a _proper_ subset of the second"
			?f0 <- (object (is-a FlatList) (id ?i0) (Contents $?c0) (parent ?p0))
			?f1 <- (object (is-a FlatList) (id ?i1&~?i0) (Contents $?c1)
								(parent ?p1))
			(test (and (subsetp ?c0 ?c1) (> (length$ ?c1) (length$ ?c0))))
			=>
			(assert (claim ?p1 owns ?p0)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnershipOfBlocks
			"This rule is used to assert ownership claims on basic blocks"
			?f0 <- (object (is-a FlatList) (parent ?p) (Contents $? ?b $?))
			(object (is-a BasicBlock) (id ?b))
			=>
			(assert (claim ?p owns ?b)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimEquivalence
			"Asserts that two regions are equivalent if one flat list contains the
			same elements as a second one."
			?f0 <- (object (is-a FlatList) (id ?i0) (Contents $?c0) (parent ?p0))
			?f1 <- (object (is-a FlatList) (id ?i1&~?i0) (Contents $?c1)
								(parent ?p1))
			(test (and (subsetp ?c0 ?c1) (= (length$ ?c1) (length$ ?c0))))
			=>
			(assert (claim ?p1 equivalent ?p0)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::MergeClaimsOfEquivalence
			"It is possible for two facts of equivalence to actually be the same
			fact"
			(declare (salience -1))
			?f0 <- (claim ?a equivalent ?b)
			?f1 <- (claim ?b equivalent ?a)
			=>
			(retract ?f0 ?f1)
			(assert (claim ?a equivalent ?b)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopFirst
			"If we find an equivalence then it means that a loop and a region
			contain the same elements. Therefore the loop persists and the region
			dies. The loop is the first entry."
			(declare (salience 1))
			?f0 <- (claim ?a equivalent ?b)
			(object (is-a Loop) (id ?a))
			(object (is-a Region&~Loop) (id ?b))
			=>
			(retract ?f0)
			(assert (delete region ?b)
					  (replace ?b with ?a)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopSecond
			"If we find an equivalence then it means that a loop and a region
			contain the same elements. Therefore the loop persists and the region
			dies. The loop is the second entry."
			(declare (salience 1))
			?f0 <- (claim ?b equivalent ?a)
			(object (is-a Loop) (id ?a))
			(object (is-a Region&~Loop) (id ?b))
			=>
			(retract ?f0)
			(assert (delete region ?b)
					  (replace ?b with ?a)))
;------------------------------------------------------------------------------
; Now that we have asserted delete and replacement claims it's necessary to
; carry those claims out. First, we need to do the replacement actions
; We need to apply these changes to the flat lists associated with these
; objects to ensure that we do the proper replacement thing.
; What we do is we use those replacement facts to retract the ownership claims
;
; Then we go through and perform partial replacement on the flat lists
;------------------------------------------------------------------------------
(defrule loop-region-building-flatlist-resolve::RemoveStaleClaims-DeletionTargetClaimsAnother
			"We target claims of ownership that deal with a given region that has
			to be replaced by another due to equivalence"
			(declare (salience 1))
			?f0 <- (replace ?old with ?new)
			?f1 <- (claim ?old owns ?other)
			=>
			(retract ?f0 ?f1)
			(assert (claim ?new owns ?other)
					  (replace ?old with ?new)))
;------------------------------------------------------------------------------
(defrule loop-region-building-flatlist-resolve::RemoveStaleClaims-AnotherClaimsDeletionTarget
			(declare (salience 1))
			?f0 <- (replace ?old with ?new)
			?f1 <- (claim ?other owns ?old)
			=>
			(retract ?f0 ?f1)
			(assert (claim ?other owns ?new)
					  (replace ?old with ?new)))
;------------------------------------------------------------------------------
(defrule loop-region-building-flatlist-resolve::RemoveStaleClaims-NoMoreConvergence
			"Retract replacement facts because there are no more claims to worry
			about"
			?f0 <- (replace ?old with ?new)
			=>
			(retract ?f0))
;------------------------------------------------------------------------------
(defrule loop-region-building-flatlist-resolve::DeleteTargetRegion
			"Deletes the target region slated for deletion"
			?f0 <- (delete region ?r0)
			?region <- (object (is-a Region) (id ?r0))
			=>
			(retract ?f0)
			(unmake-instance ?region))
;------------------------------------------------------------------------------
(defrule loop-region-building-cleanup-merger::DeleteFlatLists
			"Deletes all of the flat lists in a single rule fire"
			=>
			(progn$ (?fl (find-all-instances ((?list FlatList)) TRUE))
					  (unmake-instance ?fl)))
;------------------------------------------------------------------------------


Added the ProducersPropagation logic to the dependency-analysis pass

;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 dependency-analysis-modification-propagation::PropagateBlockProducers
			(object (is-a BasicBlock) (id ?b) (parent ?r)
					  (Produces $?produces))
			=>
			(assert (Give ?r from ?b the following produced items $?produces)))
;------------------------------------------------------------------------------
(defrule dependency-analysis-modification-propagation::PropagateRegionProducers-ParentExists
			?fct <- (Give ?r from ? the following produced items $?produced)
			?region <- (object (is-a Region) (id ?r) (parent ?p))
			(exists (object (is-a Region) (id ?p)))
			=>
			(retract ?fct)
			(assert (Give ?p from ?r the following produced items $?produced))
			(slot-insert$ ?region Produces 1 ?produced))
;------------------------------------------------------------------------------
(defrule dependency-analysis-modification-propagation::PropagateRegionProducers-ParentDoesntExist
			?fct <- (Give ?r from ? the following produced items $?produced)
			?region <- (object (is-a Region) (id ?r) (parent ?p))
			(not (exists (object (is-a Region) (id ?p))))
			=>
			(retract ?fct)
			(slot-insert$ ?region Produces 1 ?produced))
;------------------------------------------------------------------------------
(defrule dependency-analysis-modification-propagation::IdentifyNonLocalDependencies
			?i0 <- (object (is-a Instruction) (parent ?p) (id ?t0)
								(Operands $? ?op $?))
			(object (is-a ParentedObject) (id ?op) (parent ~?p))
			;(test (not (member$ ?op (send ?i0 get-NonLocalDependencies))))
			=>
			;since we don't copy the set of producers at the start anymore we
			;need this operation as well
			(slot-insert$ ?i0 Producers 1 ?op)
			(slot-insert$ ?i0 NonLocalDependencies 1 ?op))
;------------------------------------------------------------------------------

error: pathspec 'lib/durandal/passes/dependency-analysis/ProducersPropagation.clp' did not match any file(s) known to git


Added the Library entry point for the widget library

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Library.clp - Defines the widget module and loads all corresponding files.
;
; Written by Joshua Scoggins
; Started on 3/6/2013
;------------------------------------------------------------------------------
; Define the module
;------------------------------------------------------------------------------
(defmodule widget
			  (import cortex ?ALL)
			  (export ?ALL))
;------------------------------------------------------------------------------
; Load the corresponding types and functions
;------------------------------------------------------------------------------

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


Fixed bugs in lib/chicanery.clp

Fixed bugs in lib/chicanery.clp

(defclass native-pointer
  (is-a USER)
  (role abstract)
  (slot pointer-class
        (type LEXEME)
        (visibility public)
        (access read-only)
        (default nil))
  (slot pointer
        (type EXTERNAL-ADDRESS)
        (storage local)
        (visibility public))
  (message-handler init around)
  (message-handler build-pointer primary)
  (message-handler get-native-arguments primary))

(defmessage-handler native-pointer init around
                    ()
                    (call-next-handler)
                    (send ?self build-pointer))

(defmessage-handler native-pointer build-pointer primary
                    ()
                    (bind ?self:pointer
                          (new (dynamic-get pointer-class)
                               (expand$ (send ?self get-native-arguments)))))
(defgeneric quickpoint)
(defgeneric to-point)
(defclass point
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Point))
  (slot x
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (message-handler get-native-arguments primary))

(defmessage-handler point get-native-arguments primary ()
                    (create$ ?self:x ?self:y))

(defmethod quickpoint
  ((?x INTEGER)
   (?y INTEGER))
  (new Point ?x ?y))

(defmethod to-point
  ((?mf INTEGER MULTIFIELD (= (length$ ?mf) 2)))
  (quickpoint (expand$ ?mf)))

(defmethod to-point
  ((?mf INTEGER MULTIFIELD (> (length$ ?mf) 2)))
  (quickpoint (nth$ 1 ?mf)
              (nth$ 2 ?mf)))
(defmethod to-point
  (($?mf INTEGER (>= (length$ ?mf) 2)))
  (to-point ?mf))
(definstances default-points
              (ZP of point
                  (x 0)
                  (y 0)))

(defgeneric quickrect)
(defclass rectangle
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Rectangle))
  (slot x
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot bx
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot by
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (message-handler get-native-arguments primary))

(defmessage-handler rectangle get-native-arguments primary
                    ()
                    (create$ ?self:x ?self:y ?self:bx ?self:by))

(defmethod quickrect
  ((?x INTEGER)
   (?y INTEGER)
   (?bx INTEGER)
   (?by INTEGER))
  (new Rectangle ?x ?y ?bx ?by))

(defmethod quickrect
  ((?mf MULTIFIELD INTEGER (>= (length$ ?mf) 4)))
  (quickrect (expand$ (subseq$ ?mf 1 4))))

(defmethod quickrect
  (($?mf MULTIFIELD INTEGER (>= (length$ ?mf) 4)))
  (quickrect ?mf))

(definstances default-rectangle-types
              (pixel of rectangle
                     (x 0)
                     (y 0)
                     (bx 1)
                     (by 1)))

(defgeneric translate/standard-color)
(defgeneric intensity-to-cmap)
(defclass color
  (is-a USER)
  (slot red
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (slot green
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (slot blue
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (message-handler to-native-color primary))

(defmessage-handler color to-native-color primary
                    ()
                    (rgb-to-cmap ?self:red
                                 ?self:green
                                 ?self:blue))
(defmethod translate/standard-color
  ((?color LEXEME))
  (switch (lowcase (string-to-field ?color))
          (case opaque then 0)
          (case transparent then 1)
          (case black then 2)
          (case white then 3)
          (case red then 4)
          (case green then 5)
          (case blue then 6)
          (case cyan then 7)
          (case magenta then 8)
          (case yellow then 9)
          (case paleyellow then 10)
          (case darkyellow then 11)
          (case darkgreen then 12)
          (case palegreen then 13)
          (case medgreen then 14)
          (case darkblue then 15)
          (case palebluegreen then 16)
          (case paleblue then 17)
          (case bluegreen then 18)
          (case greygreen then 19)
          (case palegreygreen then 20)
          (case yellowgreen then 21)
          (case medblue then 22)
          (case greyblue then 23)
          (case palegreyblue then 24)
          (case purpleblue then 25)
          (case notacolor then 26)
          (case nofill then 27)
          (default 28)))

(defmethod get-standard-color
  ((?color LEXEME INSTANCE-NAME))
  (get-standard-color
    (translate/standard-color ?color)))

(defmethod intensity-to-cmap
  "Converts an intensity value to a greyscale color"
  ((?intensity INTEGER (<= 0 ?intensity 255)))
  (rgb-to-cmap ?intensity
               ?intensity
               ?intensity))

(defmethod rgb-to-cmap
  ((?tuple INTEGER MULTIFIELD (>= (length$ ?tuple) 3)))
  (rgb-to-cmap (nth$ 1 ?tuple)
               (nth$ 2 ?tuple)
               (nth$ 3 ?tuple)))

(defclass image
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Image))
  (slot rectangle
        (type INSTANCE)
        (allowed-classes rectangle)
        (storage local)
        (visibility public)
        (default ?NONE))
  (slot replicate
        (type SYMBOL)
        (allowed-symbols FALSE TRUE)
        (visibility public))
  (slot color
        (type INSTANCE INTEGER)
        (allowed-classes color)
        (storage local)
        (default-dynamic 0))
  (message-handler get-native-arguments primary))

(defmessage-handler image get-native-arguments primary
                    ()
                    (create$ (send ?self:rectangle get-pointer)
                             (if ?self:replicate then 1 else 0)
                             (if (instancep ?self:color) then
                               (send ?self:color to-native-color)
                               else
                               ?self:color)))
(defmethod screen/draw
  ((?r INSTANCE-NAME)
   (?src INSTANCE-NAME)
   (?mask INSTANCE-NAME)
   (?p INSTANCE-NAME))
  (screen/draw (instance-address ?r)
               (instance-address ?src)
               (instance-address ?mask)
               (instance-address ?p)))

(defmethod screen/draw
  ((?r INSTANCE-NAME)
   (?src INSTANCE-NAME)
   (?p INSTANCE-NAME))
  (screen/draw (instance-address ?r)
               (instance-address ?src)
               (instance-address ?p)))

(defmethod screen/draw
  ((?r rectangle)
   (?src image)
   (?mask image)
   (?p point))
  (screen/draw (send ?r get-pointer)
               (send ?src get-pointer)
               (send ?mask get-pointer)
               (send ?p get-pointer)))

(defmethod screen/draw
  ((?r rectangle)
   (?src image)
   (?p point))
  (screen/draw (send ?r get-pointer)
               (send ?src get-pointer)
               (new Image)
               (send ?p get-pointer)))

(defglobal MAIN
           ?*default-screen-flush-behavior* = TRUE)
(defmethod screen/flush
  ((?vis SYMBOL (not (neq ?vis TRUE FALSE))))
  (screen/flush (if ?vis then 1 else 0)))

(defmethod screen/flush
  ()
  (screen/flush ?*default-screen-flush-behavior*))

(defmethod screen/draw-text
  ((?p point)
   (?src image)
   (?sp point)
   (?str LEXEME))
  (screen/draw-text (send ?p get-pointer)
                    (send ?src get-pointer)
                    (send ?sp get-pointer)
                    ?str))

(defgeneric translate/kbd/query)
(defgeneric translate/mouse/buttons)
(defgeneric bool)
(defmethod bool ((?number INTEGER)) (if (= ?number 0) then FALSE else TRUE))

(defmethod translate/mouse/buttons
  ()
  ; Mouse combinations
  ; m.buttons & 1 => left-click
  ; m.buttons & 2 => middle-click
  ; m.buttons & 3 => left + middle
  ; m.buttons & 4 => right-click
  ; m.buttons & 5 => left + right
  ; m.buttons & 6 => middle + right
  ; m.buttons & 7 => left + middle + right
  (bind ?z (mouse/buttons))
  (return (create$
            (if (bool (binary-and ?z 1)) then button1 else (create$))
            (if (bool (binary-and ?z 2)) then button2 else (create$))
            (if (bool (binary-and ?z 4)) then button3 else (create$)))))

(defmethod translate/kbd/query
  ()
  ; This method has to be defined by the programmer because it is application
  ; specific. By default, if we don't know what the value is then just return
  ; the original rune value.
  (bind ?rune (kbd/query))
  (return (switch ?rune
                  (case -1 then NIL)
                  (case 0 then NIL)
                  (case 27 then ESC)
                  (case 61454 then UP)
                  (case 63488 then DOWN) ; Plan9's down :/
                  (case 128 then DOWN) ; this is the value I get for down
                  (case 61457 then LEFT)
                  (case 61458 then RIGHT)
                  (default ?rune))))
(defclass mouse
  (is-a USER)
  (multislot position
             (create-accessor read))
  (multislot buttons
             (create-accessor read))
  (slot timestamp
             (type INTEGER)
             (create-accessor read))
  (message-handler clear primary)
  (message-handler query primary))

(defmessage-handler mouse clear primary
                    ()
                    (bind ?self:position (create$))
                    (bind ?self:buttons (create$))
                    (bind ?self:timestamp 0))

(defmessage-handler mouse query primary
                    ()
                    (bind ?out (mouse/query))
                    (if ?out then
                      (bind ?self:position (bind ?tmp (mouse/position)))
                      (bind ?self:buttons (translate/mouse/buttons))
                      (bind ?self:timestamp (mouse/timestamp)))
                    (return ?out))

(definstances mouse-object
              (mouse of mouse))

(defclass keyboard
  (is-a USER)
  (multislot keys
             (type SYMBOL INTEGER)
             (create-accessor read))
  (slot length
        (type INTEGER)
        (create-accessor read))
  ; behavior slots
  ; should we append to the list of keys?
  (slot append-on-query
        (type SYMBOL)
        (allowed-symbols FALSE TRUE))
  ; Should we attempt to convert from raw codes to symbols?
  (slot raw-keycodes
        (type SYMBOL)
        (allowed-symbols FALSE TRUE))
  (message-handler clear primary)
  (message-handler query primary))

(defmessage-handler keyboard clear primary
                    ()
                    (slot-direct-delete$ keys 1 ?self:length)
                    (bind ?self:length 0))

(defmessage-handler keyboard query primary
                    "Get a key from the native runtime queue"
                    ()
                    (bind ?key (if ?self:raw-keycodes then
                                 (kbd/query)
                                 else
                                 (translate/kbd/query)))

                    (if ?self:append-on-query then
                      (slot-direct-insert$ keys
                                           (+ ?self:length 1)
                                           ?key)
                      (bind ?self:length (+ ?self:length 1))
                      else
                      (bind ?self:keys ?key)
                      (bind ?self:length 1))
                    (return ?key))

(definstances keyboard-interface
              (keyboard of keyboard))

(defgeneric quickmenu)
(defgeneric quickmenu/show)
(defgeneric translate-menu-id)
(defclass menu
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default menu))
  (multislot menu-entries
             (type LEXEME)
             (storage local)
             (visibility public)
             (default ?NONE))
  (message-handler get-native-arguments primary)
  (message-handler show-menu primary))

(defmessage-handler menu get-native-arguments primary
                    ()
                    ?self:menu-entries)
(defmessage-handler menu show-menu primary
                    "shows the target menu and translates it to the corresponding symbolic
                    representation"
                    (?button)
                    (translate-menu-id (menu/show ?self:pointer ?button)
                                       ?self:menu-entries))

(defmethod quickmenu/show
  "Construct a quick list and return a symbolic representation"
  ((?elements MULTIFIELD LEXEME)
   (?button INTEGER))
  (translate-menu-id (menu/show (quickmenu ?elements) ?button) ?elements))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  (($?entries LEXEME))
  (quickmenu ?entries))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  ((?entries MULTIFIELD LEXEME))
  (new menu (expand$ ?entries)))
(defmethod translate-menu-id
  "Handles the case when -1 is passed"
  ((?id INTEGER (= ?id -1))
   (?elements MULTIFIELD LEXEME))
  (return NIL))
(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER (> ?id -1))
   (?elements MULTIFIELD LEXEME))
  ; We are one indexed while libevent is zero indexed
  (return (nth$ (+ ?id 1) ?elements)))

(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER)
   ($?elements LEXEME))
  (translate-menu-id ?id ?elements))

; system initialization features
(defglobal MAIN
           ?*system-initialized* = FALSE)

(defrule initialize
         (declare (salience 10000))
         (initial-fact)
         =>
         (if (not ?*system-initialized*) then
           (eresized 0)
           (bind ?*system-initialized* TRUE)))

; on-resized handling

(defgeneric on-resized)

(defrule on-resized
         "library defined rule which calls the on-resized method"
         (declare (salience 10000))
         ?f <- (event resized new ?value)
         =>
         (retract ?f)
         (on-resized ?value))

(defclass native-pointer
  (is-a USER)
  (role abstract)
  (slot pointer-class
        (type LEXEME)
        (visibility public)
        (access read-only)
        (default nil))
  (slot pointer
        (type EXTERNAL-ADDRESS)
        (storage local)
        (visibility public))
  (message-handler init around)
  (message-handler build-pointer primary)
  (message-handler get-native-arguments primary))

(defmessage-handler native-pointer init around
                    ()
                    (call-next-handler)
                    (send ?self build-pointer))

(defmessage-handler native-pointer build-pointer primary
                    ()
                    (bind ?self:pointer
                          (new (dynamic-get pointer-class)
                               (expand$ (send ?self get-native-arguments)))))
(defgeneric quickpoint)
(defgeneric to-point)
(defclass point
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Point))
  (slot x
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (message-handler get-native-arguments primary))

(defmessage-handler point get-native-arguments primary ()
                    (create$ ?self:x ?self:y))

(defmethod quickpoint
  ((?x INTEGER)
   (?y INTEGER))
  (new Point ?x ?y))

(defmethod to-point
  ((?mf INTEGER MULTIFIELD (= (length$ ?mf) 2)))
  (quickpoint (expand$ ?mf)))

(defmethod to-point
  ((?mf INTEGER MULTIFIELD (> (length$ ?mf) 2)))
  (quickpoint (nth$ 1 ?mf)
              (nth$ 2 ?mf)))
(defmethod to-point
  (($?mf INTEGER (>= (length$ ?mf) 2)))
  (to-point ?mf))
(definstances default-points
              (ZP of point
                  (x 0)
                  (y 0)))

(defgeneric quickrect)
(defclass rectangle
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Rectangle))
  (slot x
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot bx
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot by
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (message-handler get-native-arguments primary))

(defmessage-handler rectangle get-native-arguments primary
                    ()
                    (create$ ?self:x ?self:y ?self:bx ?self:by))

(defmethod quickrect
  ((?x INTEGER)
   (?y INTEGER)
   (?bx INTEGER)
   (?by INTEGER))
  (new Rectangle ?x ?y ?bx ?by))

(defmethod quickrect
  ((?mf MULTIFIELD INTEGER (>= (length$ ?mf) 4)))
  (quickrect (expand$ (subseq$ ?mf 1 4))))

(defmethod quickrect
  (($?mf MULTIFIELD INTEGER (>= (length$ ?mf) 4)))
  (quickrect ?mf))

(definstances default-rectangle-types
              (pixel of rectangle
                     (x 0)
                     (y 0)
                     (bx 1)
                     (by 1)))

(defgeneric translate/standard-color)
(defgeneric intensity-to-cmap)
(defclass color
  (is-a USER)
  (slot red
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (slot green
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (slot blue
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (message-handler to-native-color primary))

(defmessage-handler color to-native-color primary
                    ()
                    (rgb-to-cmap ?self:red
                                 ?self:green
                                 ?self:blue))
(defmethod translate/standard-color
  ((?color LEXEME))
  (switch (lowcase (string-to-field ?color))
          (case opaque then 0)
          (case transparent then 1)
          (case black then 2)
          (case white then 3)
          (case red then 4)
          (case green then 5)
          (case blue then 6)
          (case cyan then 7)
          (case magenta then 8)
          (case yellow then 9)
          (case paleyellow then 10)
          (case darkyellow then 11)
          (case darkgreen then 12)
          (case palegreen then 13)
          (case medgreen then 14)
          (case darkblue then 15)
          (case palebluegreen then 16)
          (case paleblue then 17)
          (case bluegreen then 18)
          (case greygreen then 19)
          (case palegreygreen then 20)
          (case yellowgreen then 21)
          (case medblue then 22)
          (case greyblue then 23)
          (case palegreyblue then 24)
          (case purpleblue then 25)
          (case notacolor then 26)
          (case nofill then 27)
          (default 28)))

(defmethod get-standard-color
  ((?color LEXEME INSTANCE-NAME))
  (get-standard-color
    (translate/standard-color ?color)))

(defmethod intensity-to-cmap
  "Converts an intensity value to a greyscale color"
  ((?intensity INTEGER (<= 0 ?intensity 255)))
  (rgb-to-cmap ?intensity
               ?intensity
               ?intensity))

(defmethod rgb-to-cmap
  ((?tuple INTEGER MULTIFIELD (>= (length$ ?tuple) 3)))
  (rgb-to-cmap (nth$ 1 ?tuple)
               (nth$ 2 ?tuple)
               (nth$ 3 ?tuple)))

(defclass image
  (is-a native-pointer)
  (slot pointer-class
        (source composite)
        (default Image))
  (slot rectangle
        (type INSTANCE)
        (allowed-classes rectangle)
        (storage local)
        (visibility public)
        (default ?NONE))
  (slot replicate
        (type SYMBOL)
        (allowed-symbols FALSE TRUE)
        (visibility public))
  (slot color
        (type INSTANCE INTEGER)
        (allowed-classes color)
        (storage local)
        (default-dynamic 0))
  (message-handler get-native-arguments primary))

(defmessage-handler image get-native-arguments primary
                    ()
                    (create$ (send ?self:rectangle get-pointer)
                             (if ?self:replicate then 1 else 0)
                             (if (instancep ?self:color) then
                               (send ?self:color to-native-color)
                               else
                               ?self:color)))
(defmethod screen/draw
  ((?r rectangle)
   (?src image)
   (?mask image)
   (?p point))
  (screen/draw (send ?r get-pointer)
               (send ?src get-pointer)
               (send ?mask get-pointer)
               (send ?p get-pointer)))

(defmethod screen/draw
  ((?r rectangle)
   (?src image)
   (?p point))
  (screen/draw (send ?r get-pointer)
               (send ?src get-pointer)
               (new Image)
               (send ?p get-pointer)))

(defglobal MAIN
           ?*default-screen-flush-behavior* = TRUE)
(defmethod screen/flush
  ((?vis SYMBOL (not (neq ?vis TRUE FALSE))))
  (screen/flush (if ?vis then 1 else 0)))

(defmethod screen/flush
  ()
  (screen/flush ?*default-screen-flush-behavior*))

(defmethod screen/draw-text
  ((?p point)
   (?src image)
   (?sp point)
   (?str LEXEME))
  (screen/draw-text (send ?p get-pointer)
                    (send ?src get-pointer)
                    (send ?sp get-pointer)
                    ?str))

(defgeneric translate/kbd/query)
(defgeneric translate/mouse/buttons)
(defgeneric bool)
(defmethod bool ((?number INTEGER)) (if (= ?number 0) then FALSE else TRUE))

(defmethod translate/mouse/buttons
  ()
  ; Mouse combinations
  ; m.buttons & 1 => left-click
  ; m.buttons & 2 => middle-click
  ; m.buttons & 3 => left + middle
  ; m.buttons & 4 => right-click
  ; m.buttons & 5 => left + right
  ; m.buttons & 6 => middle + right
  ; m.buttons & 7 => left + middle + right
  (bind ?z (mouse/buttons))
  (return (create$
            (if (bool (binary-and ?z 1)) then button1 else (create$))
            (if (bool (binary-and ?z 2)) then button2 else (create$))
            (if (bool (binary-and ?z 4)) then button3 else (create$)))))

(defmethod translate/kbd/query
  ()
  ; This method has to be defined by the programmer because it is application
  ; specific. By default, if we don't know what the value is then just return
  ; the original rune value.
  (bind ?rune (kbd/query))
  (return (switch ?rune
                  (case -1 then NIL)
                  (case 0 then NIL)
                  (case 27 then ESC)
                  (case 61454 then UP)
                  (case 63488 then DOWN) ; Plan9's down :/
                  (case 128 then DOWN) ; this is the value I get for down
                  (case 61457 then LEFT)
                  (case 61458 then RIGHT)
                  (default ?rune))))
(defclass mouse
  (is-a USER)
  (multislot position
             (type INTEGER)
             (create-accessor read))
  (multislot buttons
             (type SYMBOL)
             (create-accessor read))
  (multislot timestamp
             (type INTEGER)
             (create-accessor read))
  (message-handler query primary))

(defmessage-handler mouse query primary
                    ()
                    (bind ?out (mouse/query))
                    (if ?out then
                      (bind ?self:position (bind ?tmp (mouse/position)))
                      (bind ?self:buttons
                            (translate/mouse/buttons (mouse/buttons)))
                      (bind ?self:timestamp (mouse/timestamp)))
                    (return ?out))
(definstances mouse-object
              (mouse of mouse))

(defclass keyboard
  (is-a USER)
  (multislot keys
             (type SYMBOL INTEGER)
             (create-accessor read))
  (slot length
        (type INTEGER)
        (create-accessor read))
  ; behavior slots
  ; should we append to the list of keys?
  (slot append-on-query
        (type SYMBOL)
        (allowed-symbols FALSE TRUE))
  ; Should we attempt to convert from raw codes to symbols?
  (slot raw-keycodes
        (type SYMBOL)
        (allowed-symbols FALSE TRUE))
  (message-handler clear primary)
  (message-handler query primary))

(defmessage-handler keyboard clear primary
                    ()
                    (bind ?self:keys (create$))
                    (bind ?self:length 0))

(defmessage-handler keyboard query primary
                    "Get a key from the native runtime queue"
                    ()
                    (bind ?key (if ?self:raw-keycodes then
                                 (kbd/query)
                                 else
                                 (translate/kbd/query)))

                    (if ?self:append-on-query then
                      (slot-direct-insert$ keys
                                           (+ ?self:index 1)
                                           ?key)
                      else
                      (bind ?self:keys (create$ ?key)))
                    (bind ?self:length (+ ?self:length 1))
                    (return ?key))

(definstances keyboard-interface
              (keyboard of keyboard))

(defgeneric quickmenu)
(defgeneric quickmenu/show)
(defgeneric translate-menu-id)
(defclass menu
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Menu))
  (multislot menu-entries
             (type LEXEME)
             (storage local)
             (visibility public)
             (default ?NONE))
  (message-handler get-native-arguments primary)
  (message-handler show-menu primary))

(defmessage-handler menu get-native-arguments primary
                    ()
                    ?self:menu-entries)
(defmessage-handler menu show-menu primary
                    "shows the target menu and translates it to the corresponding symbolic
                    representation"
                    (?button)
                    (translate-menu-id (menu/show ?self:pointer ?button)
                                       ?self:menu-elements))

(defmethod quickmenu/show
  "Construct a quick list and return a symbolic representation"
  ((?elements MULTIFIELD LEXEME)
   (?button INTEGER))
  (translate-menu-id (menu/show (quickmenu ?elements) ?button) ?elements))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  (($?entries LEXEME))
  (quickmenu ?entries))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  ((?entries MULTIFIELD LEXEME))
  (new menu (expand$ ?entries)))

(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER (> ?id -1))
   (?elements MULTIFIELD LEXEME))
  ; We are one indexed while libevent is zero indexed
  (return (nth$ (+ ?id 1) ?elements)))

(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER)
   ($?elements LEXEME))
  (translate-menu-id ?id ?elements))


Fixed bugs in WavefrontAdvancement.clp

Fixed bugs in WavefrontAdvancement.clp

;------------------------------------------------------------------------------
;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 wavefront-scheduling-advance-init::MoveContentsToDeleteNodes
         "Moves blocks out of the contents into the closed list"
         (declare (salience 2701))
         ?wave <- (object (is-a Wavefront)
                          (id ?z)
                          (parent ?r)
                          (values $?c)
                          (Closed $?cl))
         (test (or (> (length$ ?c) 0)
                   (> (length$ ?cl) 0)))
         =>
         (slot-insert$ ?wave DeleteNodes 1 ?c ?cl))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-advance-identify::MarkShouldStayOnWavefront
         (declare (salience 343))
         ?wave <- (object (is-a Wavefront)
                          (id ?q)
                          (parent ?r)
                          (DeleteNodes $?a ?b $?c)
                          (Closed $?clos)
                          (values $?contents))

         ?bb <- (object (is-a Diplomat)
                        (id ?b)
                        (NextPathElements ?s))
         (object (is-a Diplomat)
                 (id ?s)
                 (PreviousPathElements $?ppe))
         (test (not (subsetp ?ppe (create$ ?a ?b ?c))))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?b))
         =>
         (object-pattern-match-delay
           (if (not (member$ ?b $?clos)) then
             (bind ?ind (member$ ?b $?contents))
             (slot-delete$ ?wave Contents ?ind ?ind)
             (modify-instance ?wave (Closed $?clos ?b)
                              (DeleteNodes $?a $?c))
             else
             (modify-instance ?wave (DeleteNodes $?a $?c)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-advance::DeleteElementFromWavefront
         (declare (salience 180))
         ?wave <- (object (is-a Wavefront)
                          (id ?id)
                          (parent ?r)
                          (DeleteNodes ?a $?rest))
         (object (is-a Diplomat)
                 (id ?a)
                 (NextPathElements $?npe))
         =>
         ;TODO: Continue to port here
         (object-pattern-match-delay
           (bind ?ind (member$ ?a (send ?wave get-Contents)))
           (bind ?ind2 (member$ ?a (send ?wave get-Closed)))
           (modify-instance ?wave (DeleteNodes $?rest))
           (if ?ind then (slot-delete$ ?wave Contents ?ind ?ind))
           (if ?ind2 then (slot-delete$ ?wave Closed ?ind2 ?ind2))
           (assert (message (to wavefront-scheduling)
                            (action add-blocks-into)
                            (arguments ?id => $?npe)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-advance-end::PutSuccessorsOntoWavefront-Match
         ?fct <- (message (to wavefront-scheduling)
                          (action add-blocks-into)
                          (arguments ?id => ?next $?rest))
         ?wave <- (object (is-a Wavefront)
                          (id ?id)
                          (values $?contents))
         =>
         (modify ?fct (arguments ?id => $?rest))
         (if (not (member$ ?next $?contents)) then
           (modify-instance ?wave (contents $?contents ?next))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-advance-end::PutSuccessorsOntoWavefront-NoMoreElements
         ?fct <- (message (to wavefront-scheduling)
                          (action add-blocks-into)
                          (arguments ?id =>))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-update::PonderRestartOfWavefrontScheduling
         ?fct <- (message (to wavefront-scheduling-update)
                          (from pipeline)
                          (action initial-fact))
         ?obj <- (object (is-a pass-description)
                         (passes $?passes))
         =>
         (retract ?fct)
         (bind ?instances (find-all-instances ((?wave Wavefront))
                                              (> (length$ ?wave:values) 0)))
         (if (> (length$ ?instances) 0) then
           (modify-instance ?obj
                            (passes wavefront-scheduling-init
                                    wavefront-scheduling-identify
                                    wavefront-scheduling-phi-identify
                                    wavefront-scheduling-phi-node
                                    wavefront-scheduling-phi-node-update
                                    wavefront-scheduling-pathing
                                    wavefront-scheduling-strip
                                    wavefront-scheduling-inject
                                    wavefront-scheduling-acquire
                                    wavefront-scheduling-slice
                                    wavefront-scheduling-analyze-init
                                    wavefront-scheduling-pre-generate-analyze
                                    wavefront-scheduling-generate-analyze
                                    wavefront-scheduling-analyze
                                    wavefront-scheduling-slice-analyze
                                    wavefront-scheduling-merge-init
                                    wavefront-scheduling-merge
                                    wavefront-scheduling-merge-update
                                    wavefront-scheduling-reopen-blocks
                                    wavefront-scheduling-ponder
                                    wavefront-scheduling-post-ponder
                                    wavefront-scheduling-rename
                                    wavefront-scheduling-dependency-analysis
                                    wavefront-scheduling-advance-init
                                    wavefront-scheduling-advance-identify
                                    wavefront-scheduling-advance
                                    wavefront-scheduling-advance-end
                                    wavefront-scheduling-update
                                    $?passes))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-final::RetractUnlinkedInstructions
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (UnlinkedInstructions ?i $?rest))
         ?instruction <- (object (is-a Instruction)
                                 (id ?i)
                                 (parent ?b)
                                 (pointer ?ptr))
         (object (is-a PathAggregate)
                 (parent ?b)
                 (InstructionPropagation $? ?i ?new ?b ! $?))
         (object (is-a Instruction)
                 (id ?new)
                 (pointer ?nPtr))
         =>
         ;this is a little gross but it is a very easy way to ensure that
         ;things work correctly so that the LLVM ModuleVerifier doesn't come
         ;down like a hammer on what we're doing
         (object-pattern-match-delay
           (llvm-replace-all-uses ?ptr ?nPtr)
           (modify-instance ?bb (UnlinkedInstructions $?rest))
           (llvm-unlink-and-delete-instruction ?ptr)
           (unmake-instance ?instruction)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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 wavefront-scheduling-advance-init::MoveContentsToDeleteNodes
         "Moves blocks out of the contents into the closed list"
         (declare (salience 2701))
         ?wave <- (object (is-a Wavefront)
                          (id ?z)
                          (parent ?r)
                          (contents $?c)
                          (Closed $?cl))
         (test (or (> (length$ ?c) 0)
                   (> (length$ ?cl) 0)))
         =>
         (slot-insert$ ?wave DeleteNodes 1 ?c ?cl))
;------------------------------------------------------------------------------
(defrule wavefront-schedule-advance-identify::MarkShouldStayOnWavefront
         (declare (salience 343))
         ?wave <- (object (is-a Wavefront)
                          (id ?q)
                          (parent ?r)
                          (DeleteNodes $?a ?b $?c)
                          (Closed $?clos)
                          (contents $?contents))

         ?bb <- (object (is-a Diplomat)
                        (id ?b)
                        (NextPathElements ?s))
         (object (is-a Diplomat)
                 (id ?s)
                 (PreviousPathElements $?ppe))
         (test (not (subsetp ?ppe (create$ ?a ?b ?c))))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?b))
         =>
         (object-pattern-match-delay
           (if (not (member$ ?b $?clos)) then
             (bind ?ind (member$ ?b $?contents))
             (slot-delete$ ?wave Contents ?ind ?ind)
             (modify-instance ?wave (Closed $?clos ?b)
                              (DeleteNodes $?a $?c))
             else
             (modify-instance ?wave (DeleteNodes $?a $?c)))))
;------------------------------------------------------------------------------
(defrule wavefront-schedule-advance::DeleteElementFromWavefront
         (declare (salience 180))
         ?wave <- (object (is-a Wavefront)
                          (id ?id)
                          (parent ?r)
                          (DeleteNodes ?a $?rest))
         (object (is-a Diplomat)
                 (id ?a)
                 (NextPathElements $?npe))
         =>
         ;TODO: Continue to port here
         (object-pattern-match-delay
           (bind ?ind (member$ ?a (send ?wave get-Contents)))
           (bind ?ind2 (member$ ?a (send ?wave get-Closed)))
           (modify-instance ?wave (DeleteNodes $?rest))
           (if ?ind then (slot-delete$ ?wave Contents ?ind ?ind))
           (if ?ind2 then (slot-delete$ ?wave Closed ?ind2 ?ind2))
           (assert (message (to wavefront-scheduling)
                            (action add-blocks-into)
                            (arguments ?id => $?npe)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-advance-end::PutSuccessorsOntoWavefront-Match
         ?fct <- (message (to wavefront-scheduling)
                          (action add-blocks-into)
                          (arguments ?id => ?next $?rest))
         ?wave <- (object (is-a Wavefront)
                          (id ?id)
                          (contents $?contents))
         =>
         (modify ?fct (arguments ?id => $?rest))
         (if (not (member$ ?next $?contents)) then
           (modify-instance ?wave (contents $?contents ?next))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-advance-end::PutSuccessorsOntoWavefront-NoMoreElements
         ?fct <- (message (to wavefront-scheduling)
                          (action add-blocks-into)
                          (arguments ?id =>))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-update::PonderRestartOfWavefrontScheduling
         ?fct <- (message (to wavefront-scheduling-update)
                          (from pipeline)
                          (action initial-fact))
         ?obj <- (object (is-a pass-description)
                         (passes $?passes))
         =>
         (retract ?fct)
         (bind ?instances (find-all-instances ((?wave Wavefront))
                                              (> (length$ ?wave:contents) 0)))
         (if (> (length$ ?instances) 0) then
           (modify-instance ?obj
                            (passes wavefront-scheduling-init
                                    wavefront-scheduling-identify
                                    wavefront-scheduling-phi-identify
                                    wavefront-scheduling-phi-node
                                    wavefront-scheduling-phi-node-update
                                    wavefront-scheduling-pathing
                                    wavefront-scheduling-strip
                                    wavefront-scheduling-inject
                                    wavefront-scheduling-acquire
                                    wavefront-scheduling-slice
                                    wavefront-scheduling-analyze-init
                                    wavefront-scheduling-pre-generate-analyze
                                    wavefront-scheduling-generate-analyze
                                    wavefront-scheduling-analyze
                                    wavefront-scheduling-slice-analyze
                                    wavefront-scheduling-merge-init
                                    wavefront-scheduling-merge
                                    wavefront-scheduling-merge-update
                                    wavefront-scheduling-reopen-blocks
                                    wavefront-scheduling-ponder
                                    wavefront-scheduling-post-ponder
                                    wavefront-scheduling-rename
                                    wavefront-scheduling-dependency-analysis
                                    wavefront-scheduling-advance-init
                                    wavefront-scheduling-advance-identify
                                    wavefront-scheduling-advance
                                    wavefront-scheduling-advance-end
                                    wavefront-scheduling-update
                                    $?passes))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-final::RetractUnlinkedInstructions
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (UnlinkedInstructions ?i $?rest))
         ?instruction <- (object (is-a Instruction)
                                 (id ?i)
                                 (parent ?b)
                                 (pointer ?ptr))
         (object (is-a PathAggregate)
                 (parent ?b)
                 (InstructionPropagation $? ?i ?new ?b ! $?))
         (object (is-a Instruction)
                 (id ?new)
                 (pointer ?nPtr))
         =>
         ;this is a little gross but it is a very easy way to ensure that
         ;things work correctly so that the LLVM ModuleVerifier doesn't come
         ;down like a hammer on what we're doing
         (object-pattern-match-delay
           (llvm-replace-all-uses ?ptr ?nPtr)
           (modify-instance ?bb (UnlinkedInstructions $?rest))
           (llvm-unlink-and-delete-instruction ?ptr)
           (unmake-instance ?instruction)))
;------------------------------------------------------------------------------


Ported WavefrontPropagation.clp to the new format

;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 wavefront-scheduling-identify::PropagateAggregateInformation
         "Pulls instruction propagation information from all elements on paths
         that immediately precede this element on the wavefront and merges it
         into the path aggregate itself"
         (message (to wavefront-scheduling)
                  (action propagate-aggregates)
                  (arguments ?e))
         ;if this element is on the wavefront then we can be certain that all
         ;of it's predecessors are above it. That is the definition of being on
         ;the wavefront
         ?pa <- (object (is-a PathAggregate)
                        (parent ?e)
                        (InstructionPropagation $?ip))
         (object (is-a Diplomat)
                 (id ?e)
                 (PreviousPathElements $? ?z $?))
         (object (is-a PathAggregate)
                 (parent ?z)
                 (InstructionPropagation $? ?targ ?alias ? ! $?))
         =>
         ;replace parent blocks of previous path elements with the name of the
         ;element this was acquired from
         ;(printout t "Put (" ?targ " " ?alias " " ?z "! ) into " ?pp crlf)
         (modify-instance ?pa (InstructionPropagation $?ip ?targ ?alias ?z !)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-identify::RetractAggregationInformation
         (declare (salience -50))
         ?fct <- (message (to wavefront-scheduling)
                          (action propagate-aggregates)
                          (arguments ?))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-identify::AssertPhiNodePropagationPredicateIsBlock
         (declare (salience 1))
         (object (is-a Wavefront)
                 (parent ?r)
                 (contents $? ?e $?))
         ?pa <- (object (is-a PathAggregate)
                        (parent ?e)
                        (InstructionPropagation ?targ ?alias ?pred ! $?rest))
         =>
         (modify-instance ?pa (InstructionPropagation $?rest))
         (assert (message (to wavefront-scheduling)
                          (action propagation-target)
                          (arguments target ?targ
                                     alias ?alias
                                     from ?pred
                                     for ?e))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-node::RemoveDuplicateElements
         "Removes propagation targets that represent the same value but come from
         different previous blocks/regions. When this is seen it's not necessary to
         create a phi node. This is evident because the aliases are the same across
         multiple paths of execution."
         ?f0 <- (message (to wavefront-scheduling)
                         (action propagation-target)
                         (arguments target ?t
                                    alias ?a
                                    from ?p0
                                    for ?b))
         ?f1 <- (message (to wavefront-scheduling)
                         (action propagation-target)
                         (arguments target ?t
                                    alias ?a
                                    from ?p1&~?p0
                                    for ?b))
         ?pa <- (object (is-a PathAggregate)
                        (parent ?b)
                        (InstructionPropagation $?ip))
         =>
         (retract ?f0 ?f1)
         (modify-instance ?pa (InstructionPropagation $?ip ?t ?a ?b !)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-node::MergePhiNodePropagationWithOtherPropagation
         ?f0 <- (message (to wavefront-scheduling)
                         (action propagation-target)
                         (arguments target ?t
                                    alias ?a0
                                    from ?p0
                                    for ?b))
         ?f1 <- (message (to wavefront-scheduling)
                         (action propagation-target)
                         (arguments target ?t
                                    alias ?a1&~?a0
                                    from ?p1&~?p0
                                    for ?b))
         =>
         (retract ?f0 ?f1)
         (assert (message (to wavefront-scheduling)
                          (action create-phi-node)
                          (arguments target-instruction ?t
                                     block ?b => ?a0 ?p0 ?a1 ?p1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-node::MergePhiNodePropagationWithCreateStatement
         ?f0 <- (message (to wavefront-scheduling)
                         (action propagation-target)
                         (arguments target ?t
                                    alias ?a0
                                    from ?p0
                                    for ?b))
         ?f1 <- (message (to wavefront-scheduling)
                         (action create-phi-node)
                         (arguments target-instruction ?t
                                    block ?b => $?targets))
         =>
         (retract ?f0)
         (modify ?f1 (arguments target-instruction ?t
                                block ?b => $?targets ?a0 ?p0)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-node::PutUnfulfilledItemsBackIntoPropagationList
         (declare (salience -10))
         ?f0 <- (message (to wavefront-scheduling)
                         (action propagation-target)
                         (arguments target ?t
                                    alias ?a0
                                    from ?p0
                                    for ?b))
         ?pa <- (object (is-a PathAggregate)
                        (Parent ?b)
                        (InstructionPropagation $?ip))
         =>
         (retract ?f0)
         (modify-instance ?pa (InstructionPropagation $?ip ?t ?a0 ?b !)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-node::NamePhiNodeFromCreateStatement-NotOriginalBlock
         (declare (salience -12))
         ?fct <- (message (to wavefront-scheduling)
                          (action create-phi-node)
                          (arguments target-instruction ?t
                                     block ?b => $?targets))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?b)
                           (ScheduledInstructions $?si)
                           (InstructionPropagation $?ip)
                           (ReplacementActions $?ra))

         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (contents ?first $?rest)
                        (UnlinkedInstructions
                          $?ui&:(not (member$ ?t $?ui))))
         (object (is-a Instruction)
                 (id ?first)
                 (pointer ?bPtr))
         (object (is-a Instruction)
                 (id ?t)
                 (Type ?ty))
         (object (is-a LLVMType)
                 (id ?ty)
                 (pointer ?typePtr))
         =>
         (modify ?fct (action update-block-duration)
                 (arguments ?b))
         (bind ?name (sym-cat phi. (gensym*) . ?t))
         ;make the phinode in LLVM and get it's address back
         (bind ?phiPtr
               (llvm-make-phi-node ?name
                                   ?typePtr
                                   (/ (length$ $?elements) 2)
                                   ?bPtr
                                   (symbol-to-pointer-list $?elements)))
         ;build a CLIPS representation of it
         (make-instance ?name of PhiNode
                        (parent ?b)
                        (TimeIndex 0)
                        (pointer ?phiPtr)
                        (IncomingValueCount ?count)
                        (Operands $?elements))
         ;we've scheduled the given original instruction into this block
         ; although it's just a ruse
         (modify-instance ?agObj (ScheduledInstructions $?si ?t)
                          (InstructionPropagation $?ip ?t ?name ?b !)
                          (ReplacementActions $?ra ?t ?name !))
         (modify-instance ?bb (contents ?name ?first $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-node::NamePhiNodeFromCreateStatement-OriginalBlock
         (declare (salience -12))
         ?fct <- (message (to wavefront-scheduling)
                          (action create-phi-node)
                          (arguments target-instruction ?t
                                     block ?b => $?elements))
         ?agObj <- (object (is-a PathAggregate)
                           (Parent ?b)
                           (ScheduledInstructions $?si))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (contents ?first $?rest)
                        (UnlinkedInstructions
                          $?ui&:(not (member$ ?t $?ui))))
         (object (is-a Instruction)
                 (id ?first)
                 (pointer ?bPtr))
         ?tObj <- (object (is-a Instruction)
                          (id ?t)
                          (Type ?ty)
                          (pointer ?tPtr))
         (object (is-a LLVMType)
                 (id ?ty)
                 (pointer ?dataType))
         =>
         (modify ?fct (action update-block-duration)
                 (arguments ?b))
         (bind ?name (sym-cat phi. (gensym*) . ?t))
         (bind ?count (/ (length$ $?elements) 2))
         (bind ?pointers (symbol-to-pointer-list ?elements))
         (bind ?phiPointer
               (llvm-make-phi-node ?name ?dataType ?count ?bPtr ?pointers))
         (bind ?phiObj (make-instance ?name of PhiNode
                                      (parent ?b)
                                      (TimeIndex 0)
                                      (pointer ?phiPointer)
                                      (IncomingValueCount ?count)
                                      (Operands $?elements)))
         (llvm-replace-all-uses ?tPtr ?phiPointer)
         (llvm-unlink-and-delete-instruction ?tPtr)
         (unmake-instance ?tObj)
         (modify-instance ?agObj (ScheduledInstructions $?si ?t))
         (modify-instance ?bb (contents ?name ?first $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-phi-node-update::ReindexBasicBlock
         ?fct <- (message (to wavefront-scheduling)
                          (action update-block-duration)
                          (arguments ?b))
         (object (is-a BasicBlock)
                 (id ?b)
                 (contents $?c))
         =>
         ;this is very much procedural but I frankly don't care
         ;anymore.
         (progn$ (?t ?c)
                 (bind ?obj (instance-address (symbol-to-instance-name ?t)))
                 (modify-instance ?obj (TimeIndex (- ?t-index 1))))
         (retract ?fct))
;------------------------------------------------------------------------------

;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 PropagateAggregateInformation
			"Pulls instruction propagation information from all elements on paths
			that immediately precede this element on the wavefront and merges it
			into the path aggregate itself"
			(Stage WavefrontSchedule $?)
			(Substage Identify $?)
			(Propagate aggregates of ?e)
			;if this element is on the wavefront then we can be certain that all
			;of it's predecessors are above it. That is the definition of being on
			;the wavefront
			?pa <- (object (is-a PathAggregate) (Parent ?e) (ID ?pp))
			(object (is-a Diplomat) (ID ?e) (PreviousPathElements $? ?z $?))
			(object (is-a PathAggregate) (Parent ?z)
					  (InstructionPropagation $? ?targ ?alias ? ! $?))
			=>
			;replace parent blocks of previous path elements with the name of the
			;element this was acquired from
			;(printout t "Put (" ?targ " " ?alias " " ?z "! ) into " ?pp crlf)
			(slot-insert$ ?pa InstructionPropagation 1 ?targ ?alias ?z !))
;------------------------------------------------------------------------------
(defrule RetractAggregationInformation
			(declare (salience -50))
			(Stage WavefrontSchedule $?)
			(Substage Identify $?)
			?fct <- (Propagate aggregates of ?)
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule AssertPhiNodePropagationPredicateIsBlock
			(declare (salience 1))
			(Stage WavefrontSchedule $?)
			(Substage PhiIdentify $?)
			(object (is-a Wavefront) (Parent ?r) (Contents $? ?e $?))
			?pa <- (object (is-a PathAggregate) (Parent ?e)
								(InstructionPropagation ?targ ?alias ?pred ! $?rest))
			=>
			(modify-instance ?pa (InstructionPropagation $?rest))
			(assert (Propagation target ?targ with alias ?alias
										from block ?pred for block ?e)))
;------------------------------------------------------------------------------
(defrule RemoveDuplicateElements
			(Stage WavefrontSchedule $?)
			(Substage PhiNode $?)
			?f0 <- (Propagation target ?t with alias ?a from block ?p0
									  for block ?b)
			?f1 <- (Propagation target ?t with alias ?a from block ?p1
									  for block ?b)
			(test (and (neq ?f0 ?f1) (neq ?p0 ?p1)))
			?pa <- (object (is-a PathAggregate) (Parent ?b))
			=>
			(retract ?f0 ?f1)
			(slot-insert$ ?pa InstructionPropagation 1 ?t ?a ?b !))
;------------------------------------------------------------------------------
(defrule MergePhiNodePropagationWithOtherPropagation
			(Stage WavefrontSchedule $?)
			(Substage PhiNode $?)
			?f0 <- (Propagation target ?t with alias ?a0 from block ?p0
									  for block ?b)
			?f1 <- (Propagation target ?t with alias ?a1 from block ?p1
									  for block ?b)
			(test (neq ?f0 ?f1))
			=>
			(retract ?f0 ?f1)
			(assert (Create phinode targeting instruction ?t for block ?b
								 consisting of ?a0 ?p0 ?a1 ?p1 )))
;------------------------------------------------------------------------------
(defrule MergePhiNodePropagationWithCreateStatement
			(Stage WavefrontSchedule $?)
			(Substage PhiNode $?)
			?f0 <- (Propagation target ?t with alias ?a0 from block ?p0
									  for block ?b)
			?f1 <- (Create phinode targeting instruction ?t for block ?b
								consisting of $?targets)
			=>
			(retract ?f0 ?f1)
			(assert (Create phinode targeting instruction ?t for block ?b
								 consisting of $?targets ?a0 ?p0 )))
;------------------------------------------------------------------------------
(defrule PutUnfulfilledItemsBackIntoPropagationList
			(declare (salience -10))
			(Stage WavefrontSchedule $?)
			(Substage PhiNode $?)
			?f0 <- (Propagation target ?t with alias ?a0 from block ?p0 for
									  block ?b)
			?pa <- (object (is-a PathAggregate) (Parent ?b))
			=>
			(retract ?f0)
			(slot-insert$ ?pa InstructionPropagation 1 ?t ?a0 ?b !))
;------------------------------------------------------------------------------
(defrule NamePhiNodeFromCreateStatement-NotOriginalBlock
			(declare (salience -12))
			(Stage WavefrontSchedule $?)
			(Substage PhiNode $?)
			?fct <- (Create phinode targeting instruction ?t for block ?b
								 consisting of $?elements)
			?agObj <- (object (is-a PathAggregate)
									(Parent ?b))
			?bb <- (object (is-a BasicBlock)
								(ID ?b)
								(Contents ?first $?rest)
								(UnlinkedInstructions $?ui))
			(test (not (member$ ?t $?ui)))
			(object (is-a Instruction)
					  (ID ?first)
					  (Pointer ?bPtr))
			(object (is-a Instruction)
					  (ID ?t)
					  (Type ?ty))
			(object (is-a LLVMType)
					  (ID ?ty)
					  (Pointer ?dataType))
			=>
			(retract ?fct)
			(bind ?name (sym-cat phi. (gensym*) . ?t))
			(bind ?count (/ (length$ $?elements) 2))
			(bind ?pointers (symbol-to-pointer-list ?elements))
			(make-instance ?name of PhiNode
								(Parent ?b)
								(TimeIndex 0)
								(Pointer (llvm-make-phi-node ?name ?dataType ?count
																	  ?bPtr ?pointers))
								(IncomingValueCount ?count)
								(Operands $?elements))
			;we've scheduled the given original instruction into this block
			; although it's just a ruse
			(slot-insert$ ?agObj ScheduledInstructions 1 ?t)
			(slot-insert$ ?agObj InstructionPropagation 1 ?t ?name ?b !)
			(slot-insert$ ?agObj ReplacementActions 1 ?t ?name !)
			(slot-insert$ ?bb Contents 1 ?name)
			(assert (Update duration for block ?b)))
;------------------------------------------------------------------------------
(defrule NamePhiNodeFromCreateStatement-OriginalBlock
			(declare (salience -12))
			(Stage WavefrontSchedule $?)
			(Substage PhiNode $?)
			?fct <- (Create phinode targeting instruction ?t for block ?b
								 consisting of $?elements)
			?agObj <- (object (is-a PathAggregate)
									(Parent ?b))
			?bb <- (object (is-a BasicBlock)
								(ID ?b)
								(Contents ?first $?rest)
								(UnlinkedInstructions $?ui))
			(test (not (member$ ?t ?ui)))
			(object (is-a Instruction)
					  (ID ?first)
					  (Pointer ?bPtr))
			?tObj <- (object (is-a Instruction)
								  (ID ?t)
								  (Type ?ty)
								  (Pointer ?tPtr))
			(object (is-a LLVMType)
					  (ID ?ty)
					  (Pointer ?dataType))
			=>
			(retract ?fct)
			(bind ?name (sym-cat phi. (gensym*) . ?t))
			(bind ?count (/ (length$ $?elements) 2))
			(bind ?pointers (symbol-to-pointer-list ?elements))
			(bind ?phiPointer
					(llvm-make-phi-node ?name ?dataType ?count ?bPtr ?pointers))
			(bind ?phiObj (make-instance ?name of PhiNode
												  (Parent ?b)
												  (TimeIndex 0)
												  (Pointer ?phiPointer)
												  (IncomingValueCount ?count)
												  (Operands $?elements)))
			(llvm-replace-all-uses ?tPtr ?phiPointer)
			(llvm-unlink-and-delete-instruction ?tPtr)
			(unmake-instance ?tObj)
			(slot-insert$ ?agObj ScheduledInstructions 1 ?t)
			(slot-insert$ ?bb Contents 1 ?name)
			(assert (Update duration for block ?b)))
;------------------------------------------------------------------------------
(defrule ReindexBasicBlock
			(Stage WavefrontSchedule $?)
			(Substage PhiNodeUpdate $?)
			?fct <- (Update duration for block ?b)
			(object (is-a BasicBlock) (ID ?b) (Contents $?c))
			=>
			;this is very much procedural but I frankly don't care
			;anymore.
			(bind ?index 0)
			(progn$ (?t ?c)
					  (bind ?obj (instance-address (symbol-to-instance-name ?t)))
					  (modify-instance ?obj (TimeIndex ?index))
					  (bind ?index (+ ?index 1)))
			(retract ?fct))
;------------------------------------------------------------------------------