Added basic error checking for the assembler

;------------------------------------------------------------------------------
;electron
;Copyright (c) 2012-2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of The Adventure Engine nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;-------------------------------------------------------------------------------
; Assembler.clp - An assembler for the theoretical processor.
;-------------------------------------------------------------------------------
(defglobal MAIN ; human readable form
           ?*symbol-label-instruction* = label
           ?*symbol-terminate-instruction* = terminate
           ?*symbol-nop-instruction* = nop
           ?*symbol-add-instruction* = add
           ?*symbol-subtract-instruction* = sub
           ?*symbol-multiply-instruction* = mul
           ?*symbol-divide-instruction* = div
           ?*symbol-right-shift-instruction* = right-shift
           ?*symbol-left-shift-instruction* = left-shift
           ?*symbol-equal-instruction* = eq
           ?*symbol-not-equal-instruction* = neq
           ?*symbol-less-than-instruction* = lt
           ?*symbol-greater-than-instruction* = gt
           ?*symbol-and-instruction* = and
           ?*symbol-or-instruction* = or
           ?*symbol-not-instruction* = not
           ?*symbol-branch-instruction* = branch
           ?*symbol-load-instruction* = load
           ?*symbol-store-instruction* = store
           ?*symbol-set-instruction* = set
           ?*symbol-interrupt-instruction* = interrupt)
;-------------------------------------------------------------------------------
(deftemplate input-line
             (slot line-number
                   (type INTEGER)
                   (default ?NONE))
             (slot original-input
                   (type STRING)
                   (default ?NONE))
             (multislot raw-input))
;-------------------------------------------------------------------------------
(deftemplate operation
             (slot line-number
                   (type INTEGER)
                   (default ?NONE))
             (slot operation
                   (type SYMBOL)
                   (default ?NONE))
             (multislot arguments))
;-------------------------------------------------------------------------------
(deftemplate instruction
             (slot tag
                   (type SYMBOL))
             (slot arg-count
                   (type INTEGER))
             (slot is-macro ; is it a convienience instruction/operation?
                   (type SYMBOL)
                   (allowed-symbols FALSE TRUE)))
;-------------------------------------------------------------------------------
(deffacts argument-conversion-counts
          (instruction (tag ?*symbol-terminate-instruction*)
                       (arg-count 0))
          (instruction (tag ?*symbol-nop-instruction*)
                       (arg-count 0))
          (instruction (tag ?*symbol-add-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-subtract-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-multiply-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-divide-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-right-shift-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-left-shift-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-equal-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-not-equal-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-less-than-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-greater-than-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-and-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-or-instruction*)
                       (arg-count 3))
          (instruction (tag ?*symbol-not-instruction*)
                       (arg-count 2))
          (instruction (tag ?*symbol-branch-instruction*)
                       (arg-count 2))
          (instruction (tag ?*symbol-load-instruction*)
                       (arg-count 2))
          (instruction (tag ?*symbol-store-instruction*)
                       (arg-count 2))
          (instruction (tag ?*symbol-set-instruction*)
                       (arg-count 2))
          (instruction (tag ?*symbol-interrupt-instruction*)
                       (arg-count 1))
          (instruction (tag ?*symbol-label-instruction*)
                       (arg-count 1)
                       (is-macro TRUE)))
;-------------------------------------------------------------------------------
(defgeneric to-char)
;-------------------------------------------------------------------------------
(defmethod to-char
  ((?i INTEGER (>= ?i 0)) ; no negative numbers
   (?stream SYMBOL))
  (format ?stream "%c" ?i))

(defmethod to-char
  ((?i INTEGER (>= ?i 0)))
  (to-char ?i nil))

;-------------------------------------------------------------------------------
; since we can't do "knowledge construction" in the standard sense we need to
; pull input from standard-in.
;-------------------------------------------------------------------------------
(defrule initialize-assembler
         (initial-fact)
         =>
         (assert (read-to-end 1)))

(defrule build-input-line
         ?f <- (read-to-end ?i)
         =>
         (retract ?f)
         (bind ?input (readline))
         (if (neq ?input EOF) then
           (assert (read-to-end (+ ?i 1))
                   (input-line (line-number ?i)
                               (original-input ?input)
                               (raw-input (explode$ ?input))))
           else
           (assert (translate-input))))

(defrule throw-out-empty-lines
         "remove lines that are completely comments or just plain empty"
         (declare (salience 2))
         ?f <- (input-line (raw-input))
         =>
         (retract ?f))
(defrule invalid-line-found
         (declare (salience 2))
         (input-line (line-number ?i)
                     (original-input ?line)
                     (raw-input $?input))
         (test (or (> (length$ $?input) 4)))
         =>
         (printout werror "ERROR: line " ?i " is invalid" crlf
                   "     " ?line crlf)
         (halt))

(defrule is-invalid-instruction
         (declare (salience 2))
         (input-line (raw-input ?op $?)
                     (line-number ?l)
                     (original-input ?input))
         (not (exists (instruction (tag ?op))))
         =>
         (printout werror
                   (format nil "ERROR: Instruction %s on line %d is invalid%n" ?op ?l)
                   (format nil " Line: %s%n%n" ?input))
         (halt))
(defrule invalid-argument-count-for-operation
         (declare (salience 2))
         (input-line (raw-input ?operation $?rest)
                     (line-number ?l)
                     (original-input ?input))
         (instruction (tag ?operation)
                      (arg-count ?ac&:(!= ?ac (length$ $?rest))))
         =>
         (printout werror
                   (format nil "ERROR: Invalid number of arguments for %s on line %d%n"
                           ?operation ?l)
                   (format nil " Line: %s%n%n" ?input))
         (halt))

(defrule process-input-line
         (declare (salience 1)) ; evaluate each line as it goes through
         ?f <- (input-line (raw-input ?operation $?rest)
                           (line-number ?l))
         (instruction (tag ?operation)
                      (arg-count =(length$ $?rest)))

         =>
         (retract ?f)
         (assert (operation (line-number ?l)
                            (operation ?operation)
                            (arguments $?rest))))
;-------------------------------------------------------------------------------
; this becomes a script that reads from standard input
;-------------------------------------------------------------------------------
(reset) ; load the instruction information for our purposes
(run)
(exit)

;------------------------------------------------------------------------------
;electron
;Copyright (c) 2012-2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of The Adventure Engine nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;-------------------------------------------------------------------------------
; Assembler.clp - An assembler for the theoretical processor.
;-------------------------------------------------------------------------------
(defglobal MAIN ; human readable form
           ?*symbol-terminate-instruction* = terminate
           ?*symbol-nop-instruction* = nop
           ?*symbol-add-instruction* = add
           ?*symbol-subtract-instruction* = sub
           ?*symbol-multiply-instruction* = mul
           ?*symbol-divide-instruction* = div
           ?*symbol-right-shift-instruction* = right-shift
           ?*symbol-left-shift-instruction* = left-shift
           ?*symbol-equal-instruction* = eq
           ?*symbol-not-equal-instruction* = neq
           ?*symbol-less-than-instruction* = lt
           ?*symbol-greater-than-instruction* = gt
           ?*symbol-and-instruction* = and
           ?*symbol-or-instruction* = or
           ?*symbol-not-instruction* = not
           ?*symbol-branch-instruction* = branch
           ?*symbol-load-instruction* = load
           ?*symbol-store-instruction* = store
           ?*symbol-set-instruction* = set
           ?*symbol-interrupt-instruction* = interrupt
           )
;-------------------------------------------------------------------------------
(deftemplate input-line
             (slot line-number
                   (type INTEGER)
                   (default ?NONE))
             (multislot raw-input))

;-------------------------------------------------------------------------------
(deftemplate operation
             (slot line-number
                   (type INTEGER)
                   (default ?NONE))
             (slot operation
                   (type SYMBOL)
                   (default ?NONE))
             (slot destination
                   (type SYMBOL)
                   (default ?NONE))
             (slot source0
                   (type NUMBER INSTANCE)
                   (default ?NONE))
             (slot source1
                   (type INSTANCE)))
;-------------------------------------------------------------------------------
(defgeneric to-char)

(defmethod to-char
  ((?i INTEGER (>= ?i 0)) ; no negative numbers
   (?stream SYMBOL))
  (format ?stream "%c" ?i))

(defmethod to-char
  ((?i INTEGER (>= ?i 0)))
  (to-char ?i nil))

; since we can't do "knowledge construction" in the standard sense we need to
; pull input from standard-in.
(defrule initialize-assembler
         (initial-fact)
         =>
         (assert (read-to-end 0)))

(defrule build-input-line
         ?f <- (read-to-end ?i)
         =>
         (retract ?f)
         (bind ?input (readline))
         (if (neq ?input EOF) then
           (assert (read-to-end (+ ?i 1))
                   (input-line (line-number ?i)
                               (raw-input (explode$ ?input))))))

(defrule throw-out-empty-lines
         "remove lines that are completely comments or just plain empty"
         (declare (salience 2))
         ?f <- (input-line (raw-input))
         =>
         (retract ?f))

(defrule process-input-line:two-input
         (declare (salience 1)) ; evaluate each line as it goes through
         ?f <- (input-line (raw-input ?operation ?dest ?source)
                           (line-number ?l))
         =>
         (retract ?f)
         (assert (operation (line-number ?l)
                            (operation ?operation)
                            (destination ?dest)
                            (source0 ?source))))

(defrule process-input-line:three-input
         (declare (salience 1)) ; evaluate each line as it goes through
         ?f <- (input-line (raw-input ?operation ?dest ?source0 ?source1)
                           (line-number ?l))
         =>
         (retract ?f)
         (assert (operation (line-number ?l)
                            (operation ?operation)
                            (destination ?dest)
                            (source0 ?source0)
                            (source1 ?source1))))
(defrule is-invalid-instruction
         ?f <- (operation (line-number ?l)
                          (operation ?operation&:(not (instruction-exists
                                                       ?operation))))
         =>
         (

;-------------------------------------------------------------------------------
; this becomes a script that reads from standard input
(run)
(exit)


adding a new script to test deffunctions with assert. the bug is fixed now.

peter

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

(deftemplate wurst(slot name))

(deffunction addwurst
  (?wurstName)
  (assert
    (wurst (name ?wurstName))
  )
)
(defrule testrule
=>
  (bind ?x "new Wurst")
  (assert (wurst (name ?x)))
  (addwurst "other new Wurst")
)
(fire)

error: pathspec 'samples/deffunction_test2.clp' did not match any file(s) known to git


Ported WavefrontInstructionMerging.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.
;------------------------------------------------------------------------------
; Contains rules associated with the act of actually scheduling instructions
; into blocks on the wavefront
;
; Written by Joshua Scoggins
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::AssertScheduleCPVIntoTargetBlock
         (object (is-a Wavefront)
                 (contents $? ?e $?))
         (object (is-a Diplomat)
                 (id ?e)
                 (IsOpen TRUE))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (MovableCompensationPathVectors
                             $?cpvs&:(<> 0 (length$ $?cpvs))))
         =>
         (modify-instance ?agObj (MovableCompensationPathVectors))
         (progn$ (?cpv $?cpvs)
                 (assert (message (to wavefront-scheduling)
                                  (action determine-schedule-style)
                                  (arguments ?cpv => ?e)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsMove
         "This rule attempts to determine if the CPV should be moved into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted"
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;the two sets are the same
         (test (equal$ ?paths ?cpvPaths))
         =>
         ;change the action...nothing more :D
         (modify ?fct (message (action move-instruction))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsCompensate
         "This rule attempts to determine if the CPV should be copied into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted."
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;there are more paths in the CPV than in the block
         (test (subsetp ?paths ?cpvPaths))
         =>
         (modify ?fct (action clone-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::RemoveScheduleStyleForCPV
         (declare (salience 1))
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         (test (not (subsetp ?paths ?cpvPaths)))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionList $?il))
         =>
         ;TODO: Put code in here to delete a given instruction from the target
         ;      instruction list as well.
         ;
         ; Eventually, I will detect if we are in a loop. If we are then it is
         ; necessary to figure out which paths remain in the loop and those
         ; that exit.
         ;this should prevent a potential infinite loop
         ;(printout t "Preventing " ?i " from being scheduled into " ?e crlf)
         (retract ?fct)
         (bind ?ind (member$ ?i $?il))
         (if ?ind then (slot-delete$ ?agObj InstructionList ?ind ?ind)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::MoveInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last)
                              (Produces $?nBProds))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionPropagation $?agIP)
                           (ScheduledInstructions $?agSI)
                           (ReplacementActions $?agRA))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (ScheduleTargets $?cpvST)
                               (Aliases $?cpvAliases))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (Consumers $?niConsumers)
                             (Class ?class))
         ?oldBlock <- (object (is-a BasicBlock)
                              (id ?otherBlock)
                              (Produces $?pBefore ?inst $?pRest)
                              (Contents $?before ?inst $?rest))
         ;TODO: add another rule where we have to update the consumers list as
         ;      well
         =>
         (object-pattern-match-delay
           ;(printout t "Scheduled " ?inst " into " ?e crlf)
           (modify-instance ?terminator (TimeIndex (+ ?ti 1)))
           ;(modify-instance ?newBlock (Produces ?nBProds ?register))
           (modify-instance ?oldBlock (Contents $?before $?rest)
                            (Produces $?pBefore $?pRest))
           ;(modify-instance ?cpvObject (Paths))
           (modify ?fct (action remove-evidence)
                   (arguments ?inst => $?niConsumers))
           (assert (message (to wavefront-scheduling)
                            (action recompute-block)
                            (arguments ?otherBlock)))
           (if (eq StoreInstruction ?class) then
             (modify-instance ?agObj
                              (ScheduledInstructions $?agSI ?inst ?register)
                              (ReplacementActions $?agRA ?inst ?inst !))
             ;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (Contents $?blockBefore ?inst ?last))
             (modify-instance ?cpvObject
                              (Paths)
                              (ScheduleTargets ?cpvST ?e ?inst)
                              (Aliases $?cpvAliases ?inst ?e))
             (llvm-unlink-and-move-instruction-before ?nPtr ?tPtr)
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?inst)
             ;(slot-insert$ ?cpvObject Aliases 1 ?inst ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?inst !)
             else
             (bind ?newName (sym-cat movedinstruction. (gensym*) . ?inst))
             (modify-instance ?cpvObject (Paths)
                              (ScheduleTargets ?cpvST ?e ?newName)
                              (Aliases ?cpvAliases ?newName ?e))
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
             ;(slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (Contents $?blockBefore ?newName ?last))
             (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
             ;purge the list of producers and consumers
             (duplicate-instance ?inst to ?newName
                                 (id ?newName)
                                 (Name ?newName)
                                 (pointer ?newPtr)
                                 (Producers)
                                 (Consumers)
                                 (NonLocalDependencies)
                                 (LocalDependencies)
                                 (TimeIndex ?ti)
                                 (parent ?e))
             (llvm-move-instruction-before ?newPtr ?tPtr)
             (slot-insert$ ?oldBlock UnlinkedInstructions 1 ?inst)
             (modify-instance ?agObj (ReplacementActions $?agRA ?inst ?newName !)
                              (InstructionPropagation $?agIP ?inst ?newName ?e !)
                              (ScheduledInstructions $?agSI ?inst)))))
;(slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::CloneInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (Paths $?cpvPaths))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (Class ?class))
         =>
         ;we also need to update all CPVs within
         (object-pattern-match-delay
           (bind ?newName (sym-cat compensation.copy. (gensym*) . ?inst))
           ;(printout t "Scheduled " ?inst " into " ?e " from " ?otherBlock
           ;            " as " ?newName crlf)
           (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
           ;purge the list of producers and consumers
           (duplicate-instance ?inst to ?newName
                               (ID ?newName)
                               (Name ?newName)
                               (Pointer ?newPtr)
                               (Parent ?e)
                               (TimeIndex (+ ?ti 1)))
           (llvm-move-instruction-before ?newPtr ?tPtr)
           ;we add the original name so that we don't have to do
           ; an insane number of updates to the CPVs that follow
           ; this object
           (if (eq StoreInstruction ?class) then
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             else
             (slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst))
           (slot-insert$ ?newBlock Produces 1 ?register)
           (modify-instance ?newBlock (contents $?blockBefore ?newName ?last))
           (slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
           (slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
           (slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
           (modify ?fct (action recompute-block)
                   (arguments ?otherBlock))
           (assert (message (to wavefront-scheduling)
                            (action reopen-blocks)
                            (arguments ?cpv)))
           (bind ?leftOvers (create$))
           (progn$ (?z ?cpvPaths)
                   (bind ?cPath (symbol-to-instance-name ?z))
                   (if (not (member$ ?e (send ?cPath get-contents))) then
                     (bind ?leftOvers (insert$ ?leftOvers 1 ?z))))
           (modify-instance ?cpvObject (Paths ?leftOvers))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-CLONE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't clone " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-MOVE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't move " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-SCHEDULE-STYLE
         (declare (salience -768))
         (message (to wavefront-scheduling)
                  (action determine-schedule-style)
                  (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Parent ?p)
                 (Aliases $?aliases)
                 (Paths $?cpvPaths))
         ?pa <- (object (is-a PathAggregate)
                        (parent ?e))
         (object (is-a Instruction)
                 (id ?p)
                 (Parent ?bb))
         (object (is-a BasicBlock)
                 (id ?e)
                 (parent ?r)
                 (Paths $?paths))
         (object (is-a Wavefront)
                 (parent ?r)
                 (contents $?z)
                 (Closed $?y))
         (object (is-a Region)
                 (id ?r)
                 (Entrances ?x $?))
         (object (is-a BasicBlock)
                 (id ?x)
                 (Paths $?allPaths))
         =>
         (printout t "ERROR: Couldn't figure out scheduling stype for " ?p
                   " which is targeted for " ?e crlf
                   "Blocks on the wavefront = " ?z crlf
                   "Closed Blocks = " ?y crlf
                   "For reference ?cpvPaths = " ?cpvPaths crlf
                   "For reference aliases of ?cpv are = " $?aliases crlf
                   "For reference ?paths = " ?paths crlf
                   "Parent of " ?p " is " ?bb crlf
                   "Printing out the path aggregate for " ?p crlf )
         (send ?pa print)
         (progn$ (?apath ?allPaths)
                 (bind ?aObj (instance-name (symbol-to-instance-name ?apath)))
                 (printout t "  " ?apath " = " (send ?aObj get-contents) crlf))
         (facts)
         (halt))
;------------------------------------------------------------------------------

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


Added a conversion table

Added a conversion table

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; GLAPIConversion.clp - an expert system that reads a define and generates
; corresponding CLIPS functions that convert the CLIPS values into
; corresponding opengl types. This gets a little goofy when dealing with
; multifields but the idea is sound.
;------------------------------------------------------------------------------
; We need to add functionality to diverge asterisks from a symbol
;------------------------------------------------------------------------------
(target-symbol-is-special "*"
								  identify-symbols-with-asterisks
								  "Splits asterisks (*) out of symbols if necessary")
;------------------------------------------------------------------------------
; Can't escape with double quotes with ] and [...strange
;------------------------------------------------------------------------------
(target-symbol-is-special "["
								  identify-symbols-with-open-square-bracket
								  "Splits an input string on [")
;------------------------------------------------------------------------------
(target-symbol-is-special "]"
								  identify-symbols-with-close-square-bracket
								  "Splits an input string on ]")
;------------------------------------------------------------------------------
; Unlike GLConstantConversion, I don't need to use the heading span objects.
; This is because each file-line has already been correctly merged.
;------------------------------------------------------------------------------
(defrule build-groups::delete-heading-span
			"We don't need heading spans in this expert system. So delete them"
			?obj <- (object (is-a heading-span))
			=>
			(unmake-instance ?obj))
;------------------------------------------------------------------------------
; We need to define a transformation function/rule f which is responsible for
; taking in a knowledge representation of the original code from the input
; language and translates it to a knowledge representation of the code in the
; output language. In this case it is C => C with the added "benefit" of
; needing to add CLIPS api calls to interact with the overall environment.
;
; This isn't really that hard as what we need to do is just parse the arguments
; and generate the corresponding C code.
;------------------------------------------------------------------------------
(defclass types::GLAPIFunction
  "Defines a given GLAPI function"
  (is-a Object)
  (slot return-type (type SYMBOL STRING))
  (slot function-name)
  (slot clips-function-name))
;------------------------------------------------------------------------------
(defclass types::GLAPIArgument
  "Defines a given GLAPI function argument"
  (is-a Object)
  (slot argument-type (visibility public))
  (slot argument-name)
  (slot index)
  (slot is-constant (type SYMBOL) (allowed-values FALSE TRUE))
  (slot is-pointer (type SYMBOL) (allowed-values FALSE TRUE))
  (message-handler reconstitute))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIArgument reconstitute
						  ()
						  (return (format nil "%s %s %s %s"
												(if ?self:is-constant then "const" else "")
												?self:argument-type
												(if ?self:is-pointer then "*" else "")
												?self:argument-name)))
;------------------------------------------------------------------------------
(defclass types::GLAPIFixedArrayArgument
  "Refers to fixed size arrays"
  (is-a GLAPIArgument)
  (slot array-size)
  (message-handler reconstitute around))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIFixedArrayArgument reconstitute around
						  ()
						  (return (format nil "%s[%s]"
												(call-next-handler)
												(str-cat ?self:array-size))))
;------------------------------------------------------------------------------
; build-groups module
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" $?args ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(bind ?objName (gensym*))
			(modify ?msg
					  (action parse-arguments)
					  (arguments ?objName => $?args))
			(make-instance ?objName of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function-void
			(declare (salience 1))
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" void ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(retract ?msg)
			(make-instance of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(deffunction build-groups::count-commas
				 "Iterates through a multifield and counts the number of commas"
				 (?list)
				 (bind ?count 0)
				 (progn$ (?e ?list)
							(if (or (eq ?e ",")
									  (eq ?e ,)) then
							  (bind ?count (+ 1 ?count))))
				 (return ?count))
;------------------------------------------------------------------------------
(defrule build-groups::concatentate-length
			"Adds a range to the target argument set"
			?fct <- (message (to build-groups)
								  (action parse-arguments)
								  (arguments ?o => $?contents))
			=>
			(modify ?fct (action diverge-arguments)
					  (arguments ?o 0 (count-commas $?contents) =>
									 $?contents)))
;------------------------------------------------------------------------------
(defrule build-groups::diverge-arguments
			"Splits the set of arguments into two separate facts"
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?start ?finish => $?a "," $?b))
			(test (neq ?start ?finish))
			=>
			(bind ?cca (count-commas $?a))
			(bind ?starta ?start)
			(bind ?enda (+ ?starta ?cca))
			;from start to end
			(bind ?startb (+ 1 ?enda))
			;we use finish since it's the upper bound on this argument set
			(bind ?endb ?finish)
			(modify ?fct (arguments ?o ?starta ?enda => $?a))
			(duplicate ?fct (arguments ?o ?startb ?endb => $?b)))
;------------------------------------------------------------------------------
(defrule build-groups::generate-build-argument-statement
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?pos ?pos => $?conditions))
			=>
			(modify ?fct (action build-argument)
					  (arguments ?o ?pos => $?conditions)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-fixed-array
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?field "[" ?size "]"))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?field))
			(make-instance ?name of GLAPIFixedArrayArgument
								(parent ?o)
								(array-size ?size)
								(index ?ind)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-generic
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?input))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?input))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index ?ind)))
;------------------------------------------------------------------------------
; grouping-update module
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-pointer
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before "*" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-pointer TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-constant
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before const|"const" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-constant TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::set-argument-core-info
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => ?type ?name))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o =>))

			(modify-instance ?obj (argument-type ?type)
								  (argument-name ?name)))
;------------------------------------------------------------------------------
(defrule grouping-update::retract-arguments
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o =>))
			(object (is-a GLAPIArgument)
					  (id ?o)
					  (parent ?p))
			=>
			(modify ?fct (action make-function-builder)
					  (arguments ?p)))
;------------------------------------------------------------------------------
(defclass types::FunctionBuilder
  "Builds C functions"
  (is-a Object)
  (multislot contents))
;------------------------------------------------------------------------------
(defclass types::CLIPSFunctionBuilder
  (is-a FunctionBuilder)
  (multislot data-objects)
  (multislot variables)
  (multislot parsing-entries)
  (slot count))
;------------------------------------------------------------------------------
; So, what do we need to do to construct a single function
; 0) Generate the registration entry for the target builder
; 1) Generate the function builder (done)
; 2) Define required arguments
; 3) Figure out type conversions
; 4) Define translation code for each argument
; 5) Generate code to call the target function with the given arguments
; 6) Assemble the function together
;------------------------------------------------------------------------------
; We use EnvDefineFunction in all cases of registration
;
; For conversion of pointers, we take in a multifield from clips and convert
; that to a corresponding pointer. We can also use macros or a function to
; do the conversion, that would make this whole process a lot easier.
;
; While it goes against the standard practices of C, I am going to have this
; conversion function perform the malloc and return the pointer. It is up to
; the function that called the conversion function to clean up the pointer once
; finished.
;
; However, continually calling malloc and free is costly. We can allocate a
; pointer ahead of time and continually resize it as necessary. We could also
; define a huge block of memory and then slice it accordingly.
;
; I know this for certain, this technique will go through many iterations
; before I arrive at a valid solution (most likely).
;
; The functions that take in a fixed size array are easy because I can allocate
; a static block ahead of time that I can read and write from.
;------------------------------------------------------------------------------
; Conversion table
;------------------------------------------------------------------------------
; float => all floating point types
; int => all integer types
; symbol => GLenum or GLboolean
; multifield => pointer type or fixed array
;------------------------------------------------------------------------------
(defrule grouping-update::make-function-builder
			?fct <- (message (to grouping-update)
								  (action make-function-builder)
								  (arguments ?p))
			=>
			(modify ?fct (action build-function)
					  (arguments ?p -1))
			(make-instance of CLIPSFunctionBuilder
								(parent ?p)))
;------------------------------------------------------------------------------
(defrule grouping-update::build-function-header
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p -1))
			?obj <- (object (is-a CLIPSFunctionBuilder)
								 (parent ?p))
			(object (is-a GLAPIFunction)
					  (id ?p)
					  (return-type ?ret)
					  (clips-function-name ?cfn))
			=>
			(modify ?fct (arguments ?p 0))
			(modify-instance ?obj (contents
											(format nil "extern %s %s(void* theEnv) {"
													  ?ret ?cfn))))
;------------------------------------------------------------------------------
(defrule grouping-update::build-function-add-argument
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p ?index))
			?arg <- (object (is-a GLAPIArgument)
								 (parent ?p)
								 (index ?index)
								 (id ?argID))
			?obj <- (object (is-a CLIPSFunctionBuilder)
								 (parent ?p)
								 (parsing-entries $?pe)
								 (contents $?contents))
			=>
			(modify ?fct (arguments ?p (+ ?index 1)))
			(modify-instance ?obj
								  (contents $?contents
												(format nil "//code to handle %s"
														  (send ?arg reconstitute)))))
;------------------------------------------------------------------------------
(defrule grouping-update::close-function
			(declare (salience -1))
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p ?index))
			(not (exists (object (is-a GLAPIArgument)
										(parent ?p)
										(index ?index))))
			?f <- (object (is-a CLIPSFunctionBuilder)
							  (parent ?p)
							  (contents $?contents))
			=>
			(modify ?fct (action print-function)
					  (arguments ?p))
			(modify-instance ?f (contents $?contents "}")
								  (count ?index)))
;------------------------------------------------------------------------------
(defrule grouping-update::print-built-function
			?fct <- (message (to grouping-update)
								  (action print-function)
								  (arguments ?p))
			?f <- (object (is-a FunctionBuilder)
							  (parent ?p)
							  (contents $?c))
			=>
			(progn$ (?line ?c)
					  (printout t ?line crlf))
			(printout t crlf crlf)
			(retract ?fct)
			(unmake-instance ?f))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; GLAPIConversion.clp - an expert system that reads a define and generates
; corresponding CLIPS functions that convert the CLIPS values into
; corresponding opengl types. This gets a little goofy when dealing with
; multifields but the idea is sound.
;------------------------------------------------------------------------------
; We need to add functionality to diverge asterisks from a symbol
;------------------------------------------------------------------------------
(target-symbol-is-special "*"
								  identify-symbols-with-asterisks
								  "Splits asterisks (*) out of symbols if necessary")
;------------------------------------------------------------------------------
; Can't escape with double quotes with ] and [...strange
;------------------------------------------------------------------------------
(target-symbol-is-special "["
								  identify-symbols-with-open-square-bracket
								  "Splits an input string on [")
;------------------------------------------------------------------------------
(target-symbol-is-special "]"
								  identify-symbols-with-close-square-bracket
								  "Splits an input string on ]")
;------------------------------------------------------------------------------
; Unlike GLConstantConversion, I don't need to use the heading span objects.
; This is because each file-line has already been correctly merged.
;------------------------------------------------------------------------------
(defrule build-groups::delete-heading-span
			"We don't need heading spans in this expert system. So delete them"
			?obj <- (object (is-a heading-span))
			=>
			(unmake-instance ?obj))
;------------------------------------------------------------------------------
; We need to define a transformation function/rule f which is responsible for
; taking in a knowledge representation of the original code from the input
; language and translates it to a knowledge representation of the code in the
; output language. In this case it is C => C with the added "benefit" of
; needing to add CLIPS api calls to interact with the overall environment.
;
; This isn't really that hard as what we need to do is just parse the arguments
; and generate the corresponding C code.
;------------------------------------------------------------------------------
(defclass types::GLAPIFunction
  "Defines a given GLAPI function"
  (is-a Object)
  (slot return-type (type SYMBOL STRING))
  (slot function-name)
  (slot clips-function-name))
;------------------------------------------------------------------------------
(defclass types::GLAPIArgument
  "Defines a given GLAPI function argument"
  (is-a Object)
  (slot argument-type (visibility public))
  (slot argument-name)
  (slot index)
  (slot is-constant (type SYMBOL) (allowed-values FALSE TRUE))
  (slot is-pointer (type SYMBOL) (allowed-values FALSE TRUE))
  (message-handler reconstitute))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIArgument reconstitute
						  ()
						  (return (format nil "%s %s %s %s"
												(if ?self:is-constant then "const" else "")
												?self:argument-type
												(if ?self:is-pointer then "*" else "")
												?self:argument-name)))
;------------------------------------------------------------------------------
(defclass types::GLAPIFixedArrayArgument
  "Refers to fixed size arrays"
  (is-a GLAPIArgument)
  (slot array-size)
  (message-handler reconstitute around))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIFixedArrayArgument reconstitute around
						  ()
						  (return (format nil "%s[%s]"
												(call-next-handler)
												(str-cat ?self:array-size))))
;------------------------------------------------------------------------------
; build-groups module
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" $?args ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(bind ?objName (gensym*))
			(modify ?msg
					  (action parse-arguments)
					  (arguments ?objName => $?args))
			(make-instance ?objName of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function-void
			(declare (salience 1))
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" void ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(retract ?msg)
			(make-instance of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(deffunction build-groups::count-commas
				 "Iterates through a multifield and counts the number of commas"
				 (?list)
				 (bind ?count 0)
				 (progn$ (?e ?list)
							(if (or (eq ?e ",")
									  (eq ?e ,)) then
							  (bind ?count (+ 1 ?count))))
				 (return ?count))
;------------------------------------------------------------------------------
(defrule build-groups::concatentate-length
			"Adds a range to the target argument set"
			?fct <- (message (to build-groups)
								  (action parse-arguments)
								  (arguments ?o => $?contents))
			=>
			(modify ?fct (action diverge-arguments)
					  (arguments ?o 0 (count-commas $?contents) =>
									 $?contents)))
;------------------------------------------------------------------------------
(defrule build-groups::diverge-arguments
			"Splits the set of arguments into two separate facts"
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?start ?finish => $?a "," $?b))
			(test (neq ?start ?finish))
			=>
			(bind ?cca (count-commas $?a))
			(bind ?starta ?start)
			(bind ?enda (+ ?starta ?cca))
			;from start to end
			(bind ?startb (+ 1 ?enda))
			;we use finish since it's the upper bound on this argument set
			(bind ?endb ?finish)
			(modify ?fct (arguments ?o ?starta ?enda => $?a))
			(duplicate ?fct (arguments ?o ?startb ?endb => $?b)))
;------------------------------------------------------------------------------
(defrule build-groups::generate-build-argument-statement
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?pos ?pos => $?conditions))
			=>
			(modify ?fct (action build-argument)
					  (arguments ?o ?pos => $?conditions)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-fixed-array
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?field "[" ?size "]"))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?field))
			(make-instance ?name of GLAPIFixedArrayArgument
								(parent ?o)
								(array-size ?size)
								(index ?ind)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-generic
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?input))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?input))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index ?ind)))
;------------------------------------------------------------------------------
; grouping-update module
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-pointer
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before "*" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-pointer TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-constant
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before const|"const" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-constant TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::set-argument-core-info
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => ?type ?name))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o =>))

			(modify-instance ?obj (argument-type ?type)
								  (argument-name ?name)))
;------------------------------------------------------------------------------
(defrule grouping-update::retract-arguments
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o =>))
			(object (is-a GLAPIArgument)
					  (id ?o)
					  (parent ?p))
			=>
			(modify ?fct (action make-function-builder)
					  (arguments ?p)))
;------------------------------------------------------------------------------
(defclass types::FunctionBuilder
  "Builds C functions"
  (is-a Object)
  (multislot contents))
;------------------------------------------------------------------------------
(defclass types::CLIPSFunctionBuilder
  (is-a FunctionBuilder)
  (multislot data-objects)
  (multislot variables)
  (multislot parsing-entries)
  (slot count))
;------------------------------------------------------------------------------
; So, what do we need to do to construct a single function
; 0) Generate the registration entry for the target builder
; 1) Generate the function builder (done)
; 2) Define required arguments
; 3) Figure out type conversions
; 4) Define translation code for each argument
; 5) Generate code to call the target function with the given arguments
; 6) Assemble the function together
;------------------------------------------------------------------------------
; We use EnvDefineFunction in all cases of registration
;
; For conversion of pointers, we take in a multifield from clips and convert
; that to a corresponding pointer. We can also use macros or a function to
; do the conversion, that would make this whole process a lot easier.
;
; While it goes against the standard practices of C, I am going to have this
; conversion function perform the malloc and return the pointer. It is up to
; the function that called the conversion function to clean up the pointer once
; finished.
;
; However, continually calling malloc and free is costly. We can allocate a
; pointer ahead of time and continually resize it as necessary. We could also
; define a huge block of memory and then slice it accordingly.
;
; I know this for certain, this technique will go through many iterations
; before I arrive at a valid solution (most likely).
;
; The functions that take in a fixed size array are easy because I can allocate
; a static block ahead of time that I can read and write from.
;------------------------------------------------------------------------------
(defrule grouping-update::make-function-builder
			?fct <- (message (to grouping-update)
								  (action make-function-builder)
								  (arguments ?p))
			=>
			(modify ?fct (action build-function)
					  (arguments ?p -1))
			(make-instance of CLIPSFunctionBuilder
								(parent ?p)))
;------------------------------------------------------------------------------
(defrule grouping-update::build-function-header
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p -1))
			?obj <- (object (is-a CLIPSFunctionBuilder)
								 (parent ?p))
			(object (is-a GLAPIFunction)
					  (id ?p)
					  (return-type ?ret)
					  (clips-function-name ?cfn))
			=>
			(modify ?fct (arguments ?p 0))
			(modify-instance ?obj (contents
											(format nil "extern %s %s(void* theEnv) {"
													  ?ret ?cfn))))
;------------------------------------------------------------------------------
(defrule grouping-update::build-function-add-argument
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p ?index))
			?arg <- (object (is-a GLAPIArgument)
								 (parent ?p)
								 (index ?index)
								 (id ?argID))
			?obj <- (object (is-a CLIPSFunctionBuilder)
								 (parent ?p)
								 (parsing-entries $?pe)
								 (contents $?contents))
			=>
			(modify ?fct (arguments ?p (+ ?index 1)))
			(modify-instance ?obj
								  (contents $?contents
												(format nil "//code to handle %s"
														  (send ?arg reconstitute)))))
;------------------------------------------------------------------------------
(defrule grouping-update::close-function
			(declare (salience -1))
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p ?index))
			(not (exists (object (is-a GLAPIArgument)
										(parent ?p)
										(index ?index))))
			?f <- (object (is-a CLIPSFunctionBuilder)
							  (parent ?p)
							  (contents $?contents))
			=>
			(modify ?fct (action print-function)
					  (arguments ?p))
			(modify-instance ?f (contents $?contents "}")
								  (count ?index)))
;------------------------------------------------------------------------------
(defrule grouping-update::print-built-function
			?fct <- (message (to grouping-update)
								  (action print-function)
								  (arguments ?p))
			?f <- (object (is-a FunctionBuilder)
							  (parent ?p)
							  (contents $?c))
			=>
			(progn$ (?line ?c)
					  (printout t ?line crlf))
			(printout t crlf crlf)
			(retract ?fct)
			(unmake-instance ?f))
;------------------------------------------------------------------------------


Fixed the module that the Message template belongs to

I made a typo and put type instead of types

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Message.clp - Contains a message template useful in a wide variety of
; situations
;------------------------------------------------------------------------------
(deftemplate types::message
 (slot from)
 (slot to)
 (slot action)
 (multislot arguments))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Message.clp - Contains a message template useful in a wide variety of
; situations
;------------------------------------------------------------------------------
(deftemplate type::message
 (slot from)
 (slot to)
 (slot action)
 (multislot arguments))
;------------------------------------------------------------------------------


src/lib/cortex/core: Added Message.clp

src/lib/cortex/core: Added Message.clp

Defines the concept of a message for cross module communication.

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Message.clp - Contains the message template which is a standard way to pass
; knowledge between modules that have no knowledge of one another.
;
; Use of messages also allows programmers to use modify and duplicate to cut
; down on the amount of redundant typing which can potentially lead to a
; reduction in the overall error rate.
;------------------------------------------------------------------------------
(deftemplate cortex::message
             "Provides a communication medium between modules"
             (slot to (type SYMBOL))
             (slot from (type SYMBOL))
             (slot action (type SYMBOL))
             (multislot arguments))
;------------------------------------------------------------------------------

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


branch

branch

; -*- clips -*-

;; **********************************************************************
;;                           Frame.clp
;;
;; A nifty example of building a a Swing GUI using jess reflection.
;; Using this package, we can create java objects, call their methods,
;; access their fields, and respond to GUI events.
;; You can therefore build an entire GUI application without actually
;; writing any Java code!
;;
;; **********************************************************************

;; ******************************
;; Declarations

(import javax.swing.*)
;; Explicit import so we get JFrame.EXIT_ON_CLOSE
(import javax.swing.JFrame)
(import java.awt.event.ActionListener)
(import java.awt.BorderLayout)
(import java.awt.Color)

;; ******************************
;; DEFGLOBALS

(defglobal ?*f* = 0)
(defglobal ?*c* = 0)
(defglobal ?*d* = 0)
(defglobal ?*e* = 0)

(defglobal ?*m* = 0)
(defglobal ?*envi* = 0)

;; ******************************
;; DEFFUNCTIONS

(deffunction create-frame ()
  (bind ?*f* (new JFrame "Jess Reflection Demo"))
  (bind ?*c* (?*f* getContentPane))
  (set ?*c* background (Color.magenta)))

(deffunction add-widgets ()
  (?*c* add (new JLabel "This is: ") (BorderLayout.CENTER))
  (bind ?*m* (new JComboBox))
  (bind ?*d* (new JComboBox))
  (bind ?*e* (new JComboBox))
  (?*m* addItem "paper")
  (?*m* addItem "tools")
  (?*m* addItem "buildings")
  (?*m* addItem "numbers")
  (?*c* add ?*m* (BorderLayout.SOUTH))
  (bind ?*envi* ?*m* selectedItem)
  (assert (environment ?*envi*))
  (?*e* addItem "paper")
  (?*e* addItem "tools")
  (?*e* addItem "buildings")
  (?*e* addItem "numbers")
  (?*c* add ?*e* (BorderLayout.NORTH))
  (bind ?*envi* ?*m* selectedItem)
  (assert (environment ?*envi*))
  (?*d* addItem "paper")
  (?*d* addItem "tools")
  (?*d* addItem "buildings")
  (?*d* addItem "numbers")
  (?*c* add ?*d* )
  (bind ?*envi* ?*d* selectedItem )
  (assert (environment ?*envi*)))

(deffunction add-behaviours ()
  (?*f* setDefaultCloseOperation (JFrame.EXIT_ON_CLOSE))

  (?*m* addActionListener (implement ActionListener using
    (lambda (?name ?event)
      (printout t "You chose: " (get ?*m* selectedItem) crlf)))))

(deffunction show-frame ()
  ;(?*f* pack)
    (?*f* setSize 200 300)
  (?*f* setVisible TRUE))

;; ******************************
;; Run the program

(defrule init-rule
    (initial-fact)
    =>
    (create-frame)
    (add-widgets)
    (add-behaviours)
    (show-frame))

(reset)
(run)

;;test now 2
;;howareyougit


new branch

new branch

; -*- clips -*-

;; **********************************************************************
;;                           Frame.clp
;;
;; A nifty example of building a a Swing GUI using jess reflection.
;; Using this package, we can create java objects, call their methods,
;; access their fields, and respond to GUI events.
;; You can therefore build an entire GUI application without actually
;; writing any Java code!
;;
;; **********************************************************************

;; ******************************
;; Declarations

(import javax.swing.*)
;; Explicit import so we get JFrame.EXIT_ON_CLOSE
(import javax.swing.JFrame)
(import java.awt.event.ActionListener)
(import java.awt.BorderLayout)
(import java.awt.Color)

;; ******************************
;; DEFGLOBALS

(defglobal ?*f* = 0)
(defglobal ?*c* = 0)
(defglobal ?*d* = 0)
(defglobal ?*e* = 0)

(defglobal ?*m* = 0)
(defglobal ?*envi* = 0)

;; ******************************
;; DEFFUNCTIONS

(deffunction create-frame ()
  (bind ?*f* (new JFrame "Jess Reflection Demo"))
  (bind ?*c* (?*f* getContentPane))
  (set ?*c* background (Color.magenta)))

(deffunction add-widgets ()
  (?*c* add (new JLabel "This is: ") (BorderLayout.CENTER))
  (bind ?*m* (new JComboBox))
  (bind ?*d* (new JComboBox))
  (bind ?*e* (new JComboBox))
  (?*m* addItem "paper")
  (?*m* addItem "tools")
  (?*m* addItem "buildings")
  (?*m* addItem "numbers")
  (?*c* add ?*m* (BorderLayout.SOUTH))
  (bind ?*envi* ?*m* selectedItem)
  (assert (environment ?*envi*))
  (?*e* addItem "paper")
  (?*e* addItem "tools")
  (?*e* addItem "buildings")
  (?*e* addItem "numbers")
  (?*c* add ?*e* (BorderLayout.NORTH))
  (bind ?*envi* ?*m* selectedItem)
  (assert (environment ?*envi*))
  (?*d* addItem "paper")
  (?*d* addItem "tools")
  (?*d* addItem "buildings")
  (?*d* addItem "numbers")
  (?*c* add ?*d* )
  (bind ?*envi* ?*d* selectedItem )
  (assert (environment ?*envi*)))

(deffunction add-behaviours ()
  (?*f* setDefaultCloseOperation (JFrame.EXIT_ON_CLOSE))

  (?*m* addActionListener (implement ActionListener using
    (lambda (?name ?event)
      (printout t "You chose: " (get ?*m* selectedItem) crlf)))))

(deffunction show-frame ()
  ;(?*f* pack)
    (?*f* setSize 200 300)
  (?*f* setVisible TRUE))

;; ******************************
;; Run the program

(defrule init-rule
    (initial-fact)
    =>
    (create-frame)
    (add-widgets)
    (add-behaviours)
    (show-frame))

(reset)
(run)

;;test now