Commit 335b6561 authored by Dave Cooper's avatar Dave Cooper
Browse files

added syntax checker, Issue #145

parent 4a8a0015
......@@ -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")))
......@@ -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)
......
(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)
)
(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)