Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
ec8554f9
Commit
ec8554f9
authored
Jan 21, 2013
by
Dave Cooper
Browse files
cleaned up package redefinitions, fixed several trickle-down-alots warnings
parent
648f2235
Changes
47
Hide whitespace changes
Inline
Side-by-side
build/source/genworks.lisp
View file @
ec8554f9
...
...
@@ -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?
))
...
...
gdl/apps/tasty/source/inspector.lisp
View file @
ec8554f9
...
...
@@ -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
)))
...
...
gdl/apps/tasty/source/two-viewports.lisp
View file @
ec8554f9
...
...
@@ -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"))
gdl/apps/tasty/source/viewport.lisp
View file @
ec8554f9
...
...
@@ -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
))))))))))
gdl/apps/translators/xml/source/genworks.lisp
View file @
ec8554f9
...
...
@@ -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
)
...
...
gdl/apps/tree/source/newertree.lisp
View file @
ec8554f9
...
...
@@ -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
)
...
...
gdl/apps/yadd/source/define-object-documentation.lisp
View file @
ec8554f9
...
...
@@ -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"
))
...
...
gdl/apps/yadd/source/genworks.lisp
View file @
ec8554f9
...
...
@@ -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
)
...
...
gdl/base/common/genworks.lisp
View file @
ec8554f9
...
...
@@ -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
...
...
gdl/base/common/package.lisp
View file @
ec8554f9
;;
;; Copyright 2002
-
201
1
Genworks International and Genworks BV
;; Copyright 2002
, 2007,
201
3
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