Commit ec8554f9 authored by Dave Cooper's avatar Dave Cooper
Browse files

cleaned up package redefinitions, fixed several trickle-down-alots warnings

parent 648f2235
......@@ -21,18 +21,6 @@
(in-package :com.genworks.lisp)
(glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:export #:copy-directory
#:copy-file
#:delete-directory-and-files
#:dump-memory
#:implementation-identifier
#:make-gdl-app
#:next-datestamp
)))
(defun copy-file (from to &key overwrite?)
(fad:copy-file from to :overwrite overwrite?))
......
......@@ -140,13 +140,12 @@
(
(visit-definition-in-emacs
(definition)
(declare (ignore definition))
(error "Sorry! This is supposed to do 'lisp-find-definition' in emacs, but not working yet... Please send email to support@genworks.com"))
#+nil
(visit-definition-in-emacs
(definition)
(let ((emacs-lisp-command (format nil "(fi:lisp-find-definition ~s)" definition)))
(print-variables emacs-lisp-command)
#+allegro (lep::eval-in-emacs emacs-lisp-command)))
......
......@@ -23,9 +23,10 @@
;;
;; FLAG -- experimental, needs a lot of cleaning up to truly support two viewports.
;;
#+nil
(in-package :tasty)
#+nil
(define-object two-viewports (assembly)
:computed-slots
......@@ -81,7 +82,7 @@
)
)
#+nil
(define-lens (html-format two-viewports)()
:output-functions
......@@ -202,4 +203,4 @@
))))
(publish-gwl-app "/t2v" "tasty::two-viewports" :make-object-args (list :title "Genworks tasty 2vp"))
;;(publish-gwl-app "/t2v" "tasty::two-viewports" :make-object-args (list :title "Genworks tasty 2vp"))
......@@ -28,37 +28,37 @@
:input-slots
(tatu-root root-object
(vector-graphics-onclick? (not (eql (the digitation-mode) :select-object)))
(color nil)
(line-thickness-selected nil)
onclick-function
(inspected-object nil)
(display-list-object-roots
(let (result)
;;(the recompute?)
(maphash #'(lambda(root-path value)
(declare (ignore value))
(push (the root-object (follow-root-path root-path)) result))
(the view-object-roots-root-paths-hash)) (nreverse result)))
(display-list-objects
(let (result)
(the recompute?)
(maphash #'(lambda(root-path value)
(declare (ignore value))
(push (the root-object (follow-root-path root-path)) result))
(the view-objects-root-paths-hash)) (nreverse result)))
(image-format-default :raphael)
)
(vector-graphics-onclick? (not (eql (the digitation-mode) :select-object)))
(color nil)
(line-thickness-selected nil)
onclick-function
(inspected-object nil)
(display-list-object-roots
(let (result)
;;(the recompute?)
(maphash #'(lambda(root-path value)
(declare (ignore value))
(push (the root-object (follow-root-path root-path)) result))
(the view-object-roots-root-paths-hash)) (nreverse result)))
(display-list-objects
(let (result)
(the recompute?)
(maphash #'(lambda(root-path value)
(declare (ignore value))
(push (the root-object (follow-root-path root-path)) result))
(the view-objects-root-paths-hash)) (nreverse result)))
(image-format-default :raphael)
)
......@@ -101,7 +101,7 @@
(operations-list nil :settable)
)
......@@ -155,7 +155,7 @@
(net.aserve::debug-on :notrap)))
(break (the image-url))))))
(pop-operation!
()
......@@ -175,13 +175,21 @@
(object)
(the (add-display-controls! object))
(dolist (leaf (the-object object leaves)) (the (add-node! leaf)))
(the (set-slot! :operations-list
(append (the operations-list)
(list (list :operation :add-leaves* :object object))))))
(leaves-displayed?
(object)
(gethash (the-object (first (the-object object leaves)) root-path)
(the view-objects-root-paths-hash)))
(toggle-leaves*!
(object)
(if (the (leaves-displayed? object))
(the (add-leaves*! object))
(the (delete-leaves! object))))
(delete-node!
(object)
......@@ -229,9 +237,6 @@
(when (or (and (<= (length root-path) (length key))
(equalp (reverse root-path)
(subseq (reverse key) 0 (length root-path)))))
(progn (format t "Removing ~s from ~s~%" root-path hash))
(remhash key hash))) hash) hash)))))
(draw-leaves!
......@@ -263,9 +268,9 @@
(if (or color line-thickness)
(setf (gethash root-path hash)
(list :line-thickness line-thickness
:color (the color)))
(when (gethash root-path hash) (remhash root-path hash))))
(list :line-thickness line-thickness
:color (the color)))
(when (gethash root-path hash) (remhash root-path hash))))
hash)))))
(clear! ()
......@@ -319,8 +324,8 @@
(:x3dom (the (write-embedded-x3dom-world :include-view-controls? nil))))))))))
......@@ -21,12 +21,6 @@
(in-package :com.genworks.lisp)
(glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:nicknames :glisp)
(:export #:parse-xml)))
#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (require :pxml))
(defun parse-xml (xml-string &rest args)
......
......@@ -23,6 +23,14 @@
(defparameter *trap-errors?* t)
;;
;; FLAG -- this depends on jQuery. Assume the containing sheet has
;; :use-jquery? t
;;
;; This shoud be upgraded to avoid that assumption and check with the
;; containing sheet, and other sheets in the tree. If not using
;; jquery, then use it here.
;;
(define-object newertree (sheet-section)
:input-slots
......@@ -48,13 +56,11 @@
:computed-slots
(
;;
;; FLAG -- to skeleton-ui-mixin and out of base-html-sheet.
;; This overrides the one from skeleton-ui-element because we don't want to filter
;; the root-object-object in the case of the tree.
;;
(base64-encoded-root-path (base64-encode-safe (format nil "~s" (the root-path))))
(dom-id (the base64-encoded-root-path))
;;
;; END FLAG
;;
(tatu-color (or (when (getf (the local-display-controls) :color)
(string-append "#" (getf (the local-display-controls) :color)))
......@@ -77,9 +83,6 @@
(the target-object children))
(the target-object visible-children)))
;;
;; DJC - try to correct error reported 2011-03-30 by SvdE
;;
(safe-strings-for-display
(let ((string (multiple-value-bind (strings error)
(ignore-errors (the target-object
......@@ -98,18 +101,6 @@ Converting to a string to avoid error."
string)
(format nil "~s" string)))))
;;
;; DJC - try to correct error reported 2011-03-30 by SvdE
;;
#+nil
(safe-strings-for-display (multiple-value-bind (strings error)
(ignore-errors (the target-object strings-for-display))
(cond ((typep error 'error)
(format nil "! ~a ! from strings-for-display" error))
((the color-error?)
(format nil "~a ! ~a ! from color-hex" strings (the color-or-error)))
(t strings))))
(color-or-error (multiple-value-bind (color error)
(ignore-errors (the target-object color-hex))
(if (typep error 'error) error color)))
......@@ -148,23 +139,11 @@ Converting to a string to avoid error."
:onclick (the (gdl-ajax-call :function-key :toggle-state!))))))
))
;; JB-090810 when the node does not have a child node, it is a leaf - so display
;; a leaf graphic and this is coupled via CSS
(unless (the child-nodes)
(htm ((:span :class "leaf")))
)
;; this is the name of the object including the gdlAjax call wrapped in a span
;; JB-090813 in order to let the actions hover when the mouse is over the
;; object name, and remove the actions imgs when the mouse is leaving the
;; object name (or the images) I need to wrap this in an extra span
;; to correct visual stuff this gets a class .container
;; this code depends heavily on the presence of jQuery as the show() and hide()
;; functions, including the selectors are jQuery functions
((:span :class "container"
;; JB-090813 yep this is jQuery functionality
:onmouseover "$(this).children('.actions').css('display','inline')"
:onmouseout "$(this).children('.actions').hide()")
......@@ -211,7 +190,7 @@ Converting to a string to avoid error."
((:span :class "highlight"
:onclick (the (gdl-ajax-call :function-key :set-and-call-click-mode!
:arguments (list :highlight)))
:title "Highlight this object")))))
:title "Toggle Leaves of this object")))))
)
......@@ -277,6 +256,20 @@ Converting to a string to avoid error."
(ecase mode
(:inspect (the inspector (set-object! (the target-object))))
(:add-leaves (the viewport (add-leaves! (the target-object))))
(:highlight (if (the viewport (leaves-displayed? (the target-object)))
(the viewport (delete-leaves! (the target-object)))
(the viewport (add-leaves*! (the target-object)))))
;;
;; Add :highlighted? entry to the dynamic (thread-local)
;; display-list parameter, not to the actual object. Object has
;; no guarantee of carrying the highlighted? slot and we are not
;; going to make base-object or vanilla-mixin even heavier by
;; adding yet another slots.
;;
;; For the time being, highlight functionality simply
;; adds/deletes individual leaves.
;;
#+nil
(:highlight (if (the target-object highlighted?)
(progn
(the target-object (set-slot! :highlighted? nil))
......@@ -292,20 +285,14 @@ Converting to a string to avoid error."
:pass-down (%tree-root% respondent onclick-function expand-mode display-controls-hash
show-onmouseover-buttons?
)
:visible-child? (>= (the-child index) (the safe-child-first))
:depth (1+ (the depth))
;;:visible-child? (>= (the-child index) (the safe-child-first))
;;:depth (1+ (the depth))
:target-object (let ((node (nth (the-child index) (the safe-children))))
(if (listp node)
(make-object 'tasty-child-error
:error (getf node :error)
:object-key (getf node :object-key))
node)))
#+nil
(nodes :type 'newertree
:sequence (:size (length (the target-object children)))
:pass-down (respondent onclick-function expand-mode)
:target-object (nth (the-child index) (the target-object children)))))
node)))))
(define-object tasty-child-error ()
:input-slots (error object-key)
......
......@@ -210,7 +210,10 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
:if-exists :supersede
:if-does-not-exist :create)
(princ (the example-code) out))
(let (*redefinition-warnings*) (load (compile-file (the lisp-file))))) :uncached)
;;
;; FLAG -- try to muffle redefinition warnings here.
;;
(load (compile-file (the lisp-file)))) :uncached)
(image-file (glisp:temporary-file :extension "png"))
......
......@@ -21,15 +21,6 @@
(in-package :com.genworks.lisp)
(glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:nicknames :glisp)
(:export #:autoloaded-packages
#:package-documentation
#:function-documentation
#:variable-documentation)))
(defun autoloaded-packages ()
(append (list :win :windows :regexp)
......
......@@ -19,110 +19,6 @@
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
#+ecl (error "
D'oh! GenDL is not yet supported on ECL. If you would like to try porting it, start with the file
gdl/base/common/genworks.lisp.
Also, PortableAllegroserve is needed for the web framework.
If you are interested in this effort we would love to hear from you at open-source@genworks.com.
")
#+clisp (error "
D'oh! GenDL is not yet supported on CLISP. If you would like to try porting it, start with the file,
gdl/base/common/genworks.lisp.
Also, PortableAllegroserve is needed for the web framework.
If you are interested in this effort we would love to hear from you at open-source@genworks.com.
")
#+scl (error "
D'oh! GenDL is not yet supported on Scieneer CL. If you would like to try porting it, start with the file,
gdl/base/common/genworks.lisp.
Also, PortableAllegroserve is needed for the web framework.
If you are interested in this effort we would love to hear from you at open-source@genworks.com.
")
#+genera (error "
D'oh! GenDL is not yet supported on Genera. If you would like to try porting it, start with the file,
gdl/base/common/genworks.lisp.
Also, PortableAllegroserve is needed for the web framework.
If you are interested in this effort we would love to hear from you at open-source@genworks.com.
")
#+corman (error "
D'oh! GenDL is not yet supported on Corman Lisp. If you would like to try porting it, start with the file,
gdl/base/common/genworks.lisp.
Also, PortableAllegroserve is needed for the web framework.
If you are interested in this effort we would love to hear from you at open-source@genworks.com.
")
#-(or allegro lispworks sbcl ccl abcl ecl clisp scl genera)
(error "
GenDL is not yet supported on this Lisp. By the way, what Lisp
is this? Please let us know at open-source@genworks.com.
")
#-(or allegro lispworks sbcl ccl abcl clos) (error "Need package for mop:validate-superclass for currently running lisp.~%")
(eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:shadow #:intern)
(:nicknames :glisp)
(:import-from #+(or allegro abcl) :mop #+lispworks :hcl #+sbcl :sb-mop #+ccl :ccl #+ecl :clos
#:validate-superclass)
(:export #:*external-text-format*
#:*gdl-home*
#:*gdl-program-home*
#:*genworks-source-home*
#:basic-command-line-arguments
#:begin-redefinitions-ok
#:current-directory
#:define-constant
#:direct-superclasses
#:direct-superclass-names
#:display-startup-banner
#:end-redefinitions-ok
#:eql-specializer
#:executable-homedir-pathname
#:featurep
#:gl-class-name
#:gl-method-specializers
#:hex-string-to-integer
#:intern
#:make-sans-value-equalp-hash-table
#:make-sans-value-hash-table
#:make-weak-hash-table
#:set-default-float-format
#:set-default-package
#:set-defpackage-behavior
#:set-local-compiler-tweaks
#:set-window-titles
#:source-pathname
#:system-home
#:upcase
#:validate-superclass
#:with-definition-unit
#:without-package-variance-warnings
#:w-o-interrupts
#:xref-off
#:xref-on)))
(in-package :com.genworks.lisp)
(defparameter *external-text-format*
......@@ -376,7 +272,7 @@ is this? Please let us know at open-source@genworks.com.
(:case-sensitive-lower string)))
(defmacro w-o-interrupts (&body body)
(format t "NOTE: Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else in glisp:w-o-interrupts.")
(format t "~&NOTE: Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else in glisp:w-o-interrupts.~%")
#-(or allegro lispworks cmu sbcl ccl) (error "Need implementation for without-interrupts for currently running lisp.~%")
`(#+allegro excl:without-interrupts
#+lispworks progn
......
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;; Copyright 2002, 2007, 2013 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
......@@ -21,6 +21,16 @@
(in-package :common-lisp-user)
#-(or allegro lispworks sbcl ccl) (error "
D'oh! GenDL is not yet supported on ~a. If you would like to try porting it, start with this file,
gdl/base/common/genworks.lisp.
Also, PortableAllegroserve is needed for the web framework.
If you are interested in this effort we would love to hear from you at open-source@genworks.com.
" (lisp-implementation-type))
(defpackage :gdl
(:documentation "General-purpose Declarative Language")
(:use :common-lisp)
......@@ -240,6 +250,316 @@
#:room-report
#:*onclick-function*))
#-(or allegro lispworks sbcl ccl abcl ecl) (error "Need package for mop:validate-superclass for currently running lisp.~%")
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:shadow #:intern)
(:nicknames :glisp)
(:import-from #+(or allegro abcl) :mop #+lispworks :hcl #+sbcl :sb-mop #+ccl :ccl #+ecl :clos
#:validate-superclass)
(:export #:*external-text-format*
#:*gdl-home*
#:*gdl-program-home*
#:*genworks-source-home*
#:basic-command-line-arguments
#:begin-redefinitions-ok
#:current-directory
#:define-constant
#:direct-superclasses
#:direct-superclass-names
#:display-startup-banner
#:end-redefinitions-ok
#:eql-specializer
#:executable-homedir-pathname
#:featurep
#:gl-class-name
#:gl-method-specializers
#:hex-string-to-integer
#:intern
#:make-sans-value-equalp-hash-table
#:make-sans-value-hash-table
#:make-weak-hash-table
#:set-default-float-format
#:set-default-package
#:set-defpackage-behavior
#:set-local-compiler-tweaks
#:set-window-titles
#:source-pathname
#:system-home
#:upcase
#:validate-superclass
#:with-definition-unit
#:without-package-variance-warnings
#:w-o-interrupts
#:xref-off
#:xref-on
;;
;; Implemented in gdl/cl-lite/source/genworks.lisp.
;;
#:*fasl-extension*
#:concatenate-fasls
#:directory-list
#:file-directory-p
#:temporary-folder
#:temporary-file
;;
;; Implemented in gdl/geom-base/prereqs/source/genworks.lisp
;;
#:get-pid
#:run-gs
#:run-shell-command
#:set-gs-path
;;
;; Implemented in gdl/gwl/source/genworks.lisp
;;
#:*enable-utf8?*
#:*base64-encode-func*
#:*base64-decode-func*
#:class-slots
#:gc-full
#:get-backtrace
#:initialize-multiprocessing
#:match-regexp
#:patches-dir
#:process-run-function
#:remote-host
#:replace-regexp
#:room-report
#:slot-definition-name
#:socket-bytes-written
#:split-regexp
#:with-timeout-sym
;;
;; Implemented in regression/utils/source/genworks.lisp
;;
#:close-old-areas
#:open-old-areas
#:get-mem-info