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
1f4c642a
Commit
1f4c642a
authored
Oct 28, 2011
by
Dave Cooper
Browse files
fixed png image output in yadd
parent
4b349a0a
Changes
7
Hide whitespace changes
Inline
Side-by-side
devo
View file @
1f4c642a
...
...
@@ -2,4 +2,16 @@
cd
`
dirname
"
$0
"
`
/Applications/Aquamacs.app/Contents/MacOS/Aquamacs
--no-splash
--no-init-file
-l
devo.el
-f
slime
$@
os_platform
=
`
uname
`
export
cl_platform
=
''
if
[
"
$os_platform
"
==
"Linux"
]
;
then
cl_platform
=
'Allegro'
emacs
--no-splash
--no-init-file
-l
devo.el
$@
elif
[
"
$os_platform
"
==
"Darwin"
]
;
then
cl_platform
=
'LispWorks'
/Applications/Aquamacs.app/Contents/MacOS/Aquamacs
--no-splash
--no-init-file
-l
devo.el
$@
fi
devo.el
View file @
1f4c642a
(
load
(
expand-file-name
"~/quicklisp/slime-helper.el"
))
(
setq
inferior-lisp-program
"~/bin/lw-console"
)
;;
;; FLAG -- learn how to add command line args to inferior-lisp-program
;; to load load.lisp for Genworks GDL automatically.
;;
(
if
(
string=
(
getenv
"cl_platform"
)
"LispWorks"
)
(
setq
inferior-lisp-program
"~/bin/lw-console"
)
(
if
(
string=
(
getenv
"cl_platform"
)
"Allegro"
)
(
setq
inferior-lisp-program
"/usr/local/acl/mlisp"
)
(
error
"Don't know what CL executable to use"
)))
(
defun
gdl
()
(
interactive
)
(
slime
))
(
setq
gdl:*gdl-toplevel*
"*slime-repl allegro*"
)
(
setq
gdl:*inferior-lisp*
"*inferior-lisp*"
)
(
global-set-key
"\C-x&"
'
(
lambda
()(
interactive
)
(
switch-to-buffer
gdl:*gdl-toplevel*
)))
(
global-set-key
"\C-x*"
'
(
lambda
()(
interactive
)
(
switch-to-buffer
gdl:*inferior-lisp*
)))
(
global-set-key
"\C-xy"
'
(
lambda
()
(
interactive
)
(
other-window
-1
)))
;;
;; FLAG -- comment the following if you want a tool bar.
;; (errors ignored in case running in a console terminal)
(
ignore-errors
(
tool-bar-mode
-1
))
(
setq
visible-bell
t
)
;;
;; FLAG -- uncomment the following if you don't need a menu bar.
;; (errors ignored in case running in a console terminal)
;;
;;(ignore-errors (menu-bar-mode -1))
;;
;; Use M-x clear-kill-ring in case you have too much garbage in the
;; kill ring
;;
(
defun
clear-kill-ring
()
(
interactive
)
(
setq
kill-ring
nil
))
;;
;; FLAG -- you can customize default GDL emacs colors here.
;;
(
defun
gdl:set-colors
()
(
interactive
)
(
progn
(
set-foreground-color
"white"
)
(
set-background-color
"midnight blue"
)
(
setq
default-frame-alist
(
append
default-frame-alist
'
((
background-color
.
"midnight blue"
))))
(
set-face-foreground
'default
"white"
)
(
set-face-foreground
'font-lock-type-face
"hotpink"
)
(
set-face-foreground
'font-lock-keyword-face
"Cyan"
)
(
set-face-foreground
'font-lock-string-face
"#88FFAA"
)
(
set-face-foreground
'font-lock-function-name-face
"#55ff88"
)
(
set-face-foreground
'font-lock-comment-face
"#888888"
)
(
set-face-foreground
'font-lock-builtin-face
"#ffff99"
)
(
add-to-list
'default-frame-alist
'
(
cursor-color
.
"RosyBrown4"
))
(
set-cursor-color
"#55FFFF"
)))
;; ignore errors when setting colors in case of running in console
;; terminal (there's probably a better way to test for this).
(
ignore-errors
(
gdl:set-colors
))
(
require
'cl
)
(
defun
add-gdl-font-lock-keywords
()
(
let
((
definition-keywords
(
regexp-opt
(
list
"define-object-amendment"
"define-object"
"define-view"
"define-lens"
"define-format"
"define-skin"
"defpart"
"defwriter"
"defcompanion"
"write-the-object"
"write-the"
"the "
"the-child"
"the-object"
"the-element"
)
t
))
(
keyword-keywords
(
regexp-opt
(
list
":documentation"
":input-slots"
":computed-slots"
":objects"
":hidden-objects"
":functions"
":methods"
":output-functions"
":skin"
":trickle-down-slots"
":type"
":sequence"
":size"
":parameters"
":pass-down"
":inputs"
":optional-inputs"
":modifiable-optional-inputs"
":descendant-attributes"
":attributes"
":parts"
":pseudo-parts"
":methods"
)
t
)))
(
pushnew
(
list
definition-keywords
0
font-lock-keyword-face
)
lisp-font-lock-keywords
)
(
pushnew
(
list
keyword-keywords
0
font-lock-type-face
)
lisp-font-lock-keywords
)))
(
add-gdl-font-lock-keywords
)
(
defmacro
defindent
(
name
indentation
)
(
let*
((
keyword-list
'
(
lisp-font-lock-keywords
t
t
t
nil
nil
nil
"&allow-other-keys"
))
(
spec
(
if
(
eq
indentation
'gdl-object-style
)
`
((
1
t
,
keyword-list
)
(
0
t
2
))
indentation
)))
`
(
put
',name
'lisp-indent-hook
',spec
)))
(
defun
gdl:define-indents
()
(
defindent
define-object
gdl-object-style
)
(
defindent
define-view
(
like
define-object
))
(
defindent
define-format
(
like
define-object
))
(
defindent
defpart
(
like
define-object
))
(
defindent
defwriter
(
like
define-object
))
(
defindent
defcompanion
(
like
define-object
)))
gdl/apps/yadd/source/define-object-documentation.lisp
View file @
1f4c642a
...
...
@@ -121,15 +121,6 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
:computed-slots
(
#+
nil
(
definition
`
(
define-object
,
(
the
part-full-symbol
)
(
,@
(
the
mixins-list
))
,@
(
mapcan
#'
(
lambda
(
section
)
(
list
(
the-object
section
category
)
(
the-object
section
bindings
)))
(
list-elements
(
the
sections
)))))
(
main-sheet-body
(
with-cl-who-string
()
...
...
@@ -303,23 +294,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
:functions
(
#+
nil
(
write-html-sheet
nil
(
html
(
:html
(
:head
(
the
default-header-content
)
(
:title
"Documentation for "
(
:princ
(
string
(
the
:part-full-symbol
)))
" in Package "
(
:princ
(
string
(
package-name
(
the
:part-package
))))))
(
:body
(
when
*developing?*
(
html
(
:p
(
the
(
write-development-links
)))))
;;(when *adsense?* (html (:p (:princ *adsense-code*))))
(
when
(
the
:return-object
)
(
html
(
:p
(
the
(
:write-back-link
:display-string
"<-Back"
)))))
(
the
(
:write-documentation
))
(
when
(
the
:return-object
)
(
html
(
:p
(
the
(
:write-back-link
:display-string
"<-Back"
)))))
(
:p
(
the
:write-footer
))))))
(
write-documentation
nil
...
...
@@ -454,12 +429,9 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(
or
(
search
"(generate-sample-drawing"
(
the
example-code
))
(
search
"(with-format (pdf"
(
the
example-code
))))
(
let
((
image-file
(
the
image-file
))
(
image-format
:png
)
(
pdf-file
(
merge-pathnames
"example.pdf"
#+
allegro
(
sys:temporary-directory
)
#-
allegro
sys::*temp-directory*
))
(
pdf-file
(
merge-pathnames
"example.pdf"
(
glisp:temporary-folder
)))
(
url
(
the
image-url
))
(
lisp-file
(
the
lisp-file
)))
(
publish
:path
url
:content-type
"image/png"
:format
:binary
...
...
@@ -497,7 +469,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(
delete-file
image-file
)
(
delete-file
lisp-file
)
(
delete-file
(
make-pathname
:name
(
pathname-name
lisp-file
)
:type
g
dl:
:*fasl-
default-type
*
:type
g
lisp
:*fasl-
extension
*
:directory
(
pathname-directory
lisp-file
)
:device
(
pathname-device
lisp-file
))))))))
...
...
gdl/base/gdl-base.asd
View file @
1f4c642a
...
...
@@ -4,11 +4,12 @@
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license
"AGPL unless otherwise indicated"
:serial
t
:version
"2011101700"
:components
:version
"2011102800"
:components
((
:file
"common/package"
)
(
:file
"common/genworks"
)
(
:file
"common/start-gdl"
)
(
:file
"prereqs/source/parameters"
)
(
:file
"common/genworks"
)
(
:file
"common/start-gdl"
)
(
:file
"prereqs/source/parameters"
)
(
:file
"prereqs/source/metaclasses"
)
(
:file
"prereqs/source/utilities"
)
(
:file
"expanders/source/inputs"
)
...
...
@@ -28,8 +29,12 @@
(
: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/null-part"
)
(
:file
"rest/source/quantification"
)
(
:file
"rest/source/sequence"
)
(
:file
"rest/source/init"
)))
(
:file
"tests/source/package"
)
(
:file
"tests/source/andrew"
)
(
:file
"tests/source/hello"
)
(
:file
"tests/source/minimal"
)))
\ No newline at end of file
gdl/base/macros/source/defaulting.lisp
View file @
1f4c642a
...
...
@@ -21,6 +21,7 @@
(
in-package
:gdl
)
(
defmacro
defaulting
(
form
&optional
default
)
"Lisp object. Returns a default value if the reference-chain is not handled.
...
...
gdl/base/rest/source/vanilla-mixin.lisp
View file @
1f4c642a
...
...
@@ -30,7 +30,7 @@
:documentation
(
:description
"Vanilla-Mixin is automatically inherited by every object
created in GDL. It provides basic messages which are common to all GDL objects defined
with the define-object macro, unless <tt>:no-vanilla-mixin t</tt> is specified at the toplevel
with the define-object macro, unless <tt>:no-vanilla-mixin t</tt> is specif
qq
ied at the toplevel
of the define-object form."
)
:input-slots
...
...
@@ -577,13 +577,16 @@ by the update."
(
methods
(
the
(
:message-list
:category
:functions
)))
(
immune-messages
(
list
:$$ta2
:$$ta2-object
:$$tatu
:$$tatu-object
))
;;
;; FLAG -- get rid of special-casing and ignore-errors for root-object-object.
;;
(
root-object-object-vt
(
when
(
defaulting
(
the
root-object-object
))
(
when
(
ignore-errors
(
the
root-object-object
))
(
mapcar
#'
(
lambda
(
path
)
(
when
(
consp
(
rest
path
))
(
cons
(
append
(
first
path
)
(
list
:root-object-object
))
(
rest
path
))))
(
gdl-acc::%version-tree%
(
defaulting
(
the
root-object-object
)))))))
(
gdl-acc::%version-tree%
(
ignore-errors
(
the
root-object-object
)))))))
(
let
((
cached-messages
(
set-difference
all-messages
(
append
methods
immune-messages
))))
...
...
gdl/gwl/source/genworks.lisp
View file @
1f4c642a
...
...
@@ -13,8 +13,8 @@
#:match-regexp
#:patches-dir
#:process-run-function
#:replace-regexp
#:remote-host
#:replace-regexp
#:socket-bytes-written
#:with-timeout-sym
...
...
@@ -76,13 +76,15 @@
#-
allegro
#'
acl-compat.mp:process-run-function
name-or-options
preset-function
args
))
(
defun
replace-regexp
(
string
regexp
to-string
)
(
cl-ppcre:regex-replace-all
regexp
string
to-string
))
(
defun
remote-host
(
socket
)
#+
allegro
(
socket:remote-host
socket
)
#-
allegro
(
acl-compat.socket:remote-host
socket
))
(
defun
replace-regexp
(
string
regexp
to-string
)
(
cl-ppcre:regex-replace-all
regexp
string
to-string
))
(
defun
socket-bytes-written
(
socket
)
#-
allegro
(
declare
(
ignore
socket
))
#+
allegro
(
excl::socket-bytes-written
socket
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment