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
335b6561
Commit
335b6561
authored
Mar 28, 2015
by
Dave Cooper
Browse files
added syntax checker, Issue
#145
parent
4a8a0015
Changes
4
Hide whitespace changes
Inline
Side-by-side
base/base.asd
View file @
335b6561
...
...
@@ -10,7 +10,8 @@
((
:file
"source/package"
)
(
:file
"source/genworks"
)
(
:file
"source/presets"
)
(
:file
"source/parameters"
)
(
:file
"source/metaclasses"
)
(
:file
"source/utilities"
)
(
:file
"source/start"
)
(
:file
"expanders/source/inputs"
)
(
:file
"source/start"
)
(
:file
"source/syntax-checker"
)
(
:file
"expanders/source/inputs"
)
(
:file
"expanders/source/computed-slots"
)
(
:file
"expanders/source/functions"
)
(
:file
"expanders/source/methods"
)
...
...
@@ -27,5 +28,7 @@
(
: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
"rest/source/sequence"
)
(
:file
"zzinit/source/initialize"
)
(
:file
"zzinit/source/zzinit"
)))
base/macros/source/define-object.lisp
View file @
335b6561
...
...
@@ -185,175 +185,205 @@ future GenDL release."
(
defmacro
%define-object-amendment%
(
name
mixin-list
&key
input-slots
computed-slots
objects
hidden-objects
functions
methods
documentation
trickle-down-slots
query-slots
)
computed-slots
objects
hidden-objects
functions
methods
documentation
trickle-down-slots
query-slots
)
(
check-syntax
name
input-slots
computed-slots
objects
hidden-objects
functions
methods
documentation
trickle-down-slots
query-slots
)
(
with-gdl-message-symbols
()
(
let
((
message-ht
(
make-hash-table
:size
(
length
messages
))))
(
dolist
(
message
messages
)
(
push
message
(
gethash
message
message-ht
)))
(
let
((
duplicates
(
let
(
duplicates
)
(
maphash
#'
(
lambda
(
key
val
)
(
if
(
consp
(
rest
val
))
(
push
key
duplicates
)))
message-ht
)
duplicates
)))
(
let
((
duplicates
(
remove-if
#'
(
lambda
(
dup
)
(
member
dup
method-syms
))
duplicates
)))
(
when
duplicates
(
error
"duplicate slot name~p: ~{~a~^, ~}"
(
length
duplicates
)
(
sort
duplicates
#'
string-lessp
:key
#'
symbol-name
))))))
(
let*
((
class
(
find-class
name
))
(
new-messages
(
remove-duplicates
(
append
(
messages
class
)
messages
)))
(
new-computed-slots
(
remove-duplicates
(
append
(
computed-slots
class
)
computed-slot-syms
)))
(
new-required-input-slots
(
remove-duplicates
(
append
(
required-input-slots
class
)
required-input-slot-syms
)))
(
new-optional-input-slots
(
remove-duplicates
(
append
(
optional-input-slots
class
)
optional-input-slot-syms
)))
(
new-defaulted-input-slots
(
remove-duplicates
(
append
(
defaulted-input-slots
class
)
defaulted-input-slot-syms
)))
(
new-query-slots
(
remove-duplicates
(
append
(
query-slots
class
)
query-slot-syms
)))
(
new-settable-computed-slots
(
remove-duplicates
(
append
(
settable-computed-slots
class
)
settable-computed-slot-syms
)))
(
new-uncached-computed-slots
(
remove-duplicates
(
append
(
uncached-computed-slots
class
)
uncached-computed-slot-syms
)))
(
new-settable-optional-input-slots
(
remove-duplicates
(
append
(
settable-optional-input-slots
class
)
settable-input-slot-syms
)))
(
new-settable-defaulted-input-slots
(
remove-duplicates
(
append
(
settable-defaulted-input-slots
class
)
settable-defaulted-input-slot-syms
)))
(
new-functions
(
remove-duplicates
(
append
(
functions
class
)
function-syms
)))
(
new-methods
(
remove-duplicates
(
append
(
methods
class
)
method-syms
)))
(
new-cached-methods
(
remove-duplicates
(
append
(
cached-methods
class
)
cached-method-syms
)))
(
new-cached-functions
(
remove-duplicates
(
append
(
cached-functions
class
)
cached-function-syms
)))
(
new-objects
(
remove-duplicates
(
append
(
objects
class
)
object-syms
)))
(
new-quantified-objects
(
remove-duplicates
(
append
(
quantified-objects
class
)
quantified-object-syms
)))
(
new-hidden-objects
(
remove-duplicates
(
append
(
hidden-objects
class
)
hidden-object-syms
)))
(
new-quantified-hidden-objects
(
remove-duplicates
(
append
(
quantified-hidden-objects
class
)
quantified-hidden-object-syms
)))
(
new-trickle-down-slots
(
remove-duplicates
(
append
(
trickle-down-slots
class
)
(
append
object-syms
quantified-object-syms
hidden-object-syms
quantified-hidden-object-syms
trickle-down-slot-syms
))))
(
new-settable-slots
(
remove-duplicates
(
append
(
settable-slots
class
)
(
list
(
append
required-input-slot-syms
settable-input-slot-syms
settable-defaulted-input-slot-syms
settable-computed-slot-syms
)))))
(
new-messages
(
remove-duplicates
(
append
(
messages
class
)
messages
)))
(
new-computed-slots
(
remove-duplicates
(
append
(
computed-slots
class
)
computed-slot-syms
)))
(
new-required-input-slots
(
remove-duplicates
(
append
(
required-input-slots
class
)
required-input-slot-syms
)))
(
new-optional-input-slots
(
remove-duplicates
(
append
(
optional-input-slots
class
)
optional-input-slot-syms
)))
(
new-defaulted-input-slots
(
remove-duplicates
(
append
(
defaulted-input-slots
class
)
defaulted-input-slot-syms
)))
(
new-query-slots
(
remove-duplicates
(
append
(
query-slots
class
)
query-slot-syms
)))
(
new-settable-computed-slots
(
remove-duplicates
(
append
(
settable-computed-slots
class
)
settable-computed-slot-syms
)))
(
new-uncached-computed-slots
(
remove-duplicates
(
append
(
uncached-computed-slots
class
)
uncached-computed-slot-syms
)))
(
new-settable-optional-input-slots
(
remove-duplicates
(
append
(
settable-optional-input-slots
class
)
settable-input-slot-syms
)))
(
new-settable-defaulted-input-slots
(
remove-duplicates
(
append
(
settable-defaulted-input-slots
class
)
settable-defaulted-input-slot-syms
)))
(
new-functions
(
remove-duplicates
(
append
(
functions
class
)
function-syms
)))
(
new-methods
(
remove-duplicates
(
append
(
methods
class
)
method-syms
)))
(
new-cached-methods
(
remove-duplicates
(
append
(
cached-methods
class
)
cached-method-syms
)))
(
new-cached-functions
(
remove-duplicates
(
append
(
cached-functions
class
)
cached-function-syms
)))
(
new-objects
(
remove-duplicates
(
append
(
objects
class
)
object-syms
)))
(
new-quantified-objects
(
remove-duplicates
(
append
(
quantified-objects
class
)
quantified-object-syms
)))
(
new-hidden-objects
(
remove-duplicates
(
append
(
hidden-objects
class
)
hidden-object-syms
)))
(
new-quantified-hidden-objects
(
remove-duplicates
(
append
(
quantified-hidden-objects
class
)
quantified-hidden-object-syms
)))
(
new-trickle-down-slots
(
remove-duplicates
(
append
(
trickle-down-slots
class
)
(
append
object-syms
quantified-object-syms
hidden-object-syms
quantified-hidden-object-syms
trickle-down-slot-syms
))))
(
new-settable-slots
(
remove-duplicates
(
append
(
settable-slots
class
)
(
list
(
append
required-input-slot-syms
settable-input-slot-syms
settable-defaulted-input-slot-syms
settable-computed-slot-syms
)))))
(
supers
(
remove-duplicates
(
append
(
glisp:direct-superclass-names
class
)
mixin-list
)
:from-end
t
))
(
supers
(
remove-duplicates
(
append
(
glisp:direct-superclass-names
class
)
mixin-list
)
:from-end
t
))
(
class
(
gensym
)))
(
class
(
gensym
)))
(
reserved-word-warning-or-error
name
messages
supers
)
`
(
progn
,
(
when
(
and
*compile-documentation-database?*
documentation
)
,
(
when
(
and
*compile-documentation-database?*
documentation
)
`
(
when
*load-documentation-database?*
(
setf
(
gdl-documentation
,
class
)
',documentation
)))
(
let*
((
,
class
(
find-class
',name
)))
(
setf
(
messages
,
class
)
',new-messages
)
(
setf
(
required-input-slots
,
class
)
',new-required-input-slots
)
(
setf
(
optional-input-slots
,
class
)
',new-optional-input-slots
)
(
setf
(
defaulted-input-slots
,
class
)
',new-defaulted-input-slots
)
(
setf
(
computed-slots
,
class
)
',new-computed-slots
)
(
setf
(
query-slots
,
class
)
',new-query-slots
)
(
setf
(
settable-computed-slots
,
class
)
',new-settable-computed-slots
)
(
setf
(
uncached-computed-slots
,
class
)
',new-uncached-computed-slots
)
(
setf
(
settable-optional-input-slots
,
class
)
',new-settable-optional-input-slots
)
(
setf
(
settable-defaulted-input-slots
,
class
)
',new-settable-defaulted-input-slots
)
(
setf
(
functions
,
class
)
',new-functions
)
(
setf
(
methods
,
class
)
',new-methods
)
(
setf
(
cached-functions
,
class
)
',new-cached-functions
)
(
setf
(
cached-methods
,
class
)
',new-cached-methods
)
(
setf
(
objects
,
class
)
',new-objects
)
(
setf
(
quantified-objects
,
class
)
',new-quantified-objects
)
(
setf
(
hidden-objects
,
class
)
',new-hidden-objects
)
(
setf
(
quantified-hidden-objects
,
class
)
',new-quantified-hidden-objects
)
(
setf
(
trickle-down-slots
,
class
)
',new-trickle-down-slots
)
(
setf
(
settable-slots
,
class
)
',new-settable-slots
)
(
let*
((
,
class
(
find-class
',name
)))
(
setf
(
messages
,
class
)
',new-messages
)
(
setf
(
required-input-slots
,
class
)
',new-required-input-slots
)
(
setf
(
optional-input-slots
,
class
)
',new-optional-input-slots
)
(
setf
(
defaulted-input-slots
,
class
)
',new-defaulted-input-slots
)
(
setf
(
computed-slots
,
class
)
',new-computed-slots
)
(
setf
(
query-slots
,
class
)
',new-query-slots
)
(
setf
(
settable-computed-slots
,
class
)
',new-settable-computed-slots
)
(
setf
(
uncached-computed-slots
,
class
)
',new-uncached-computed-slots
)
(
setf
(
settable-optional-input-slots
,
class
)
',new-settable-optional-input-slots
)
(
setf
(
settable-defaulted-input-slots
,
class
)
',new-settable-defaulted-input-slots
)
(
setf
(
functions
,
class
)
',new-functions
)
(
setf
(
methods
,
class
)
',new-methods
)
(
setf
(
cached-functions
,
class
)
',new-cached-functions
)
(
setf
(
cached-methods
,
class
)
',new-cached-methods
)
(
setf
(
objects
,
class
)
',new-objects
)
(
setf
(
quantified-objects
,
class
)
',new-quantified-objects
)
(
setf
(
hidden-objects
,
class
)
',new-hidden-objects
)
(
setf
(
quantified-hidden-objects
,
class
)
',new-quantified-hidden-objects
)
(
setf
(
trickle-down-slots
,
class
)
',new-trickle-down-slots
)
(
setf
(
settable-slots
,
class
)
',new-settable-slots
)
(
eval-when
(
compile
load
)
(
glisp:begin-redefinitions-ok
))
(
defclass
,
name
,
supers
(
,@
(
remove-duplicates
(
append
(
make-standard-slots
)
(
make-accessible-slots
new-computed-slots
)
(
make-accessible-slots
new-query-slots
)
(
make-accessible-slots
new-settable-computed-slots
)
(
make-accessible-slots
new-uncached-computed-slots
)
(
make-accessible-slots
new-objects
)
(
make-accessible-slots
new-quantified-objects
)
(
make-accessible-slots
new-hidden-objects
)
(
make-accessible-slots
new-quantified-hidden-objects
)
(
make-accessible-slots
new-cached-functions
)
(
make-accessible-slots
new-cached-methods
)
(
make-accessible-slots
new-required-input-slots
:inputs?
t
)
(
make-accessible-slots
new-optional-input-slots
:inputs?
t
)
(
make-accessible-slots
new-settable-optional-input-slots
:inputs?
t
)
(
make-accessible-slots
new-defaulted-input-slots
:inputs?
t
)
(
make-accessible-slots
new-settable-defaulted-input-slots
:inputs?
t
))
:key
#'
first
))
(
:metaclass
gdl-class
)
(
eval-when
(
compile
load
)
(
glisp:begin-redefinitions-ok
))
(
defclass
,
name
,
supers
(
,@
(
remove-duplicates
(
append
(
make-standard-slots
)
(
make-accessible-slots
new-computed-slots
)
(
make-accessible-slots
new-query-slots
)
(
make-accessible-slots
new-settable-computed-slots
)
(
make-accessible-slots
new-uncached-computed-slots
)
(
make-accessible-slots
new-objects
)
(
make-accessible-slots
new-quantified-objects
)
(
make-accessible-slots
new-hidden-objects
)
(
make-accessible-slots
new-quantified-hidden-objects
)
(
make-accessible-slots
new-cached-functions
)
(
make-accessible-slots
new-cached-methods
)
(
make-accessible-slots
new-required-input-slots
:inputs?
t
)
(
make-accessible-slots
new-optional-input-slots
:inputs?
t
)
(
make-accessible-slots
new-settable-optional-input-slots
:inputs?
t
)
(
make-accessible-slots
new-defaulted-input-slots
:inputs?
t
)
(
make-accessible-slots
new-settable-defaulted-input-slots
:inputs?
t
))
:key
#'
first
))
(
:metaclass
gdl-class
)
)
(
eval-when
(
compile
load
)
(
glisp:end-redefinitions-ok
))
;; FLAG -- consider pre-cooking these expression lists
;;
,@
(
input-slots-section
name
(
group-remark-strings
(
remove-if-not
#'
(
lambda
(
item
)
(
or
(
symbolp
item
)
(
stringp
item
)))
input-slots
)))
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
null
(
rest
(
rest
(
strip-strings
slot
))))))
input-slots
))
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
member
:settable
(
rest
(
rest
(
strip-strings
slot
))))
(
not
(
member
:defaulting
(
rest
(
rest
(
strip-strings
slot
)))))))
input-slots
))
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
member
:defaulting
(
rest
(
rest
(
strip-strings
slot
))))
(
not
(
member
:settable
(
rest
(
rest
(
strip-strings
slot
)))))))
input-slots
)
t
)
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
member
:settable
(
rest
(
rest
(
strip-strings
slot
))))
(
member
:defaulting
(
rest
(
rest
(
strip-strings
slot
))))))
input-slots
)
t
)
)
(
eval-when
(
compile
load
)
(
glisp:end-redefinitions-ok
))
;;
;; FLAG -- make sure these next two are ok.
;;
,@
(
message-generics
(
set-difference
messages
(
append
method-syms
cached-method-syms
)))
,
(
input-slots-generics
(
append
(
group-remark-strings
(
remove-if-not
#'
(
lambda
(
item
)
(
or
(
symbolp
item
)
(
stringp
item
)))
input-slots
))
(
remove-if-not
#'
consp
input-slots
)))
;; FLAG -- consider pre-cooking these expression lists
;;
,@
(
input-slots-section
name
(
group-remark-strings
(
remove-if-not
#'
(
lambda
(
item
)
(
or
(
symbolp
item
)
(
stringp
item
)))
input-slots
)))
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
null
(
rest
(
rest
(
strip-strings
slot
))))))
input-slots
))
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
member
:settable
(
rest
(
rest
(
strip-strings
slot
))))
(
not
(
member
:defaulting
(
rest
(
rest
(
strip-strings
slot
)))))))
input-slots
))
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
member
:defaulting
(
rest
(
rest
(
strip-strings
slot
))))
(
not
(
member
:settable
(
rest
(
rest
(
strip-strings
slot
)))))))
input-slots
)
t
)
,@
(
optional-input-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
member
:settable
(
rest
(
rest
(
strip-strings
slot
))))
(
member
:defaulting
(
rest
(
rest
(
strip-strings
slot
))))))
input-slots
)
t
)
,@
(
computed-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
null
(
rest
(
rest
(
strip-strings
slot
))))))
computed-slots
))
,@
(
computed-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
null
(
rest
(
rest
(
strip-strings
slot
))))))
computed-slots
))
,@
(
functions-section
name
(
mapcar
#'
(
lambda
(
slot
)
(
if
(
stringp
(
first
slot
))
(
list
(
first
slot
)
(
second
slot
)
nil
(
third
slot
))
(
list
(
first
slot
)
nil
(
second
slot
))))
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
eql
(
first
(
rest
(
rest
(
strip-strings
slot
))))
:uncached
)))
computed-slots
)))
,@
(
functions-section
name
(
mapcar
#'
(
lambda
(
slot
)
(
if
(
stringp
(
first
slot
))
(
list
(
first
slot
)
(
second
slot
)
nil
(
third
slot
))
(
list
(
first
slot
)
nil
(
second
slot
))))
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
eql
(
first
(
rest
(
rest
(
strip-strings
slot
))))
:uncached
)))
computed-slots
)))
,@
(
computed-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
eql
(
first
(
rest
(
rest
(
strip-strings
slot
))))
:settable
)))
computed-slots
))
,@
(
computed-slots-section
name
(
remove-if-not
#'
(
lambda
(
slot
)
(
and
(
consp
slot
)
(
eql
(
first
(
rest
(
rest
(
strip-strings
slot
))))
:settable
)))
computed-slots
))
,@
(
computed-slots-section
name
query-slots
:query?
t
)
,@
(
computed-slots-section
name
query-slots
:query?
t
)
,@
(
objects-section
name
objects
)
,@
(
objects-section
name
hidden-objects
)
,@
(
objects-section
name
objects
)
,@
(
objects-section
name
hidden-objects
)
,@
(
functions-section
name
functions
)
,@
(
functions-section
name
functions
)
,@
(
methods-section
name
methods
)
,@
(
methods-section
name
methods
)
,@
(
trickle-down-slots-section
(
append
object-syms
quantified-object-syms
hidden-object-syms
quantified-hidden-object-syms
trickle-down-slot-syms
)))))))
,@
(
trickle-down-slots-section
(
append
object-syms
quantified-object-syms
hidden-object-syms
quantified-hidden-object-syms
trickle-down-slot-syms
)))))))
...
...
@@ -376,6 +406,9 @@ overview of <tt>define-object</tt> syntax."
query-slots
)
(
check-syntax
name
input-slots
computed-slots
objects
hidden-objects
functions
methods
documentation
trickle-down-slots
query-slots
)
(
with-gdl-message-symbols
(
:new
t
)
(
let
((
mixins
(
if
(
or
no-vanilla-mixin?
...
...
@@ -387,6 +420,8 @@ overview of <tt>define-object</tt> syntax."
mixin-list
(
append
mixin-list
(
list
'vanilla-mixin
)))))
(
reserved-word-warning-or-error
name
messages
mixins
)
(
let
((
message-ht
(
make-hash-table
:size
(
length
messages
))))
(
dolist
(
message
messages
)
...
...
base/source/syntax-checker.lisp
0 → 100644
View file @
335b6561
(
in-package
:gdl
)
(
defparameter
*on-syntax-error*
:warn
"Keyword symbol. Can be either :warn or :error."
)
(
define-condition
syntax-error
(
error
)
((
text
:initarg
:text
:reader
text
)))
(
defun
syntax-error
(
name
token
message-key
message
)
(
let
((
text
(
format
nil
"Syntax error for class ~s.~%Offending token: ~s~%~a: ~a."
name
token
message-key
message
)))
(
ecase
*on-syntax-error*
(
:warn
(
warn
text
))
(
:error
(
error
'syntax-error
:text
text
)))))
(
defun
check-floating-string
(
name
form
)
"check for special case in which documentation isn't followed by symbol spec"
(
when
(
stringp
(
first
(
last
form
)))
(
syntax-error
name
(
first
(
last
form
))
"Problem"
"documentation string isn't followed by any message symbol"
)))
(
defun
check-form
(
name
form
predicate
grammar
)
"general function that, given a predicate, validates all tokens in a slot declaration form"
(
dolist
(
token
form
)
(
if
(
not
(
funcall
predicate
token
))
(
syntax-error
name
token
"Valid Grammar"
grammar
))))
(
defun
check-input-slots
(
name
form
)
":input-slots grammar:
<form> = :input-slots (<token>*)
<token> = <string> | <symbol> | (<string>* <symbol> <expression>+ <behavior>*)
<behavior> = :settable | :defaulting
Also check for special case in which only strings without a symbol following."
(
when
form
(
let
((
behavior
'
(
:settable
:defaulting
))
(
grammar
"
<form> = :input-slots (<token>*)
<token> = <string> | <symbol> | (<string>* <symbol> <expression>+ <behavior>*)
<behavior> = :settable | :defaulting"
))
(
flet
((
valid-token
(
token
)
(
or
(
symbolp
token
)
(
stringp
token
)
(
and
(
consp
token
)
(
let
((
token
(
strip-strings
token
)))
(
and
(
symbolp
(
first
token
))
;; RvD: this check still allows duplicate keys in tail of cons
(
every
#'
(
lambda
(
token*
)
(
member
token*
behavior
))
(
rest
(
rest
token
)))))))))
(
check-form
name
form
#'
valid-token
grammar
)
(
check-floating-string
name
form
)
))))
(
defun
check-computed-slots
(
name
form
)
":computed-slots grammar:
<form> = :computed-slots (<token>*)
<token> = <string> | (<string>* <symbol> <expression>+ <behavior>+)
<behavior> = :settable | :uncached
Also check for special case in which only strings without a symbol following."
(
when
form
(
let
((
behavior
'
(
:settable
:uncached
))
(
grammar
"
<form> = :computed-slots (<token>*)
<token> = <string> | (<string>* <symbol> <expression>+ <behavior>*)
<behavior> = :settable | :uncached"
))
(
flet
((
valid-token
(
token
)
(
or
(
stringp
token
)
(
and
(
consp
token
)
(
let
((
token
(
strip-strings
token
)))
(
and
(
symbolp
(
first
token
))
;; RvD: unlike :input-slots, :computed-slots only allows one behavior keyword
;; RvD: otherwise GDL compiler throws warnings.
(
or
(
not
(
rest
(
rest
token
)))
(
and
(
=
(
length
token
)
3
)
(
member
(
third
token
)
behavior
)))
))))))
(
check-form
name
form
#'
valid-token
grammar
)
(
check-floating-string
name
form
)
))))
(
defun
check-objects
(
name
form
&optional
(
hidden
nil
))
":(hidden-)objects grammar:
<form> = (hidden-):objects (<token>*)
<token> = (<string>* <symbol> <rule>*)
<rule> = <keyword> <expression>"
(
when
form
(
let
((
grammar
(
format
nil
"
<form> = :~aobjects (<token>*)
<token> = (<string>* <symbol> <rule>*)
<rule> = <keyword> <expression>"
(
if
hidden
"hidden-"
""
))))
(
flet
((
valid-token
(
token
)
(
and
(
consp
token
)
(
let
((
token
(
strip-strings
token
)))
(
and
(
symbolp
(
first
token
))
;; plist is already checked by define-object internals, but do it here anyway
(
or
(
and
(
evenp
(
length
(
rest
token
)))
(
every
#'
keywordp
(
plist-keys
(
rest
token
))))
(
syntax-error
name
(
rest
token
)
"Problem"
(
format
nil
"Unvalid plist for slot ~s"
(
first
token
)))
t
)
)))))
(
check-form
name
form
#'
valid-token
grammar
)
))))
(
defun
check-functions
(
name
form
&optional
(
methods
t
))
":functions|:methods grammar:
<form> = :functions|:methods (<token>*)
<token> = (<string>* <symbol> <behavior>+ <list> <body>)
<behavior> = :cached | :cached-eql | :cached-= | :cached-eq | :cached-equal | :cached-equalp"
(
when
form
(
let
((
grammar
(
format
nil
"
<form> = :~a (<token>*)
<token> = (<string>* <symbol> <behavior>+ <list> <body>*)
<behavior> = :cached | :cached-eql | :cached-= | :cached-eq | :cached-equal | :cached-equalp"
(
if
methods
"methods"
"functions"
)))
(
behavior
'
(
:cached
:cached-eql
:cached-=
:cached-eq
:cached-equal
:cached-equalp
)))
(
flet
((
valid-token
(
token
)
(
and
(
consp
token
)
(
let
((
token
(
strip-strings
token
)))
(
and
(
symbolp
(
first
token
))
(
or
(
listp
(
second
token
))
(
and
(
member
(
second
token
)
behavior
)
(
listp
(
third
token
))))
)))))
(
check-form
name
form
#'
valid-token
grammar
)
))))
(
defun
check-trickle-down-slots
(
name
form
)
":functions|:methods grammar:
<form> = :trickle-down-slots (<symbol>*)
"
(
when
form
(
let
((
grammar
"<form> = :trickle-down-slots (<symbol>*)"
))
(
if
(
not
(
and
(
consp
form
)
(
every
#'
symbolp
form
)))
(
syntax-error
name
form
"Valid Grammar"
grammar
)))))
(
defun
check-query-slots
(
name
form
)
"unknown what is is"
(
declare
(
ignore
name
form
))
t
)
(
defun
check-documentation
(
name
form
)
"plist containing keys :description :author :examples :date :version"
(
when
form
(
let
((
valid-keys
'
(
:description
:author
:examples
:date
:version
)))
(
when
(
not
(
and
(
consp
form
)
(
evenp
(
length
form
))
(
every
#'
(
lambda
(
key
)
(
member
key
valid-keys
))
(
plist-keys
form
))))
(
syntax-error
name
form
"Problem"
(
format
nil
":documentation is a plist which may contain the following keys: ~a"
valid-keys
))))))
(
defun
check-syntax
(
name
input-slots
computed-slots
objects
hidden-objects
functions
methods
documentation
trickle-down-slots
query-slots
)
(
check-input-slots
name
input-slots
)
(
check-computed-slots
name
computed-slots
)
(
check-objects
name
objects
)
(
check-objects
name
hidden-objects
t
)
(
check-functions
name
functions
)
(
check-functions
name
methods
t
)
(
check-trickle-down-slots
name
trickle-down-slots
)
(
check-query-slots
name
query-slots
)
(
check-documentation
name
documentation
)
)
regression/gdl/source/syntax-checker.lisp
0 → 100644
View file @
335b6561
(
gwl:define-package
:gdl-lift-tests
)
(
in-package
:gdl-lift-tests
)
(
define-condition
not-raised
(
error
)
;; Private condition to use inside assert-raises."
((
expected-condition
:initarg
:expected-condition
:reader
expected-condition
)
(
raised-condition
:initarg
:raised-condition
:reader
raised-condition
:initform
nil
)