Commit 61a3e8b5 authored by Dave Cooper's avatar Dave Cooper

Merge branch 'release/1590' into devo

parents 770de4bd e269264d
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:dom :description
"The Gendl\" dom Subsystem" :author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160417" :depends-on (:cl-who :yadd)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "base/source/package") (:file "base/source/assembly")
(:file "writers/source/package")
(:file "writers/source/dom-writer") (:file "writers/source/html")
(:file "writers/source/latex") (:file "writers/source/plain-text")
(:file "html/source/package") (:file "html/source/lenses")
(:file "latex/source/package") (:file "latex/source/lenses")
(:file "latex/source/utilities")
(:file "test-parts/source/assembly")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:dom :description
"The Gendl\" dom Subsystem" :author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160505" :depends-on (:cl-who :yadd)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "base/source/package") (:file "base/source/assembly")
(:file "writers/source/package")
(:file "writers/source/dom-writer") (:file "writers/source/html")
(:file "writers/source/latex") (:file "writers/source/plain-text")
(:file "html/source/package") (:file "html/source/lenses")
(:file "latex/source/package") (:file "latex/source/lenses")
(:file "latex/source/utilities")
(:file "test-parts/source/assembly")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:ta2 :description
"The Gendl\" (legacy) Testing and Tracking Utility, version 2 (using Ajax but pre-gdlAjax, and no JQuery or CSS)"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160417" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/parameters")
(:file "source/javascript") (:file "source/action-object")
(:file "source/ajax") (:file "source/assembly")
(:file "source/click-mode") (:file "source/inspector")
(:file "source/object-tree") (:file "source/part-type-form")
(:file "source/publish") (:file "source/viewport")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:ta2 :description
"The Gendl\" (legacy) Testing and Tracking Utility, version 2 (using Ajax but pre-gdlAjax, and no JQuery or CSS)"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160505" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/parameters")
(:file "source/javascript") (:file "source/action-object")
(:file "source/ajax") (:file "source/assembly")
(:file "source/click-mode") (:file "source/inspector")
(:file "source/object-tree") (:file "source/part-type-form")
(:file "source/publish") (:file "source/viewport")))
......@@ -433,53 +433,54 @@ The error was: ~a
((:div :id "tabs" :class "page-layout-center")
((:ul :id "TabButtons" :class "pane")
(:li ((:a :href "#ApplicationLayout")(:span "Application")))
(:li ((:a :href "#Documentation")(:span "Documentation")))
;;(:li ((:a :href "#ApplicationLayout")(:span "Application")))
;;(:li ((:a :href "#Documentation")(:span "Documentation")))
)
;; wrap tab-panels in ui-layout-content div
((:div :id "TabPanelsContainer" :class "pane")
;; TAB #1
((:div :id "ApplicationLayout")
((:div :id "ApplicationLayout")
((:div :id "InnerLayout" :class "outer-center pane")
((:div :id "InnerLayout" :class "outer-center pane")
((:div :class "inner-center ui-widget pane")
((:div :class "header ui-widget-header")"Viewport")
((:div :class "ui-widget-content")(str (the viewport main-div)))
((:div :class "footer ui-widget-header")
((:div :class "inner-center ui-widget pane")
((:div :class "header ui-widget-header")"Viewport")
((:div :class "ui-widget-content")(str (the viewport main-div)))
((:div :class "footer ui-widget-header")
(str (the footer-ui-widget-header main-div))))
(str (the footer-ui-widget-header main-div))))
((:div :class "inner-west ui-widget pane")
((:div :class "header ui-widget-header")"Inspector")
((:div :class "ui-widget-content")
(str (the inspector main-div))))
((:div :class "inner-west ui-widget pane")
((:div :class "header ui-widget-header")"Inspector")
((:div :class "ui-widget-content")
(str (the inspector main-div))))
((:div :class "inner-north ui-widget pane")
((:div :class "header ui-widget-header")"Inner North")
((:div :class "ui-widget-content")(:span "Inner North"))))
((:div :class "inner-north ui-widget pane")
((:div :class "header ui-widget-header")"Inner North")
((:div :class "ui-widget-content")(:span "Inner North"))))
((:div :class "outer-west ui-widget pane")
((:div :class "header ui-widget-header")"Tree")
((:div :class "ui-widget-content"
((:div :class "outer-west ui-widget pane")
((:div :class "header ui-widget-header")"Tree")
((:div :class "ui-widget-content"
:style (format nil "background-color: ~a" (or (getf *colors-default* :background) "#fafafa")))
(str (the tree main-div)))
((:div :class "footer ui-widget-header")
"Click-mode:" (str (the tree-status-object main-div)))
)
(str (the tree main-div)))
((:div :class "footer ui-widget-header")
"Click-mode:" (str (the tree-status-object main-div)))
)
((:div :class "outer-north ui-widget pane")
((:div :class "outer-north ui-widget pane")
((:div :onmouseover "InnerLayout.allowOverflow(this)")
(str (the menu-section main-div))))
((:div :class "outer-south ui-widget pane")
((:div :class "footer ui-widget-header")
((:span :class "fltrt")
"powered by "
((:div :class "outer-south ui-widget pane")
((:div :class "footer ui-widget-header")
((:span :class "fltrt")
"powered by "
((:a :href "http://www.genworks.com" :target "_new") "Genworks GDL")
(str (if (glisp:featurep :smlib) ", " " and "))
((:a :href "http://www.quicklisp.org" :target "_new")"Quicklisp")
......@@ -488,52 +489,53 @@ The error was: ~a
(str ", and ")
(htm ((:a :href "http://www.smlib.com" :target "_new") "SMLib")))
""))
((:span) "GDL status: ")
((:span :id "gdlStatus")"Done.")
(when *tasty-developing?*
(htm
(:span " | ")
(:span
((:span :onclick (the (gdl-ajax-call :function-key :update-object!
:arguments (list self)))
:title "Full Update of Tasty Browser and Object in Tree (for tasty development)"
:style "color: blue; cursor: pointer;") "Update!")
" | "
((:span :onclick (the (gdl-ajax-call :function-key :set-self!
:arguments (list self)))
:title "Set self to this tasty object (for tasty development)"
:style "color: blue; cursor: pointer;") "Set Self!"))
((:span) "GDL status: ")
((:span :id "gdlStatus")"Done.")
(when *tasty-developing?*
(htm
(:span " | ")
(:span
((:span :onclick (the (gdl-ajax-call :function-key :update-object!
:arguments (list self)))
:title "Full Update of Tasty Browser and Object in Tree (for tasty development)"
:style "color: blue; cursor: pointer;") "Update!")
" | "
((:span :onclick (the (gdl-ajax-call :function-key :set-self!
:arguments (list self)))
:title "Set self to this tasty object (for tasty development)"
:style "color: blue; cursor: pointer;") "Set Self!"))
;;(write-the development-links)
;;(write-the development-links)
;;(write-the break-link) (htm " | ")(write-the update-full-link)
;;(write-the break-link) (htm " | ")(write-the update-full-link)
))
))
#+nil
(when (typep (the root-object) 'base-html-sheet)
(htm (:span " | ")
((:a :href (the root-object url)) "Visit UI")))))
#+nil
(when (typep (the root-object) 'base-html-sheet)
(htm (:span " | ")
((:a :href (the root-object url)) "Visit UI")))))
((:div :class "outer-east ui-widget pane")
((:div :class "header ui-widget-header")"Auxiliary")
((:div :class "ui-widget-content")(:span "Auxiliary Pane Content"))
((:div :class "outer-east ui-widget pane")
((:div :class "header ui-widget-header")"Auxiliary")
((:div :class "ui-widget-content")(:span "Auxiliary Pane Content"))
)
)
);; #ApplicationLayout
) ;; #ApplicationLayout
;; TAB #2
#+nil
((:div :id "Documentation" :class "ui-tabs-hide pane")
((:iframe :class "ui-widget-content" :src "/yadd" :width "100%" :height "500px"))
)
);; END TabPanelsContainer
) ;; END TabPanelsContainer
)
)
))))
......
......@@ -22,6 +22,15 @@
(in-package :tasty)
(let ((tutorial-file
(or (probe-file (merge-pathnames "../doc/tutorial.pdf" (glisp:executable-homedir-pathname)))
(probe-file (merge-pathnames "gendl/documenation/tutorial/pdf/tutorial.pdf" glisp:*genworks-source-home*))
(warn "tutorial.pdf not found in distribution doc/ directory or source documentation directory for
publishing in tasty Help menu.~%"))))
(when tutorial-file (publish-file :path "/tutorial.pdf"
:file (namestring (truename tutorial-file)))))
(define-object menu-section (sheet-section)
:input-slots (tatu-root
......@@ -425,7 +434,9 @@
((:li :id "menuHelp" :class "top")
"Help"
(:ul
(:li ((:a :href "http://www.genworks.com" :target "_new") "Documentation"))
(:li ((:a :href "/yadd" :target "_new") "Reference Documentation"))
(:li ((:a :href "/tutorial.pdf" :target "_new") "Tutorial/Manual"))
(:li ((:a :href "http://www.genworks.com" :target "_new") "Genworks Site"))
(:li ((:a :href "http://www.genworks.com/dl" :target "_new") "Check for Updates"))
(:li ((:a :href "http://www.genworks.com" :target "_new") "Contact Us"))
)))))
......
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:tasty :description
"The Gendl\" Web-based Development Environment (tasty)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160417" :depends-on (:tree :gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/parameters")
(:file "source/assembly") (:file "source/initialize")
(:file "source/inspector") (:file "source/menu")
(:file "source/new-inspector") (:file "source/newer-inspector")
(:file "source/part-type-form") (:file "source/publish")
(:file "source/status-object") (:file "source/test-part")
(:file "source/test-part2") (:file "source/two-viewports")
(:file "source/viewport") (:file "source/zzinit")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:tasty :description
"The Gendl\" Web-based Development Environment (tasty)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160505" :depends-on (:tree :gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/parameters")
(:file "source/assembly") (:file "source/initialize")
(:file "source/inspector") (:file "source/menu")
(:file "source/new-inspector") (:file "source/newer-inspector")
(:file "source/part-type-form") (:file "source/publish")
(:file "source/status-object") (:file "source/test-part")
(:file "source/test-part2") (:file "source/two-viewports")
(:file "source/viewport") (:file "source/zzinit")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:translators :description
"The Gendl\" Translators to/from XML and potentially other high-level KBE and Knowledge formats"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160417" :depends-on (:gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "xml/source/package") (:file "xml/source/genworks")
(:file "xml/source/definition-tree") (:file "xml/source/gdl2xml")
(:file "xml/source/xml2gdl")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:translators :description
"The Gendl\" Translators to/from XML and potentially other high-level KBE and Knowledge formats"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160505" :depends-on (:gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "xml/source/package") (:file "xml/source/genworks")
(:file "xml/source/definition-tree") (:file "xml/source/gdl2xml")
(:file "xml/source/xml2gdl")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:tree :description
"The Gendl\" Tree component used by Tasty and potentially as a UI component on its own"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160417" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/parameters")
(:file "source/ajax") (:file "source/assembly")
(:file "source/newertree")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:tree :description
"The Gendl\" Tree component used by Tasty and potentially as a UI component on its own"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160505" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/parameters")
(:file "source/ajax") (:file "source/assembly")
(:file "source/newertree")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:yadd :description
"The Gendl\" Yet Another Definition Documenter (yadd)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160417" :depends-on
(:gwl-graphics #-allegro :cl-html-parse)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/genworks")
(:file "source/parameters") (:file "source/mixins")
(:file "source/define-object-documentation")
(:file "source/assembly") (:file "source/ass")
(:file "source/format-documentation")
(:file "source/function-documentation") (:file "source/initialize")
(:file "source/publish") (:file "source/test-part")
(:file "source/variable-documentation") (:file "source/zzinit")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:yadd :description
"The Gendl\" Yet Another Definition Documenter (yadd)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20160505" :depends-on
(:gwl-graphics #-allegro :cl-html-parse)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/genworks")
(:file "source/parameters") (:file "source/mixins")
(:file "source/define-object-documentation")
(:file "source/assembly") (:file "source/ass")
(:file "source/format-documentation")
(:file "source/function-documentation") (:file "source/initialize")
(:file "source/publish") (:file "source/test-part")
(:file "source/variable-documentation") (:file "source/zzinit")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:base :description
"The Gendl\" Base Core Kernel Engine" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20160417" :depends-on (:bordeaux-threads)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/genworks")
(:file "source/presets") (:file "source/parameters")
(:file "source/metaclasses") (:file "source/utilities")
(:file "source/start") (:file "source/syntax-checker")
(:file "expanders/source/inputs")
(:file "expanders/source/computed-slots")
(:file "expanders/source/functions")
(:file "expanders/source/methods")
(:file "expanders/source/objects")
(:file "macros/source/reference")
(:file "macros/source/message-utils")
(:file "macros/source/define-object")
(:file "macros/source/defaulting")
(:file "macros/source/define-format")
(:file "rest/source/parameters")
(:file "rest/source/quantification")
(:file "rest/source/aggregate") (:file "rest/source/utilities")
(:file "rest/source/null-part") (:file "rest/source/vanilla-mixin")
(:file "rest/source/base-rule-object") (:file "rest/source/bodies")
(:file "rest/source/ignore-errors-with-backtrace")
(:file "rest/source/init") (:file "rest/source/make-part")
(:file "rest/source/sequence") (:file "zzinit/source/initialize")
(:file "zzinit/source/zzinit")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:base :description
"The Gendl\" Base Core Kernel Engine" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20160505" :depends-on (:bordeaux-threads)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/genworks")
(:file "source/presets") (:file "source/parameters")
(:file "source/metaclasses") (:file "source/utilities")
(:file "source/start") (:file "source/syntax-checker")
(:file "expanders/source/inputs")
(:file "expanders/source/computed-slots")
(:file "expanders/source/functions")
(:file "expanders/source/methods")
(:file "expanders/source/objects")
(:file "macros/source/reference")
(:file "macros/source/message-utils")
(:file "macros/source/define-object")
(:file "macros/source/defaulting")
(:file "macros/source/define-format")
(:file "rest/source/parameters")
(:file "rest/source/quantification")
(:file "rest/source/aggregate") (:file "rest/source/utilities")
(:file "rest/source/null-part") (:file "rest/source/vanilla-mixin")
(:file "rest/source/base-rule-object") (:file "rest/source/bodies")
(:file "rest/source/ignore-errors-with-backtrace")
(:file "rest/source/init") (:file "rest/source/make-part")
(:file "rest/source/sequence") (:file "zzinit/source/initialize")
(:file "zzinit/source/zzinit")))
......@@ -75,12 +75,12 @@
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((*error-on-not-handled?* t))
(with-dependency-tracking (,attr-sym)
,(if query? `(iq:qlet (()) ,attr-expr) attr-expr))
#+nil
(with-dependency-tracking (,attr-sym)
,(if query? `(iq:qlet (()) ,attr-expr) attr-expr))
#+nil
(with-dependency-tracking (,attr-sym)
,(if query? (error "Query-slots are not supported in this distribution of Genworks GDL.")
attr-expr)))))
attr-expr)))))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object")))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
......@@ -89,18 +89,16 @@
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((,self-arg gdl-remote) &rest ,args-arg)
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym))
,args-arg)))))))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))))))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))))))
computed-slots))
......
......@@ -66,14 +66,14 @@
,(if has-declare? (first body) `(declare))
,(when *compile-circular-reference-detection?*
`(when (and *run-with-circular-reference-detection?*
(member (list self ',attr-sym) *till-now* :test #'equalp))
(error "Circular reference detected")))
`(when (and *run-with-circular-reference-detection?*
(member (list self ',attr-sym) *till-now* :test #'equalp))
(error "Circular reference detected")))
(let ,(remove nil
(list (when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list self ',attr-sym) *till-now*))))))
(list (when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list self ',attr-sym) *till-now*))))))
(block ,(make-keyword attr-sym)
(let ((*error-on-not-handled?* t))
,@(if has-declare? (rest body) body))))) ,args-arg))
......@@ -86,9 +86,9 @@
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((,self-arg gdl-remote) &rest ,args-arg)
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym)) ,args-arg)))))))
;;
;; FLAG -- why is this needed??
;;
;;
;; FLAG -- why is this needed??
;;
`(when (or (not (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)))
......@@ -96,8 +96,8 @@
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))))))
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))))))
......
......@@ -24,7 +24,7 @@
(defun not-handled (object message &optional args)
(if *error-on-not-handled?*
(not-handled-error object message args)
'gdl-rule:%not-handled%))
'gdl-rule:%not-handled%))
(defun input-slots-generics (input-slots)
......@@ -76,8 +76,8 @@
(mapcan
#'(lambda(input)
(let* ((attr-sym (glisp:intern (symbol-name (if (symbolp input)
input
(message-symbol input))) :gdl-acc))
input
(message-symbol input))) :gdl-acc))
(attr-remarks (when (consp input) (message-strings input))))
(remove
nil
......@@ -91,26 +91,28 @@
(when (and *compile-for-dgdl?* (not (eql attr-sym 'gdl-acc::type)))
`(unless (find-method (symbol-function ',(glisp:intern attr-sym :gdl-inputs))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern attr-sym :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg)))))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern attr-sym :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg)))))
;;
;; FLAG -- added recently, because why wouldn't we need default message handlers for input-slots?
;;
;; FLAG -- did this cause problems for DAP? Keep an eye out for this.
;;
;; FLAG -- added recently, because why wouldn't we need default message handlers for input-slots?
;;
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))
......@@ -123,14 +125,14 @@
(if ,parent-arg
(let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object self %name%) self))
'gdl-rule:%not-handled%)))
,parent-arg (the-object self %name%) self))
'gdl-rule:%not-handled%)))
(cond ((not (eql ,val-arg 'gdl-rule:%not-handled%)) ,val-arg)
((and ,parent-arg (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)))
(if ;;(member ,(make-key attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(gethash ,(make-keyword attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(,(glisp:intern (symbol-name attr-sym) :gdl-slots) ,parent-arg)
(funcall (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)) ,parent-arg)))
(gethash ,(make-keyword attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(,(glisp:intern (symbol-name attr-sym) :gdl-slots) ,parent-arg)
(funcall (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)) ,parent-arg)))
(t (not-handled self ,(make-keyword attr-sym) ,args-arg)))))))))))) input-slots))
(defun optional-input-slots-section (name input-slots &optional (defaulted? nil))
......@@ -161,12 +163,13 @@
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object") ))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object")))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern attr-sym :gdl-slots))
nil (list (find-class 'gdl-remote)) nil)))
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((self gdl-remote) &rest ,args-arg)
(the (send (:apply (cons ,(make-keyword (symbol-name attr-sym)) ,args-arg)))))))
(when *compile-for-dgdl?*
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-remote)
......@@ -191,13 +194,13 @@
`(if (eql ,val-arg 'gdl-rule:%not-handled%)
(let ((,val-arg (if ,parent-arg
(let (*error-on-not-handled?*)
(if (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs))
(,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs) self)
'gdl-rule:%not-handled%))
(if (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs))
(,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs) self)
'gdl-rule:%not-handled%))
,val-arg)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))
,val-arg)
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))))))))))) input-slots))
,val-arg)
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))))))))))) input-slots))
......
......@@ -25,28 +25,28 @@
(defun object-inputs-generics-section (cooked-data &key special-keys)
(let ((object-input-keys (remove-duplicates
(cons :%parameters%
(apply #'append (mapcar #'(lambda(data)
(let ((plist-keys (mapcar #'make-keyword (append (plist-keys (getf data :plist))
(getf data :with-attribute-keys)))))
(set-difference plist-keys special-keys))) cooked-data))))))
(cons :%parameters%
(apply #'append (mapcar #'(lambda(data)
(let ((plist-keys (mapcar #'make-keyword (append (plist-key