update BeerEX.clp

update BeerEX.clp

(load clips/beerex.clp)

(deffunction ask-question (?display ?allowed-values)
   (bind ?answer "")
   (while (not (member ?answer ?allowed-values))
      (if (not (member$ prev ?allowed-values))
       then (printout t crlf))
      (printout t " " ?display " " ?allowed-values " ")
      (bind ?answer (readline))
      (if (eq (str-index " " ?answer) FALSE)
       then (bind ?answer (nth$ 1 (explode$ ?answer)))))
   ?answer)

(deffunction next-UI-state ()
   (do-for-fact ((?s state-list)) TRUE (and (bind ?current-id ?s:current)
                                            (bind ?sequence ?s:sequence)))
   (do-for-fact ((?u UI-state)) (eq ?u:id ?current-id) (and (bind ?display ?u:display)
                                                            (bind ?help ?u:help)
                                                            (bind ?why ?u:why)
                                                            (bind ?state ?u:state)
                                                            (bind ?valid-answers ?u:valid-answers)))
   (if (eq ?state initial)
    then (assert (next ?current-id))
         (run)
         (next-UI-state))
   (if (eq ?state middle)
    then (bind ?allowed-values ?valid-answers)
         (if (neq ?help nil)
          then (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) help)))
         (if (neq ?why nil)
          then (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) why)))
         (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) cancel))
         (if (> (length$ ?sequence) 2)
          then (bind ?allowed-values (insert$ ?allowed-values (length$ ?allowed-values) prev)))
         (bind ?answer (ask-question ?display ?allowed-values)))
   (if (eq ?state final)
    then (bind ?answer (ask-question ?display (create$ prev restart cancel))))
   (if (member$ ?answer ?valid-answers)
    then (assert (next ?current-id ?answer))
         (run)
         (next-UI-state))
   (if (eq ?answer help)
    then (printout t ?help crlf)
         (next-UI-state))
   (if (eq ?answer why)
    then (printout t ?why crlf)
         (next-UI-state))
   (if (eq ?answer prev)
    then (assert (prev ?current-id))
         (run)
         (next-UI-state))
   (if (eq ?answer restart)
    then (reset)
         (run)
         (next-UI-state))
   (if (eq ?answer cancel)
    then (exit)))

(reset)
(run)

(next-UI-state)

(load clips/beerex.clp)

(deffunction ask-question (?display ?allowed-values)
   (bind ?answer "")
   (while (not (member ?answer ?allowed-values))
      (printout t " "?display " " ?allowed-values " ")
      (bind ?answer (readline))
      (if (eq (str-index " " ?answer) FALSE)
       then (bind ?answer (nth$ 1 (explode$ ?answer)))))
   ?answer)

(deffunction next-UI-state ()
   (do-for-fact ((?s state-list)) TRUE (and (bind ?current-id ?s:current)
                                            (bind ?sequence ?s:sequence)))
   (do-for-fact ((?u UI-state)) (eq ?u:id ?current-id) (and (bind ?display ?u:display)
                                                            (bind ?help ?u:help)
                                                            (bind ?why ?u:why)
                                                            (bind ?state ?u:state)
                                                            (bind ?valid-answers ?u:valid-answers)))
   (if (eq ?state initial)
    then (assert (next ?current-id))
         (run)
         (next-UI-state))
   (if (eq ?state middle)
    then (if (> (length$ ?sequence) 2)
          then (bind ?answer
                     (ask-question ?display (insert$ ?valid-answers (+ (length$ ?valid-answers) 1) help why prev cancel)))
          else (bind ?answer
                     (ask-question ?display (insert$ ?valid-answers (+ (length$ ?valid-answers) 1) help why cancel)))))
   (if (eq ?state final)
    then (bind ?answer (ask-question ?display (create$ prev restart cancel))))
   (if (member$ ?answer ?valid-answers)
    then (assert (next ?current-id ?answer))
         (run)
         (next-UI-state))
   (if (eq ?answer help)
    then (printout t ?help crlf)
         (next-UI-state))
   (if (eq ?answer why)
    then (printout t ?why crlf)
         (next-UI-state))
   (if (eq ?answer prev)
    then (assert (prev ?current-id))
         (run)
         (next-UI-state))
   (if (eq ?answer restart)
    then (reset)
         (run)
         (next-UI-state))
   (if (eq ?answer cancel)
    then (exit)))

(reset)
(run)

(next-UI-state)


add track

add track

; -*- 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


Imported more features from the old chicanery libs

(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))

(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)))))

(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))
(definstances default-points
              (ZP of point
                  (x 0)
                  (y 0)))
(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))

(definstances default-rectangle-types
              (pixel of rectangle
                     (x 0)
                     (y 0)
                     (bx 1)
                     (by 1)))
(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))
(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 WavefrontPropagation.clp

Fixed bugs in WavefrontPropagation.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-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)
                 (values $? ?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 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))
;------------------------------------------------------------------------------


Added SetExtensions.clp

Added SetExtensions.clp

It contains a list of functions that are useful for set operations

;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.
;------------------------------------------------------------------------------
; SetExtensions.clp - Contains set operations such as superset and equality
;------------------------------------------------------------------------------
(deffunction core::superset (?a ?b)
				 (and (>= (length$ ?a) (length$ ?b))
						(subsetp ?b ?a) (not (subsetp ?a ?b))))
;------------------------------------------------------------------------------
(deffunction core::equal$ (?a ?b)
				 (and
					(= (length$ ?a) (length$ ?b))
					(subsetp ?b ?a)
					(subsetp ?a ?b)))
;------------------------------------------------------------------------------
(deffunction core::has-common-element (?a ?b)
				 (progn$ (?c ?a)
							(if (member$ ?c ?b) then (return TRUE)))
				 (return FALSE))
;------------------------------------------------------------------------------
(deffunction core::disjoint (?a ?b)
				 (not (has-common-element ?a ?b)))
;------------------------------------------------------------------------------

error: pathspec 'modules/core/SetExtensions.clp' did not match any file(s) known to git


Deleted shell.clp

Deleted shell.clp

It is no longer necessary in the new filesystem

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


Added an example configuration file for srv/interface

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

(deffacts interface
          (message (action declare-target-interface)
                   (contents int0 (fs /dev/int0))))

error: pathspec 'conf/srv/interface.clp' did not match any file(s) known to git


Formatting changes

Formatting changes

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

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


Create task4.clp

Create task4.clp

(deffunction str-stars (?str ?n)
    (while (> ?n 0) do
        (bind ?str (str-cat ?str "*"))
        (bind ?n (- ?n 1))
    )
    ?str
)

(defrule str_start
=>
(bind ?str1 (read))
(bind ?str2 (read))
(if (> (str-length ?str1) (str-length ?str2)) then
    (bind ?diff (- (str-length ?str1) (str-length ?str2)))
    (printout t ?str1 crlf)
    (printout t (str-stars ?str2 ?diff) crlf)
else
    (bind ?diff (- (str-length ?str2) (str-length ?str1)))
    (printout t (str-stars ?str1 ?diff) crlf)
    (printout t ?str2 crlf)
))

error: pathspec 'ssu-ai-level-2/chapter7/task4.clp' did not match any file(s) known to git


two files changed for knowledge engineering class

(clear)

(deftemplate person "People in actuarial database"
    (slot age)
    (slot name)
    (slot gender))

(assert (person (name "Bob Smith") (age 34) (gender Male)))
(assert (person (gender Male) (name "Tom Smith") (age 32) (gender Male)))
(assert (person (name "Mary Smith") (age 34) (gender Female)))
(assert (person (gender Female) (age 66)))

(defglobal ?*count* = 0)
(defglobal ?*agemin* = 1000)
(defrule male-ages
    (person (name ?n) (age ?a) (gender Male) )
    =>
    (printout t ?n " is " ?a " years old " crlf))
(defrule male-counted
	(person (gender Male))
	=>
	(bind  ?*count* (+ 1 ?*count*))
)

(deffunction show-male-counted ()
	(printout t "amount: " ?*count* " Males "crlf)
)
(defrule youngest
	(person (age ?x))
	=>
	(if (< ?x ?*agemin*)
	then
	(bind ?*agemin* ?x)
	)
)

(deffunction show-youngest ()
	(printout t "youngest: " ?*agemin* crlf)
)
(run)

(show-male-counted)
(show-youngest)

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


Update task5.clp

Update task5.clp

(deffunction trim (?str)
    (bind ?str2 "")
    (bind ?space TRUE)
    (bind ?n (str-length ?str))
    (bind ?i 0)
    (while (<= ?i ?n) do
        (bind ?c1 (sub-string ?i ?i ?str))

        (if (= 0 (str-compare ?c1 " ")) then
            (if (and ?space TRUE) then
                (bind ?space FALSE)
                (bind ?str2 (str-cat ?str2 ?c1))
            )

        else

            (bind ?space TRUE)
            (bind ?str2 (str-cat ?str2 ?c1))
        )
        (bind ?i (+ ?i 1))
    )
    ?str2
)

(deffunction trim (?str)
    (bind ?str2 "")
    (bind ?space True)
    (bind ?n (str-length ?str))
    (bind ?i 0)
    (while (< ?i ?n) do
        (bind ?c1 (sub-string ?i ?i ?str))

        (if (= 0 (str-compare ?c1 " ")) then
            (if (and (?space True)) then
                (printout t "kefal")
                (bind ?space False)
                (bind ?str2 (str-cat ?str2 ?c1))
            )

        else

            (bind ?space True)
            (bind ?str2 (str-cat ?str2 ?c1))
        )
        (bind ?i (+ ?i 1))
    )
    ?str2
)


Fixed another instance where is-registered is called instead of pass-registered

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Pass.clp - Pass types that interact with LibIndirect
;------------------------------------------------------------------------------
(defclass indirect::PassBase
  "The base class of all passes (native or indirect)"
  (is-a Object)
  (slot pass-name (type SYMBOL STRING) (visibility public))
  (slot pass-description (type STRING) (visibility public)))
;------------------------------------------------------------------------------
(defclass indirect::NativePass
  "A wrapper over a native LLVM pass"
  (is-a PassBase)
  (role concrete)
  (pattern-match reactive))
;------------------------------------------------------------------------------
(defclass indirect::Pass
  "Represents an indirect pass that uses LibIndirect to interact with LLVM"
  (is-a PassBase)
  (role concrete)
  (pattern-match reactive)
  (slot pass-type (type SYMBOL) (allowed-symbols Unknown Module Function Region
																 Loop BasicBlock CallGraphSCC MachineFunction))
  (slot is-analysis (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot is-cfg (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot need-loops (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot need-regions (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot preserves-all (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot preserves-cfg (type SYMBOL) (allowed-symbols FALSE TRUE))
  (multislot passes (type SYMBOL))
  (multislot required (type SYMBOL))
  (multislot required-transitive (type SYMBOL))
  (multislot preserved (type SYMBOL))
  ;begin CLIPS specific slots
  (slot entry-point (type STRING))
  (message-handler register)
  (message-handler unregister)
  (message-handler is-registered))
;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass init around ()
						  (call-next-handler)
						  ;automatically load the code if there is an entry point
						  (if (and (< (str-length ?self:entry-point) 0)
									  (not (defmodule-exists ?self:pass-name))) then
							 (batch* ?self:entry-point))
						  (if (not (pass-registered ?self:pass-name)) then
							 (register-pass ?self:pass-name
												 ?self:pass-description
												 ?self:pass-type
												 ?self:is-analysis
												 ?self:is-cfg
												 ?self:need-regions
												 ?self:need-loops
												 ?self:passes
												 ?self:required
												 ?self:required-transitive
												 ?self:preserved
												 ?self:preserves-all
												 ?self:preserves-cfg)))
;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass register ()
						  (if (not (pass-registered ?self:pass-name)) then
							 (register-pass ?self:pass-name
												 ?self:pass-description
												 ?self:pass-type
												 ?self:is-analysis
												 ?self:is-cfg
												 ?self:need-regions
												 ?self:need-loops
												 ?self:passes
												 ?self:required
												 ?self:required-transitive
												 ?self:preserved
												 ?self:preserves-all
												 ?self:preserves-cfg)
							 (return TRUE)
							 else
							 (printout werror "ERROR: pass already registered" crlf)
							 (return FALSE)))

;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass unregister ()
						  (unregister-pass ?self:pass-name))
;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass is-registered ()
						  (pass-registered ?self:pass-name))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Pass.clp - Pass types that interact with LibIndirect
;------------------------------------------------------------------------------
(defclass indirect::PassBase
  "The base class of all passes (native or indirect)"
  (is-a Object)
  (slot pass-name (type SYMBOL STRING) (visibility public))
  (slot pass-description (type STRING) (visibility public)))
;------------------------------------------------------------------------------
(defclass indirect::NativePass
  "A wrapper over a native LLVM pass"
  (is-a PassBase)
  (role concrete)
  (pattern-match reactive))
;------------------------------------------------------------------------------
(defclass indirect::Pass
  "Represents an indirect pass that uses LibIndirect to interact with LLVM"
  (is-a PassBase)
  (role concrete)
  (pattern-match reactive)
  (slot pass-type (type SYMBOL) (allowed-symbols Unknown Module Function Region
																 Loop BasicBlock CallGraphSCC MachineFunction))
  (slot is-analysis (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot is-cfg (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot need-loops (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot need-regions (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot preserves-all (type SYMBOL) (allowed-symbols FALSE TRUE))
  (slot preserves-cfg (type SYMBOL) (allowed-symbols FALSE TRUE))
  (multislot passes (type SYMBOL))
  (multislot required (type SYMBOL))
  (multislot required-transitive (type SYMBOL))
  (multislot preserved (type SYMBOL))
  ;begin CLIPS specific slots
  (slot entry-point (type STRING))
  (message-handler register)
  (message-handler unregister)
  (message-handler is-registered))
;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass init around ()
						  (call-next-handler)
						  ;automatically load the code if there is an entry point
						  (if (and (< (str-length ?self:entry-point) 0)
									  (not (defmodule-exists ?self:pass-name))) then
							 (batch* ?self:entry-point))
						  (if (not (pass-registered ?self:pass-name)) then
							 (register-pass ?self:pass-name
												 ?self:pass-description
												 ?self:pass-type
												 ?self:is-analysis
												 ?self:is-cfg
												 ?self:need-regions
												 ?self:need-loops
												 ?self:passes
												 ?self:required
												 ?self:required-transitive
												 ?self:preserved
												 ?self:preserves-all
												 ?self:preserves-cfg)))
;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass register ()
						  (if (not (is-registered ?self:pass-name)) then
							 (register-pass ?self:pass-name
												 ?self:pass-description
												 ?self:pass-type
												 ?self:is-analysis
												 ?self:is-cfg
												 ?self:need-regions
												 ?self:need-loops
												 ?self:passes
												 ?self:required
												 ?self:required-transitive
												 ?self:preserved
												 ?self:preserves-all
												 ?self:preserves-cfg)
							 (return TRUE)
							 else
							 (printout werror "ERROR: pass already registered" crlf)
							 (return FALSE)))

;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass unregister ()
						  (unregister-pass ?self:pass-name))
;------------------------------------------------------------------------------
(defmessage-handler indirect::Pass is-registered ()
						  (pass-registered ?self:pass-name))
;------------------------------------------------------------------------------