Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
648f2235
Commit
648f2235
authored
Jan 19, 2013
by
Dave Cooper
Browse files
cleaned out some commented code.
parent
792ffc3e
Changes
7
Hide whitespace changes
Inline
Side-by-side
gdl/base/expanders/source/computed-slots.lisp
View file @
648f2235
...
...
@@ -37,17 +37,9 @@
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
message
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
;;
;;FLAG -- replace rest of body with function call.
;;
(
gdl-rule::lookup-parameters
,
self-arg
,
(
make-keyword
message
))
#+
nil
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
message
)
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
self-arg
,
(
make-keyword
message
))
,
val-arg
)))))
messages
)))
(
gdl-rule::lookup-parameters
,
self-arg
,
(
make-keyword
message
)))))
messages
)))
(
defun
computed-slots-section
(
name
computed-slots
&key
query?
)
(
mapcan
#'
(
lambda
(
attribute
)
...
...
@@ -76,10 +68,6 @@
(
with-dependency-tracking
(
,
attr-sym
)
,
(
if
query?
(
error
"Query-slots are not supported in this distribution of Genworks GDL."
)
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,21 +77,6 @@
(
the-object
,
self-arg
(
send
(
:apply
(
cons
,
(
make-keyword
(
symbol-name
attr-sym
))
,
args-arg
)))))))
;;
;; FLAG -- duplicated from inputs.lisp and objects.lisp, functions.lisp, and below in this file.
;;
#+
nil
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
attr-sym
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
))
,
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
)
...
...
@@ -118,137 +91,55 @@
#+
nil
(
defun
computed-slots-section
(
name
computed-slots
&key
query?
)
(
mapcan
#'
(
lambda
(
attribute
)
(
let
((
attr-remarks
(
message-strings
attribute
))
(
attr-sym
(
intern
(
symbol-name
(
message-symbol
attribute
))
:gdl-acc
))
(
attr-expr
(
message-source-code
attribute
)))
(
remove
nil
(
list
(
when
(
and
name
*compile-documentation-database?*
attr-remarks
)
`
(
when
*load-documentation-database?*
(
let
((
ht
(
or
(
message-documentation
(
find-class
',name
))
(
setf
(
message-documentation
(
find-class
',name
))
(
make-hash-table
)))))
(
setf
(
gethash
(
make-keyword
',attr-sym
)
ht
)
,
attr-remarks
))))
(
when
(
and
name
*compile-source-code-database?*
)
`
(
when
*load-source-code-database?*
(
let
((
ht
(
or
(
message-source
(
find-class
',name
))
(
setf
(
message-source
(
find-class
',name
))
(
make-hash-table
)))))
(
setf
(
gethash
(
make-keyword
',attr-sym
)
ht
)
',attr-expr
))))
(
when
name
`
(
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?
(
error
"Query-slots are not supported in this distribution of Genworks GDL."
)
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
)))
(
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-arg
gdl-remote
)
&rest
,
args-arg
)
(
the-object
,
self-arg
(
send
(
:apply
(
cons
,
(
make-keyword
(
symbol-name
attr-sym
))
,
args-arg
)))))))
`
(
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
)))
(
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
(
null
,
parent-arg
)
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
))
(
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
))
,
val-arg
))))))
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
glisp:begin-redefinitions-ok
))
;;
;; FLAG -- duplicated from inputs.lisp and objects.lisp, functions.lisp, and below in this file.
;;
`
(
unless
nil
#+
nil
(
and
(
fboundp
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
))
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
attr-sym
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
))
,
val-arg
))))
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
glisp:end-redefinitions-ok
))))))
computed-slots
))
;;
;; FLAG -- this can be made much shorter for all but the slots which
;; are only declared as trickle-downs and not otherwise declared (a
;; rare situation).
;;
(
defun
trickle-down-slots-section
(
slots
&key
from-objects?
)
(
mapcan
#'
(
lambda
(
slot
)
(
let
(
;; DJC trim effort
;; (result (gensym))
)
(
remove
nil
(
list
(
unless
from-objects?
;; DJC trim effort
;;
;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file.
;;
;; FLAG -- this must be get-riddable. Test carefully because trickle-downs are relatively rare.
;;
`
(
unless
(
and
(
fboundp
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-inputs
))
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
))
(
defmethod
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
slot
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
parent-arg
,
(
make-keyword
slot
))
,
val-arg
)))))
;;
;; FLAG -- collect all the trickle-downs and group this at the top in the one eval-when.
;;
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
unless
(
fboundp
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
))
(
defgeneric
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
)
(
self
&rest
args
))))
(
remove
nil
(
list
(
unless
from-objects?
;;
;; FLAG --
this is really confusing and should be able to be conditional
;; FLAG --
duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file.
;;
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
))
nil
(
list
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
(
trickle-down-basis
,
self-arg
',slot
,
args-arg
)))
#+
nil
`
(
defmethod
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
(
trickle-down-basis
,
self-arg
',slot
,
args-arg
))
;;
;; FLAG -- (eval-when (:c- :l- :e) ...) for defgenerics for _all_ messages in header, then remove fboundp from conditional here.
;; FLAG -- this must be get-riddable. Test carefully because trickle-downs are relatively rare.
;;
;; FLAG -- maybe don't remove, could have a trickle-down which is not otherwise declared as a message.
`
(
unless
nil
#+
nil
(
and
(
fboundp
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
))
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
))
nil
(
list
(
find-class
'gdl-basis
))
nil
))
(
defmethod
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
(
chase-up-trickle-down
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
)
,
self-arg
,
args-arg
)))
`
(
unless
(
and
(
fboundp
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-inputs
))
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
))
(
defmethod
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
slot
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
parent-arg
,
(
make-keyword
slot
))
,
val-arg
)))))
;;
;; FLAG -- collect all the trickle-downs and group this at the top in the one eval-when.
;;
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
unless
(
fboundp
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
))
(
defgeneric
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
)
(
self
&rest
args
))))
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
))
nil
(
list
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-trickle-downs
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
(
trickle-down-basis
,
self-arg
',slot
,
args-arg
)))
;;
;; FLAG -- (eval-when (:c- :l- :e) ...) for defgenerics for _all_ messages in header, then remove fboundp from conditional here.
;;
;; FLAG -- maybe don't remove, could have a trickle-down which is not otherwise declared as a message.
`
(
unless
nil
#+
nil
(
and
(
fboundp
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
))
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
))
nil
(
list
(
find-class
'gdl-basis
))
nil
))
(
defmethod
,
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
(
chase-up-trickle-down
',
(
glisp:intern
(
symbol-name
slot
)
:gdl-slots
)
,
self-arg
,
args-arg
)))
)
)))
)))
slots
))
gdl/base/expanders/source/functions.lisp
View file @
648f2235
...
...
@@ -86,8 +86,6 @@
(
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??
;;
...
...
@@ -99,26 +97,7 @@
(
let
((
,
parent-arg
(
the-object
,
self-arg
%parent%
)))
(
if
(
null
,
parent-arg
)
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
))
(
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
,
parent-arg
(
the-object
,
self-arg
:%name%
)
,
self-arg
)))))
;;`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;
;; FLAG -- duplicated from inputs.lisp, objects.lisp, and computed-slots.lisp
;;
#+
nil
`
(
unless
nil
#+
nil
(
and
(
fboundp
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
))
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
attr-sym
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
parent-arg
,
(
make-keyword
attr-sym
))
,
val-arg
))))
;;`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
)))))
,
parent-arg
(
the-object
,
self-arg
:%name%
)
,
self-arg
))))))))))
...
...
@@ -179,6 +158,3 @@
(
block
,
(
make-keyword
attr-sym
)
(
let
((
*error-on-not-handled?*
t
))
,@
(
if
has-declare?
(
rest
body
)
body
))))
,
args-arg
))))))))))))
gdl/base/expanders/source/inputs.lisp
View file @
648f2235
...
...
@@ -63,26 +63,11 @@
(
when
(
not
(
member
input
special-keys
))
(
let
((
input-sym
(
glisp:intern
(
symbol-name
input
)
:gdl-acc
)))
(
list
;;
;; New stuff
;;
`
(
defmethod
,
(
glisp:intern
(
symbol-name
input-sym
)
:gdl-inputs
)
((
self
,
name
)
(
,
part-arg
(
eql
',attr-sym
))
(
child
t
))
(
let
((
*error-on-not-handled?*
t
))
,
expr
))
#+
nil
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
input-sym
)
:gdl-slots
))
nil
(
list
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
input-sym
)
:gdl-slots
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
(
declare
(
ignore
,
args-arg
))
(
let
((
,
parent-arg
(
the-object
,
self-arg
%parent%
)))
(
if
(
null
,
parent-arg
)
(
not-handled
,
self-arg
,
(
make-keyword
input-sym
))
(
,
(
glisp:intern
(
symbol-name
input-sym
)
:gdl-inputs
)
,
parent-arg
(
the-object
,
self-arg
:%name%
)
,
self-arg
)))))))))
(
let
((
*error-on-not-handled?*
t
))
,
expr
))))))
keys
expressions
))))))
...
...
@@ -109,26 +94,6 @@
,
part-arg
(
,
self-arg
gdl-basis
))
(
the-object
,
parent-arg
(
fetch-input
,
(
make-keyword
attr-sym
)
,
part-arg
,
self-arg
))))
;;
;; FLAG -- duplicated from objects.lisp and from this file --- make a function for this!
;;
;; FLAG -- avoid duplicate invocation of (glisp:intern (symbol-name ...))
;;
;;
#+
nil
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
attr-sym
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
))
,
val-arg
))))
`
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-slots
)
((
self
,
name
)
&rest
,
args-arg
)
(
declare
(
ignore
,
args-arg
))
...
...
@@ -146,8 +111,7 @@
(
if
(
member
,
(
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
)))))))))))))
input-slots
))
(
t
(
not-handled
self
,
(
make-keyword
attr-sym
)))))))))))))
input-slots
))
(
defun
optional-input-slots-section
(
name
input-slots
&optional
(
defaulted?
nil
))
(
mapcan
...
...
@@ -175,10 +139,6 @@
(
setf
(
message-source
(
find-class
',name
))
(
make-hash-table
)))))
(
setf
(
gethash
(
make-keyword
',attr-sym
)
ht
)
',attr-expr
))))
;;
;; New stuff
;;
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
glisp:begin-redefinitions-ok
))
(
when
(
and
*compile-for-dgdl?*
(
not
(
string-equal
(
symbol-name
name
)
"remote-object"
)
))
...
...
@@ -194,33 +154,6 @@
(
,
self-arg
gdl-basis
))
(
the-object
,
parent-arg
(
fetch-input
,
(
make-keyword
attr-sym
)
,
part-arg
,
self-arg
))))
;;
;; FLAG -- duplicated from objects.lisp and from this file --- make a function for this!
;;
#+
nil
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
attr-sym
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
parent-arg
,
(
make-keyword
attr-sym
))
,
val-arg
))))
#+
nil
`
(
when
(
and
,
defaulted?
(
or
(
not
(
fboundp
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-trickle-downs
)))
(
not
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-trickle-downs
))
nil
(
list
(
find-class
'gdl-basis
))
nil
))))
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-trickle-downs
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
(
declare
(
ignore
,
args-arg
))
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
))))
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
glisp:end-redefinitions-ok
))
`
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-slots
)
((
self
,
name
)
&rest
,
args-arg
)
...
...
@@ -244,9 +177,7 @@
,
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
))
`
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
,
attr-expr
,
val-arg
)))))))))))
input-slots
))
...
...
gdl/base/expanders/source/objects.lisp
View file @
648f2235
...
...
@@ -24,9 +24,7 @@
(
defun
object-inputs-generics-section
(
cooked-data
&key
special-keys
)
(
let
(
#+
nil
(
object-symbols-in-input-package
(
mapcar
#'
(
lambda
(
data
)
(
glisp:intern
(
getf
data
:attr-sym
)
:gdl-inputs
))
cooked-data
))
(
object-input-keys
(
remove-duplicates
(
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
))
...
...
@@ -34,20 +32,12 @@
(
set-difference
plist-keys
special-keys
)))
cooked-data
))))))
`
((
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
,@
(
append
#+
nil
(
mapcar
#'
(
lambda
(
object-symbol
)
`
(
unless
(
fboundp
',object-symbol
)
(
defgeneric
,
object-symbol
(
,
parent-arg
,
val-arg
,
self-arg
))))
object-symbols-in-input-package
)
(
mapcar
#'
(
lambda
(
key
)
`
(
unless
(
fboundp
',
(
glisp:intern
key
:gdl-inputs
))
(
defgeneric
,
(
glisp:intern
key
:gdl-inputs
)
(
,
parent-arg
,
val-arg
,
self-arg
))))
object-input-keys
)
(
mapcar
#'
(
lambda
(
key
)
`
(
unless
(
fboundp
',
(
glisp:intern
key
:gdl-slots
))
(
defgeneric
,
(
glisp:intern
key
:gdl-slots
)
(
,
self-arg
&rest
,
args-arg
))))
object-input-keys
)))
,@
(
mapcar
#'
(
lambda
(
key
)
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
key
:gdl-slots
))
nil
(
list
(
find-class
'gdl-basis
))
nil
)
...
...
@@ -56,40 +46,7 @@
(
let
((
,
parent-arg
(
the-object
,
self-arg
%parent%
)))
(
if
(
null
,
parent-arg
)
(
not-handled
,
self-arg
,
(
make-keyword
key
))
(
,
(
glisp:intern
key
:gdl-inputs
)
,
parent-arg
(
the-object
,
self-arg
:%name%
)
,
self-arg
))))))
object-input-keys
))))
#+
nil
(
let*
((
special-keys
(
list
:type
:sequence
:parameters
:pass-down
:pseudo-inputs
))
(
object-symbols-in-input-package
(
remove-duplicates
(
mapcar
#'
(
lambda
(
spec
)
(
glisp:intern
(
if
(
stringp
(
first
spec
))
(
second
spec
)
(
first
spec
))
:gdl-inputs
))
object-specs
)))
(
object-input-keys
(
remove-duplicates
(
append
(
set-difference
(
apply
#'
append
(
mapcar
#'
plist-keys
(
mapcar
#'
(
lambda
(
spec
)
(
if
(
stringp
(
first
spec
))
(
rest
(
rest
spec
))
(
rest
spec
)))
object-specs
)))
special-keys
)
(
apply
#'
append
(
mapcar
#'
(
lambda
(
spec
)
(
getf
(
rest
(
strip-strings
spec
))
:pass-down
))
object-specs
))))))
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
,@
(
append
(
mapcar
#'
(
lambda
(
object-symbol
)
`
(
unless
(
fboundp
',object-symbol
)
(
defgeneric
,
object-symbol
(
parent
object-name
self
))))
object-symbols-in-input-package
)
(
mapcar
#'
(
lambda
(
key
)
`
(
unless
(
fboundp
',
(
glisp:intern
key
:gdl-inputs
))
(
defgeneric
,
(
glisp:intern
key
:gdl-inputs
)
(
parent
object-name
self
))))
object-input-keys
)
(
mapcar
#'
(
lambda
(
key
)
`
(
unless
(
fboundp
',
(
glisp:intern
key
:gdl-slots
))
(
defgeneric
,
(
glisp:intern
key
:gdl-slots
)
(
self
&rest
args
))))
object-input-keys
))))
,
parent-arg
(
the-object
,
self-arg
:%name%
)
,
self-arg
))))))
object-input-keys
))))
...
...
@@ -289,21 +246,6 @@ item in the list following the :sequence keyword")))))
(
the-object
,
self-arg
(
send
(
:apply
(
cons
,
(
make-keyword
(
symbol-name
attr-sym
))
,
args-arg
)))))))
;;
;; FLAG -- duplicated from two places in inputs.lisp --- make a function for this!!
;;
#+
nil
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
))
nil
(
list
(
find-class
'gdl-basis
)
(
find-class
t
)
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
((
,
parent-arg
gdl-basis
)
,
part-arg
(
,
self-arg
gdl-basis
))
(
declare
(
ignore
,
part-arg
))
(
let
((
,
val-arg
(
getf
(
the-object
,
self-arg
%parameters%
)
,
(
make-keyword
(
symbol-name
attr-sym
))
'gdl-rule:%not-handled%
)))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
parent-arg
,
(
make-keyword
attr-sym
))
,
val-arg
))))
(
when
(
member
(
first
part-quantify-expr
)
'
(
:size
:radial
))
`
(
defmethod
gdl-inputs::number-of-elements
((
self
,
name
)
(
,
part-arg
(
eql
',attr-sym
))
(
child
t
))
,
(
second
part-quantify-expr
)))
...
...
@@ -330,232 +272,12 @@ item in the list following the :sequence keyword")))))
))))
#+
nil
(
defun
objects-section
(
name
objects
)
(
let
((
special-keys
(
list
:type
:sequence
:parameters
:pass-down
:pseudo-inputs
)))
(
apply
#'
append
(
mapcar
#'
(
lambda
(
part
)
(
let*
((
attr-remarks
(
message-strings
part
))
(
attr-sym
(
glisp:intern
(
symbol-name
(
message-symbol
part
))
:gdl-acc
))
(
plist
(
rest
(
strip-strings
part
)))
(
plist-orig
plist
)
(
plist
(
process-radial
plist
))
(
plist
(
process-matrix
plist
))
(
part-parameters-expression
(
getf
plist
:parameters
))
(
part-type-expr
(
or
(
getf
plist
:type
)
`
',
(
glisp:intern
(
symbol-name
attr-sym
)
(
symbol-package
name
))))
(
part-quantify-expr
(
getf
plist
:sequence
))
(
pseudo-inputs
(
getf
plist
:pseudo-inputs
))
(
with-attribute-keys
(
getf
plist
:pass-down
)))
(
let
((
part-type-symbol
(
cond
((
and
(
listp
part-type-expr
)
(
eql
(
first
part-type-expr
)
'quote
))
(
second
part-type-expr
))
((
and
(
listp
part-type-expr
)
(
eql
(
first
part-type-expr
)
:sequence
)
(
listp
(
second
part-type-expr
))
(
eql
(
first
(
second
part-type-expr
))
'quote
))
(
second
(
second
part-type-expr
)))
(
t
nil
))))
(
when
(
and
part-type-symbol
(
atom
part-type-symbol
)
(
not
(
eql
part-type-symbol
'remote-object
)))
(
let*
((
all-inputs
(
all-inputs
part-type-symbol
))
(
accepted-inputs
(
if
(
listp
all-inputs
)
(
append
all-inputs
pseudo-inputs
)
all-inputs
)))
(
when
(
listp
accepted-inputs
)
(
let*
((
accepted-inputs
(
mapcar
#'
make-keyword
accepted-inputs
))
(
attempted-inputs
(
mapcar
#'
make-keyword
(
set-difference
(
append
(
plist-keys
plist-orig
)
with-attribute-keys
)
special-keys
)))
(
unrecognized-inputs
(
safe-sort
(
set-difference
attempted-inputs
accepted-inputs
)
#'
string-lessp
:key
#'
string
)))
(
reserved-word-warning-or-error
part-type-symbol
(
mapcar
#'
(
lambda
(
symbol
)
(
glisp:intern
symbol
:gdl-acc
))
attempted-inputs
))
(
when
unrecognized-inputs
(
let*
((
singular?
(
=
(
length
unrecognized-inputs
)
1
))
(
s-or-blank
(
if
singular?
""
"s"
))
(
a-or-blank
(
if
singular?
"a"
""
)))
(
warn
" (from object specification for ~s)
The following ~a not recognized as any category of defined input-slot for
the object type '~s'. ~a will be assumed to be ~a pseudo-input~a.
~{ ~s~^~%~}
You can suppress this warning by including ~a name~a in the :pseudo-inputs
special input keyword for the child object, i.e:
...
:pseudo-inputs (~{~a~^ ~})
...
"
(
make-keyword
attr-sym
)
(
if
singular?
"is"
"are"
)
part-type-symbol
(
if
singular?
"This"
"These"
)
a-or-blank
s-or-blank
unrecognized-inputs
(
if
singular?
"this"
"these"
)
s-or-blank
unrecognized-inputs
))))))))