Commit 4c0b8f40 authored by Dave Cooper's avatar Dave Cooper
Browse files

added generalized check for reserved words (i.e. non-inputs) in internal primitives

parent 6f979848
......@@ -140,11 +140,16 @@ and then compile this again.~%"))
(safe-sort (set-difference attempted-inputs accepted-inputs)
#'string-lessp :key #'string)))
;;
;; FLAG -- do we really need to do this here? We are already
;; checking for non-inputs, and the reserved words will all
;; be non-inputs.
;;
(reserved-word-warning-or-error part-type-symbol
(mapcar #'(lambda(symbol)
(glisp:intern symbol :gdl-acc))
attempted-inputs))
attempted-inputs) (list part-type-symbol))
(when unrecognized-inputs
(let* ((singular? (= (length unrecognized-inputs) 1))
......
......@@ -378,192 +378,196 @@ overview of <tt>define-object</tt> syntax."
(with-gdl-message-symbols (:new t)
(reserved-word-warning-or-error name messages)
(let ((mixins (if (or no-vanilla-mixin?
(some #'(lambda(mixin)
(let ((class (find-class mixin nil)))
(and class
(member (find-class 'vanilla-mixin)
(all-superclasses class))))) mixin-list))
mixin-list (append mixin-list (list 'vanilla-mixin)))))
(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))))))
(reserved-word-warning-or-error name messages mixins)
`(progn
(defclass ,name ,(if (or no-vanilla-mixin?
(some #'(lambda(mixin)
(let ((class (find-class mixin nil)))
(and class
(member (find-class 'vanilla-mixin)
(all-superclasses class))))) mixin-list))
mixin-list
(append mixin-list (list 'vanilla-mixin)))
(,@(append (make-standard-slots)
(make-accessible-slots computed-slot-syms)
(make-accessible-slots settable-computed-slot-syms)
(make-accessible-slots uncached-computed-slot-syms)
(make-accessible-slots query-slot-syms)
(make-accessible-slots object-syms)
(make-accessible-slots quantified-object-syms)
(make-accessible-slots hidden-object-syms)
(make-accessible-slots quantified-hidden-object-syms)
(make-accessible-slots cached-function-syms)
(make-accessible-slots cached-method-syms)
(make-accessible-slots required-input-slot-syms :inputs? t)
(make-accessible-slots optional-input-slot-syms :inputs? t)
(make-accessible-slots settable-input-slot-syms :inputs? t)
(make-accessible-slots defaulted-input-slot-syms :inputs? t)
(make-accessible-slots settable-defaulted-input-slot-syms :inputs? t))) (:metaclass gdl-class))
(let ((,class-arg (find-class ',name)))
(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))))))
`(progn
(defclass ,name ,mixins
(,@(append (make-standard-slots)
(make-accessible-slots computed-slot-syms)
(make-accessible-slots settable-computed-slot-syms)
(make-accessible-slots uncached-computed-slot-syms)
(make-accessible-slots query-slot-syms)
(make-accessible-slots object-syms)
(make-accessible-slots quantified-object-syms)
(make-accessible-slots hidden-object-syms)
(make-accessible-slots quantified-hidden-object-syms)
(make-accessible-slots cached-function-syms)
(make-accessible-slots cached-method-syms)
(make-accessible-slots required-input-slot-syms :inputs? t)
(make-accessible-slots optional-input-slot-syms :inputs? t)
(make-accessible-slots settable-input-slot-syms :inputs? t)
(make-accessible-slots defaulted-input-slot-syms :inputs? t)
(make-accessible-slots settable-defaulted-input-slot-syms :inputs? t))) (:metaclass gdl-class))
(let ((,class-arg (find-class ',name)))
(let ((,old-message-keys (messages ,class-arg))
(,new-message-keys ',messages))
(dolist (key (set-difference ,old-message-keys ,new-message-keys))
(let ((method (ignore-errors
(find-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) nil
(list ,class-arg) nil))))
(when method
(when *report-gdl-redefinitions?*
(format t "~%Removing slot: ~a for object definition: ~s~%" key ',name))
(remove-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) method)))))
,(when (and *compile-documentation-database?* documentation)
`(when *load-documentation-database?*
(setf (gdl-documentation ,class-arg) ',documentation))))
(let ((,old-message-keys (messages ,class-arg))
(,new-message-keys ',messages))
(dolist (key (set-difference ,old-message-keys ,new-message-keys))
(let ((method (ignore-errors
(find-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) nil
(list ,class-arg) nil))))
(when method
(when *report-gdl-redefinitions?*
(format t "~%Removing slot: ~a for object definition: ~s~%" key ',name))
(remove-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) method)))))
,(when (and *compile-documentation-database?* documentation)
`(when *load-documentation-database?*
(setf (gdl-documentation ,class-arg) ',documentation))))
(when (message-documentation (find-class ',name)) (clrhash (message-documentation (find-class ',name))))
(when (message-source (find-class ',name))(clrhash (message-source (find-class ',name))))
(setf (messages (find-class ',name)) ',messages)
(setf (required-input-slots (find-class ',name)) ',required-input-slot-syms)
(setf (optional-input-slots (find-class ',name)) ',optional-input-slot-syms)
(setf (defaulted-input-slots (find-class ',name)) ',defaulted-input-slot-syms)
(setf (computed-slots (find-class ',name)) ',computed-slot-syms)
(setf (query-slots (find-class ',name)) ',query-slot-syms)
(setf (settable-computed-slots (find-class ',name)) ',settable-computed-slot-syms)
(setf (uncached-computed-slots (find-class ',name)) ',uncached-computed-slot-syms)
(setf (settable-optional-input-slots (find-class ',name)) ',settable-input-slot-syms)
(setf (settable-defaulted-input-slots (find-class ',name)) ',settable-defaulted-input-slot-syms)
(setf (functions (find-class ',name)) ',function-syms)
(setf (methods (find-class ',name)) ',method-syms)
(setf (cached-functions (find-class ',name)) ',cached-function-syms)
(setf (cached-methods (find-class ',name)) ',cached-method-syms)
(setf (objects (find-class ',name)) ',object-syms)
(setf (quantified-objects (find-class ',name)) ',quantified-object-syms)
(setf (hidden-objects (find-class ',name)) ',hidden-object-syms)
(setf (quantified-hidden-objects (find-class ',name)) ',quantified-hidden-object-syms)
(setf (trickle-down-slots (find-class ',name))
',(append object-syms quantified-object-syms hidden-object-syms quantified-hidden-object-syms trickle-down-slot-syms))
(setf (settable-slots (find-class ',name)) ',(append required-input-slot-syms settable-input-slot-syms
settable-defaulted-input-slot-syms settable-computed-slot-syms))
;; FLAG -- consider pre-cooking these expression lists
;;
,@(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)))
,@(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)
(when (message-documentation (find-class ',name)) (clrhash (message-documentation (find-class ',name))))
(when (message-source (find-class ',name))(clrhash (message-source (find-class ',name))))
(setf (messages (find-class ',name)) ',messages)
(setf (required-input-slots (find-class ',name)) ',required-input-slot-syms)
(setf (optional-input-slots (find-class ',name)) ',optional-input-slot-syms)
(setf (defaulted-input-slots (find-class ',name)) ',defaulted-input-slot-syms)
(setf (computed-slots (find-class ',name)) ',computed-slot-syms)
(setf (query-slots (find-class ',name)) ',query-slot-syms)
(setf (settable-computed-slots (find-class ',name)) ',settable-computed-slot-syms)
(setf (uncached-computed-slots (find-class ',name)) ',uncached-computed-slot-syms)
(setf (settable-optional-input-slots (find-class ',name)) ',settable-input-slot-syms)
(setf (settable-defaulted-input-slots (find-class ',name)) ',settable-defaulted-input-slot-syms)
(setf (functions (find-class ',name)) ',function-syms)
(setf (methods (find-class ',name)) ',method-syms)
(setf (cached-functions (find-class ',name)) ',cached-function-syms)
(setf (cached-methods (find-class ',name)) ',cached-method-syms)
(setf (objects (find-class ',name)) ',object-syms)
(setf (quantified-objects (find-class ',name)) ',quantified-object-syms)
(setf (hidden-objects (find-class ',name)) ',hidden-object-syms)
(setf (quantified-hidden-objects (find-class ',name)) ',quantified-hidden-object-syms)
(setf (trickle-down-slots (find-class ',name))
',(append object-syms quantified-object-syms hidden-object-syms quantified-hidden-object-syms trickle-down-slot-syms))
(setf (settable-slots (find-class ',name)) ',(append required-input-slot-syms settable-input-slot-syms
settable-defaulted-input-slot-syms settable-computed-slot-syms))
;; FLAG -- consider pre-cooking these expression lists
;;
,@(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)))
,@(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))
,@(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 (append objects hidden-objects))
,@(objects-section name (append objects hidden-objects))
,@(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)))
,@(functions-section name functions)
,@(functions-section name functions)
,@(methods-section name methods)
,@(methods-section name methods)
,@(trickle-down-slots-section trickle-down-slot-syms)
,@(trickle-down-slots-section trickle-down-slot-syms)
,@(trickle-down-slots-section (append object-syms quantified-object-syms hidden-object-syms quantified-hidden-object-syms)
:from-objects? t)
,@(trickle-down-slots-section (append object-syms quantified-object-syms hidden-object-syms quantified-hidden-object-syms)
:from-objects? t)
#+nil
(defmethod gdl-rule::%object-keywords%
((,self-arg ,name))
(remove-duplicates
(append ',object-syms ',quantified-object-syms
(when (next-method-p) (call-next-method)))))
#+nil
(defmethod gdl-rule::%object-keywords%
((,self-arg ,name))
(remove-duplicates
(append ',object-syms ',quantified-object-syms
(when (next-method-p) (call-next-method)))))
#+nil
(defmethod gdl-rule::%hidden-object-keywords%
((,self-arg ,name))
(remove-duplicates
(append ',hidden-object-syms ',quantified-hidden-object-syms
(when (next-method-p) (call-next-method)))))
#+nil
(defmethod gdl-rule::%hidden-object-keywords%
((,self-arg ,name))
(remove-duplicates
(append ',hidden-object-syms ',quantified-hidden-object-syms
(when (next-method-p) (call-next-method)))))
;;
;; FLAG -- maybe some of these others can go away as well.
;;
;;
;; FLAG -- maybe some of these others can go away as well.
;;
(let ((,self-arg (find-class ',name nil)))
(when ,self-arg
(setf (trickle-down-effective ,self-arg) nil)))
(let ((,self-arg (find-class ',name nil)))
(when ,self-arg
(setf (trickle-down-effective ,self-arg) nil)))
;;
;; FLAG -- use uiop:list-to-hash-set
;;
(defmethod gdl-rule::%trickle-down-slots%
;;
;; FLAG -- use uiop:list-to-hash-set
;;
(defmethod gdl-rule::%trickle-down-slots%
((,self-arg ,name))
(let ((class (class-of ,self-arg)))
(or (trickle-down-effective class)
......@@ -640,7 +644,7 @@ overview of <tt>define-object</tt> syntax."
(when (and (not (eql ,message-type-arg :local)) (next-method-p))
(call-next-method ,self-arg ,category-arg ,message-type-arg ,base-part-type-arg (1+ ,depth-arg)))))
(find-class ',name))))
(find-class ',name)))))
......
......@@ -159,18 +159,44 @@
(setq current-remark-string nil on-message? nil))))))
(defparameter *reserved-word-protected-packages* (list (find-package :gdl)
(find-package :geom-base)
(find-package :surf)))
(defun reserved-word-warning-or-error (name messages)
(unless (and (atom name)
(or (member (symbol-package name) *reserved-word-protected-packages*)))
(let ((reserved-violations (intersection messages +reserved-words+)))
(defparameter *reserved-words-hash* (make-hash-table))
;;
;; FLAG -- consider a scheme for controlling the overriding of your
;; own mixins as well, perhaps allowing for a list of
;; overridable-slots.
;;
(defun reserved-words-for (mixins)
(apply #'append
(mapcar
#'(lambda(mixin)
(when (member (glisp:intern (package-name (symbol-package mixin)) :keyword) *packages-to-lock*)
(or (gethash mixin *reserved-words-hash*)
(setf (gethash mixin *reserved-words-hash*)
(mapcar
#'(lambda(word) (glisp:intern word :gdl-acc))
(set-difference
(the-object (make-object mixin) message-list)
(append
(the-object (make-object mixin) (message-list :category :required-input-slots))
(the-object (make-object mixin) (message-list :category :optional-input-slots))
(the-object (make-object mixin) (message-list :category :settable-optional-input-slots))
(the-object (make-object mixin) (message-list :category :defaulted-input-slots))
(the-object (make-object mixin) (message-list :category :settable-defaulted-input-slots)))))))))
mixins)))
(defun reserved-word-warning-or-error (name messages mixins)
(unless (and (atom name) (member (glisp:intern (package-name (symbol-package name)) :keyword) *packages-to-lock*))
(let* ((reserved-words (reserved-words-for mixins))
(reserved-violations (intersection messages reserved-words))
(length (length reserved-violations)))
(when reserved-violations
(let ((is-or-are (if (= (length reserved-violations) 1) "is" "are"))
(s-or-blank (if (= (length reserved-violations) 1) "" "s"))
(a-or-blank (if (= (length reserved-violations) 1) "a " "")))
(let ((is-or-are (if (= length 1) "is" "are"))
(s-or-blank (if (= length 1) "" "s"))
(a-or-blank (if (= length 1) "a " "")))
(funcall (if *error-on-reserved-words?*
#'error
......
......@@ -210,3 +210,6 @@ values are a color indicator for the default foreground and background of graphi
:tasty :robot :tree :yadd :surf :smlib :genworks-gdl))
(defvar *quicklisp-home* nil)
(defvar *packages-to-lock*
(list :gendl :geom-base :cl-lite :gwl :gwl-graphics :tasty :robot :tree :yadd :surf :smlib :genworks-gdl))
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
("tests")
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:gwl :description
"The Gendl™ Generative Web Language (GWL)" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20150122" :depends-on
(asdf:defsystem
#:gwl
:description
"The Gendl™ Generative Web Language (GWL)"
:author
"Dave Cooper"
:license
"Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial
t
:version
"20150317"
:depends-on
(:bordeaux-threads :glisp :aserve)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/defparameters")
(:file "source/presets") (:file "source/base-html-sheet")
(:file "source/base-html-utils") (:file "source/macros")
((:file "source/package")
(:file "source/defparameters")
(:file "source/presets")
(:file "source/base-html-sheet")
(:file "source/base-html-utils")
(:file "source/macros")
(:file "source/ignore-errors-with-backtrace")
(:file "source/utilities") (:file "source/answer")
(:file "source/accessories") (:file "source/gdl-remote")
(:file "source/vanilla-remote") (:file "source/base64-utils")
(:file "source/cl-pdf-patches") (:file "source/color-palette")
(:file "source/crawler") (:file "source/log-utils")
(:file "source/new-urls") (:file "source/publish")
(:file "source/utilities")
(:file "source/answer")
(:file "source/accessories")
(:file "source/gdl-remote")
(:file "source/vanilla-remote")
(:file "source/base64-utils")
(:file "source/cl-pdf-patches")
(:file "source/color-palette")
(:file "source/crawler")
(:file "source/log-utils")
(:file "source/new-urls")
(:file "source/publish")
(:file "source/remote-object")
(:file "source/security-check-failed")
(:file "form-elements/source/grid-form-element")
(:file "form-elements/source/macros")
(:file "form-elements/source/primitives")
(:file "form-elements/source/short-test")
(:file "form-elements/source/test-seq")
(:file "form-elements/source/validation-tests")
(:file "ajax/source/parameters") (:file "ajax/source/ajax")
(:file "ajax/source/parameters")
(:file "ajax/source/ajax")
(:file "ajax/source/base-ajax-sheet")
(:file "ajax/source/skeleton-ui-element")
(:file "gwl-session/source/parameters")
......@@ -38,4 +54,5 @@
(:file "gwl-session/source/session-report")
(:file "js-libs/jquery/source/package")
(:file "js-libs/jquery/source/slider-form-control")
(:file "zzinit/source/initialize") (:file "zzinit/source/zzinit")))
(:file "zzinit/source/initialize")
(:file "zzinit/source/zzinit")))
......@@ -19,7 +19,7 @@
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gwl-user)
(in-package :gwl)
(publish :path "/color-map"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment